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
412 foreach id $displayorder {
413 catch {unset children($n,$id)}
414 catch {unset commitrow($n,$id)}
415 catch {unset ordertok($n,$id)}
417 foreach vid [array names idpending "$n,*"] {
418 unset idpending($vid)
421 catch {unset selectedline}
422 catch {unset thickerline}
423 catch {unset viewdata($n)}
432 proc parsecommit {id contents listed} {
433 global commitinfo cdate
442 set hdrend [string first "\n\n" $contents]
444 # should never happen...
445 set hdrend [string length $contents]
447 set header [string range $contents 0 [expr {$hdrend - 1}]]
448 set comment [string range $contents [expr {$hdrend + 2}] end]
449 foreach line [split $header "\n"] {
450 set tag [lindex $line 0]
451 if {$tag == "author"} {
452 set audate [lindex $line end-1]
453 set auname [lrange $line 1 end-2]
454 } elseif {$tag == "committer"} {
455 set comdate [lindex $line end-1]
456 set comname [lrange $line 1 end-2]
460 # take the first non-blank line of the comment as the headline
461 set headline [string trimleft $comment]
462 set i [string first "\n" $headline]
464 set headline [string range $headline 0 $i]
466 set headline [string trimright $headline]
467 set i [string first "\r" $headline]
469 set headline [string trimright [string range $headline 0 $i]]
472 # git rev-list indents the comment by 4 spaces;
473 # if we got this via git cat-file, add the indentation
475 foreach line [split $comment "\n"] {
476 append newcomment " "
477 append newcomment $line
478 append newcomment "\n"
480 set comment $newcomment
482 if {$comdate != {}} {
483 set cdate($id) $comdate
485 set commitinfo($id) [list $headline $auname $audate \
486 $comname $comdate $comment]
489 proc getcommit {id} {
490 global commitdata commitinfo
492 if {[info exists commitdata($id)]} {
493 parsecommit $id $commitdata($id) 1
496 if {![info exists commitinfo($id)]} {
497 set commitinfo($id) [list [mc "No commit information available"]]
504 global tagids idtags headids idheads tagobjid
505 global otherrefids idotherrefs mainhead mainheadid
507 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
510 set refd [open [list | git show-ref -d] r]
511 while {[gets $refd line] >= 0} {
512 if {[string index $line 40] ne " "} continue
513 set id [string range $line 0 39]
514 set ref [string range $line 41 end]
515 if {![string match "refs/*" $ref]} continue
516 set name [string range $ref 5 end]
517 if {[string match "remotes/*" $name]} {
518 if {![string match "*/HEAD" $name]} {
519 set headids($name) $id
520 lappend idheads($id) $name
522 } elseif {[string match "heads/*" $name]} {
523 set name [string range $name 6 end]
524 set headids($name) $id
525 lappend idheads($id) $name
526 } elseif {[string match "tags/*" $name]} {
527 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
528 # which is what we want since the former is the commit ID
529 set name [string range $name 5 end]
530 if {[string match "*^{}" $name]} {
531 set name [string range $name 0 end-3]
533 set tagobjid($name) $id
535 set tagids($name) $id
536 lappend idtags($id) $name
538 set otherrefids($name) $id
539 lappend idotherrefs($id) $name
546 set thehead [exec git symbolic-ref HEAD]
547 if {[string match "refs/heads/*" $thehead]} {
548 set mainhead [string range $thehead 11 end]
549 if {[info exists headids($mainhead)]} {
550 set mainheadid $headids($mainhead)
556 # skip over fake commits
557 proc first_real_row {} {
558 global nullid nullid2 displayorder numcommits
560 for {set row 0} {$row < $numcommits} {incr row} {
561 set id [lindex $displayorder $row]
562 if {$id ne $nullid && $id ne $nullid2} {
569 # update things for a head moved to a child of its previous location
570 proc movehead {id name} {
571 global headids idheads
573 removehead $headids($name) $name
574 set headids($name) $id
575 lappend idheads($id) $name
578 # update things when a head has been removed
579 proc removehead {id name} {
580 global headids idheads
582 if {$idheads($id) eq $name} {
585 set i [lsearch -exact $idheads($id) $name]
587 set idheads($id) [lreplace $idheads($id) $i $i]
593 proc show_error {w top msg} {
594 message $w.m -text $msg -justify center -aspect 400
595 pack $w.m -side top -fill x -padx 20 -pady 20
596 button $w.ok -text [mc OK] -command "destroy $top"
597 pack $w.ok -side bottom -fill x
598 bind $top <Visibility> "grab $top; focus $top"
599 bind $top <Key-Return> "destroy $top"
603 proc error_popup msg {
607 show_error $w $w $msg
610 proc confirm_popup msg {
616 message $w.m -text $msg -justify center -aspect 400
617 pack $w.m -side top -fill x -padx 20 -pady 20
618 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
619 pack $w.ok -side left -fill x
620 button $w.cancel -text [mc Cancel] -command "destroy $w"
621 pack $w.cancel -side right -fill x
622 bind $w <Visibility> "grab $w; focus $w"
628 option add *Panedwindow.showHandle 1 startupFile
629 option add *Panedwindow.sashRelief raised startupFile
630 option add *Button.font uifont startupFile
631 option add *Checkbutton.font uifont startupFile
632 option add *Radiobutton.font uifont startupFile
633 option add *Menu.font uifont startupFile
634 option add *Menubutton.font uifont startupFile
635 option add *Label.font uifont startupFile
636 option add *Message.font uifont startupFile
637 option add *Entry.font uifont startupFile
641 global canv canv2 canv3 linespc charspc ctext cflist
643 global findtype findtypemenu findloc findstring fstring geometry
644 global entries sha1entry sha1string sha1but
645 global diffcontextstring diffcontext
647 global maincursor textcursor curtextcursor
648 global rowctxmenu fakerowmenu mergemax wrapcomment
649 global highlight_files gdttype
650 global searchstring sstring
651 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
652 global headctxmenu progresscanv progressitem progresscoords statusw
653 global fprogitem fprogcoord lastprogupdate progupdatepending
654 global rprogitem rprogcoord
658 .bar add cascade -label [mc "File"] -menu .bar.file
660 .bar.file add command -label [mc "Update"] -command updatecommits
661 .bar.file add command -label [mc "Reread references"] -command rereadrefs
662 .bar.file add command -label [mc "List references"] -command showrefs
663 .bar.file add command -label [mc "Quit"] -command doquit
665 .bar add cascade -label [mc "Edit"] -menu .bar.edit
666 .bar.edit add command -label [mc "Preferences"] -command doprefs
669 .bar add cascade -label [mc "View"] -menu .bar.view
670 .bar.view add command -label [mc "New view..."] -command {newview 0}
671 .bar.view add command -label [mc "Edit view..."] -command editview \
673 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
674 .bar.view add separator
675 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
676 -variable selectedview -value 0
679 .bar add cascade -label [mc "Help"] -menu .bar.help
680 .bar.help add command -label [mc "About gitk"] -command about
681 .bar.help add command -label [mc "Key bindings"] -command keys
683 . configure -menu .bar
685 # the gui has upper and lower half, parts of a paned window.
686 panedwindow .ctop -orient vertical
688 # possibly use assumed geometry
689 if {![info exists geometry(pwsash0)]} {
690 set geometry(topheight) [expr {15 * $linespc}]
691 set geometry(topwidth) [expr {80 * $charspc}]
692 set geometry(botheight) [expr {15 * $linespc}]
693 set geometry(botwidth) [expr {50 * $charspc}]
694 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
695 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
698 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
699 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
701 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
703 # create three canvases
704 set cscroll .tf.histframe.csb
705 set canv .tf.histframe.pwclist.canv
707 -selectbackground $selectbgcolor \
708 -background $bgcolor -bd 0 \
709 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
710 .tf.histframe.pwclist add $canv
711 set canv2 .tf.histframe.pwclist.canv2
713 -selectbackground $selectbgcolor \
714 -background $bgcolor -bd 0 -yscrollincr $linespc
715 .tf.histframe.pwclist add $canv2
716 set canv3 .tf.histframe.pwclist.canv3
718 -selectbackground $selectbgcolor \
719 -background $bgcolor -bd 0 -yscrollincr $linespc
720 .tf.histframe.pwclist add $canv3
721 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
722 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
724 # a scroll bar to rule them
725 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
726 pack $cscroll -side right -fill y
727 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
728 lappend bglist $canv $canv2 $canv3
729 pack .tf.histframe.pwclist -fill both -expand 1 -side left
731 # we have two button bars at bottom of top frame. Bar 1
733 frame .tf.lbar -height 15
735 set sha1entry .tf.bar.sha1
736 set entries $sha1entry
737 set sha1but .tf.bar.sha1label
738 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
739 -command gotocommit -width 8
740 $sha1but conf -disabledforeground [$sha1but cget -foreground]
741 pack .tf.bar.sha1label -side left
742 entry $sha1entry -width 40 -font textfont -textvariable sha1string
743 trace add variable sha1string write sha1change
744 pack $sha1entry -side left -pady 2
746 image create bitmap bm-left -data {
747 #define left_width 16
748 #define left_height 16
749 static unsigned char left_bits[] = {
750 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
751 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
752 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
754 image create bitmap bm-right -data {
755 #define right_width 16
756 #define right_height 16
757 static unsigned char right_bits[] = {
758 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
759 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
760 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
762 button .tf.bar.leftbut -image bm-left -command goback \
763 -state disabled -width 26
764 pack .tf.bar.leftbut -side left -fill y
765 button .tf.bar.rightbut -image bm-right -command goforw \
766 -state disabled -width 26
767 pack .tf.bar.rightbut -side left -fill y
769 # Status label and progress bar
770 set statusw .tf.bar.status
771 label $statusw -width 15 -relief sunken
772 pack $statusw -side left -padx 5
773 set h [expr {[font metrics uifont -linespace] + 2}]
774 set progresscanv .tf.bar.progress
775 canvas $progresscanv -relief sunken -height $h -borderwidth 2
776 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
777 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
778 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
779 pack $progresscanv -side right -expand 1 -fill x
780 set progresscoords {0 0}
783 bind $progresscanv <Configure> adjustprogress
784 set lastprogupdate [clock clicks -milliseconds]
785 set progupdatepending 0
787 # build up the bottom bar of upper window
788 label .tf.lbar.flabel -text "[mc "Find"] "
789 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
790 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
791 label .tf.lbar.flab2 -text " [mc "commit"] "
792 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
794 set gdttype [mc "containing:"]
795 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
797 [mc "touching paths:"] \
798 [mc "adding/removing string:"]]
799 trace add variable gdttype write gdttype_change
800 pack .tf.lbar.gdttype -side left -fill y
803 set fstring .tf.lbar.findstring
804 lappend entries $fstring
805 entry $fstring -width 30 -font textfont -textvariable findstring
806 trace add variable findstring write find_change
807 set findtype [mc "Exact"]
808 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
809 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
810 trace add variable findtype write findcom_change
811 set findloc [mc "All fields"]
812 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
813 [mc "Comments"] [mc "Author"] [mc "Committer"]
814 trace add variable findloc write find_change
815 pack .tf.lbar.findloc -side right
816 pack .tf.lbar.findtype -side right
817 pack $fstring -side left -expand 1 -fill x
819 # Finish putting the upper half of the viewer together
820 pack .tf.lbar -in .tf -side bottom -fill x
821 pack .tf.bar -in .tf -side bottom -fill x
822 pack .tf.histframe -fill both -side top -expand 1
824 .ctop paneconfigure .tf -height $geometry(topheight)
825 .ctop paneconfigure .tf -width $geometry(topwidth)
827 # now build up the bottom
828 panedwindow .pwbottom -orient horizontal
830 # lower left, a text box over search bar, scroll bar to the right
831 # if we know window height, then that will set the lower text height, otherwise
832 # we set lower text height which will drive window height
833 if {[info exists geometry(main)]} {
834 frame .bleft -width $geometry(botwidth)
836 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
841 button .bleft.top.search -text [mc "Search"] -command dosearch
842 pack .bleft.top.search -side left -padx 5
843 set sstring .bleft.top.sstring
844 entry $sstring -width 20 -font textfont -textvariable searchstring
845 lappend entries $sstring
846 trace add variable searchstring write incrsearch
847 pack $sstring -side left -expand 1 -fill x
848 radiobutton .bleft.mid.diff -text [mc "Diff"] \
849 -command changediffdisp -variable diffelide -value {0 0}
850 radiobutton .bleft.mid.old -text [mc "Old version"] \
851 -command changediffdisp -variable diffelide -value {0 1}
852 radiobutton .bleft.mid.new -text [mc "New version"] \
853 -command changediffdisp -variable diffelide -value {1 0}
854 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
855 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
856 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
857 -from 1 -increment 1 -to 10000000 \
858 -validate all -validatecommand "diffcontextvalidate %P" \
859 -textvariable diffcontextstring
860 .bleft.mid.diffcontext set $diffcontext
861 trace add variable diffcontextstring write diffcontextchange
862 lappend entries .bleft.mid.diffcontext
863 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
864 checkbutton .bleft.mid.ignspace -text [mc "Ignore space change"] \
865 -command changeignorespace -variable ignorespace
866 pack .bleft.mid.ignspace -side left -padx 5
867 set ctext .bleft.ctext
868 text $ctext -background $bgcolor -foreground $fgcolor \
869 -state disabled -font textfont \
870 -yscrollcommand scrolltext -wrap none
872 $ctext conf -tabstyle wordprocessor
874 scrollbar .bleft.sb -command "$ctext yview"
875 pack .bleft.top -side top -fill x
876 pack .bleft.mid -side top -fill x
877 pack .bleft.sb -side right -fill y
878 pack $ctext -side left -fill both -expand 1
879 lappend bglist $ctext
880 lappend fglist $ctext
882 $ctext tag conf comment -wrap $wrapcomment
883 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
884 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
885 $ctext tag conf d0 -fore [lindex $diffcolors 0]
886 $ctext tag conf d1 -fore [lindex $diffcolors 1]
887 $ctext tag conf m0 -fore red
888 $ctext tag conf m1 -fore blue
889 $ctext tag conf m2 -fore green
890 $ctext tag conf m3 -fore purple
891 $ctext tag conf m4 -fore brown
892 $ctext tag conf m5 -fore "#009090"
893 $ctext tag conf m6 -fore magenta
894 $ctext tag conf m7 -fore "#808000"
895 $ctext tag conf m8 -fore "#009000"
896 $ctext tag conf m9 -fore "#ff0080"
897 $ctext tag conf m10 -fore cyan
898 $ctext tag conf m11 -fore "#b07070"
899 $ctext tag conf m12 -fore "#70b0f0"
900 $ctext tag conf m13 -fore "#70f0b0"
901 $ctext tag conf m14 -fore "#f0b070"
902 $ctext tag conf m15 -fore "#ff70b0"
903 $ctext tag conf mmax -fore darkgrey
905 $ctext tag conf mresult -font textfontbold
906 $ctext tag conf msep -font textfontbold
907 $ctext tag conf found -back yellow
910 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
915 radiobutton .bright.mode.patch -text [mc "Patch"] \
916 -command reselectline -variable cmitmode -value "patch"
917 radiobutton .bright.mode.tree -text [mc "Tree"] \
918 -command reselectline -variable cmitmode -value "tree"
919 grid .bright.mode.patch .bright.mode.tree -sticky ew
920 pack .bright.mode -side top -fill x
921 set cflist .bright.cfiles
922 set indent [font measure mainfont "nn"]
924 -selectbackground $selectbgcolor \
925 -background $bgcolor -foreground $fgcolor \
927 -tabs [list $indent [expr {2 * $indent}]] \
928 -yscrollcommand ".bright.sb set" \
929 -cursor [. cget -cursor] \
930 -spacing1 1 -spacing3 1
931 lappend bglist $cflist
932 lappend fglist $cflist
933 scrollbar .bright.sb -command "$cflist yview"
934 pack .bright.sb -side right -fill y
935 pack $cflist -side left -fill both -expand 1
936 $cflist tag configure highlight \
937 -background [$cflist cget -selectbackground]
938 $cflist tag configure bold -font mainfontbold
940 .pwbottom add .bright
943 # restore window width & height if known
944 if {[info exists geometry(main)]} {
945 if {[scan $geometry(main) "%dx%d" w h] >= 2} {
946 if {$w > [winfo screenwidth .]} {
947 set w [winfo screenwidth .]
949 if {$h > [winfo screenheight .]} {
950 set h [winfo screenheight .]
952 wm geometry . "${w}x$h"
956 if {[tk windowingsystem] eq {aqua}} {
962 bind .pwbottom <Configure> {resizecdetpanes %W %w}
963 pack .ctop -fill both -expand 1
964 bindall <1> {selcanvline %W %x %y}
965 #bindall <B1-Motion> {selcanvline %W %x %y}
966 if {[tk windowingsystem] == "win32"} {
967 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
968 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
970 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
971 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
972 if {[tk windowingsystem] eq "aqua"} {
973 bindall <MouseWheel> {
974 set delta [expr {- (%D)}]
975 allcanvs yview scroll $delta units
979 bindall <2> "canvscan mark %W %x %y"
980 bindall <B2-Motion> "canvscan dragto %W %x %y"
981 bindkey <Home> selfirstline
982 bindkey <End> sellastline
983 bind . <Key-Up> "selnextline -1"
984 bind . <Key-Down> "selnextline 1"
985 bind . <Shift-Key-Up> "dofind -1 0"
986 bind . <Shift-Key-Down> "dofind 1 0"
987 bindkey <Key-Right> "goforw"
988 bindkey <Key-Left> "goback"
989 bind . <Key-Prior> "selnextpage -1"
990 bind . <Key-Next> "selnextpage 1"
991 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
992 bind . <$M1B-End> "allcanvs yview moveto 1.0"
993 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
994 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
995 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
996 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
997 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
998 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
999 bindkey <Key-space> "$ctext yview scroll 1 pages"
1000 bindkey p "selnextline -1"
1001 bindkey n "selnextline 1"
1004 bindkey i "selnextline -1"
1005 bindkey k "selnextline 1"
1008 bindkey b "$ctext yview scroll -1 pages"
1009 bindkey d "$ctext yview scroll 18 units"
1010 bindkey u "$ctext yview scroll -18 units"
1011 bindkey / {dofind 1 1}
1012 bindkey <Key-Return> {dofind 1 1}
1013 bindkey ? {dofind -1 1}
1015 bindkey <F5> updatecommits
1016 bind . <$M1B-q> doquit
1017 bind . <$M1B-f> {dofind 1 1}
1018 bind . <$M1B-g> {dofind 1 0}
1019 bind . <$M1B-r> dosearchback
1020 bind . <$M1B-s> dosearch
1021 bind . <$M1B-equal> {incrfont 1}
1022 bind . <$M1B-plus> {incrfont 1}
1023 bind . <$M1B-KP_Add> {incrfont 1}
1024 bind . <$M1B-minus> {incrfont -1}
1025 bind . <$M1B-KP_Subtract> {incrfont -1}
1026 wm protocol . WM_DELETE_WINDOW doquit
1027 bind . <Button-1> "click %W"
1028 bind $fstring <Key-Return> {dofind 1 1}
1029 bind $sha1entry <Key-Return> gotocommit
1030 bind $sha1entry <<PasteSelection>> clearsha1
1031 bind $cflist <1> {sel_flist %W %x %y; break}
1032 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1033 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1034 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1036 set maincursor [. cget -cursor]
1037 set textcursor [$ctext cget -cursor]
1038 set curtextcursor $textcursor
1040 set rowctxmenu .rowctxmenu
1041 menu $rowctxmenu -tearoff 0
1042 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1043 -command {diffvssel 0}
1044 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1045 -command {diffvssel 1}
1046 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1047 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1048 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1049 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1050 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1052 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1055 set fakerowmenu .fakerowmenu
1056 menu $fakerowmenu -tearoff 0
1057 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1058 -command {diffvssel 0}
1059 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1060 -command {diffvssel 1}
1061 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1062 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1063 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1064 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1066 set headctxmenu .headctxmenu
1067 menu $headctxmenu -tearoff 0
1068 $headctxmenu add command -label [mc "Check out this branch"] \
1070 $headctxmenu add command -label [mc "Remove this branch"] \
1074 set flist_menu .flistctxmenu
1075 menu $flist_menu -tearoff 0
1076 $flist_menu add command -label [mc "Highlight this too"] \
1077 -command {flist_hl 0}
1078 $flist_menu add command -label [mc "Highlight this only"] \
1079 -command {flist_hl 1}
1082 # Windows sends all mouse wheel events to the current focused window, not
1083 # the one where the mouse hovers, so bind those events here and redirect
1084 # to the correct window
1085 proc windows_mousewheel_redirector {W X Y D} {
1086 global canv canv2 canv3
1087 set w [winfo containing -displayof $W $X $Y]
1089 set u [expr {$D < 0 ? 5 : -5}]
1090 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1091 allcanvs yview scroll $u units
1094 $w yview scroll $u units
1100 # mouse-2 makes all windows scan vertically, but only the one
1101 # the cursor is in scans horizontally
1102 proc canvscan {op w x y} {
1103 global canv canv2 canv3
1104 foreach c [list $canv $canv2 $canv3] {
1113 proc scrollcanv {cscroll f0 f1} {
1114 $cscroll set $f0 $f1
1119 # when we make a key binding for the toplevel, make sure
1120 # it doesn't get triggered when that key is pressed
in the
1121 # find string entry widget.
1122 proc bindkey
{ev
script} {
1125 set escript
[bind Entry
$ev]
1126 if {$escript == {}} {
1127 set escript
[bind Entry
<Key
>]
1129 foreach e
$entries {
1130 bind $e $ev "$escript; break"
1134 # set the focus back to the toplevel for any click outside
1137 global ctext entries
1138 foreach e
[concat
$entries $ctext] {
1139 if {$w == $e} return
1144 # Adjust the progress bar for a change in requested extent or canvas size
1145 proc adjustprogress
{} {
1146 global progresscanv progressitem progresscoords
1147 global fprogitem fprogcoord lastprogupdate progupdatepending
1148 global rprogitem rprogcoord
1150 set w
[expr {[winfo width
$progresscanv] - 4}]
1151 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1152 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1153 set h
[winfo height
$progresscanv]
1154 $progresscanv coords
$progressitem $x0 0 $x1 $h
1155 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1156 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1157 set now
[clock clicks
-milliseconds]
1158 if {$now >= $lastprogupdate + 100} {
1159 set progupdatepending
0
1161 } elseif
{!$progupdatepending} {
1162 set progupdatepending
1
1163 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1167 proc doprogupdate
{} {
1168 global lastprogupdate progupdatepending
1170 if {$progupdatepending} {
1171 set progupdatepending
0
1172 set lastprogupdate
[clock clicks
-milliseconds]
1177 proc savestuff
{w
} {
1178 global canv canv2 canv3 mainfont textfont uifont tabstop
1179 global stuffsaved findmergefiles maxgraphpct
1180 global maxwidth showneartags showlocalchanges
1181 global viewname viewfiles viewargs viewargscmd viewperm nextviewnum
1182 global cmitmode wrapcomment datetimeformat limitdiffs
1183 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1185 if {$stuffsaved} return
1186 if {![winfo viewable .
]} return
1188 set f
[open
"~/.gitk-new" w
]
1189 puts
$f [list
set mainfont
$mainfont]
1190 puts
$f [list
set textfont
$textfont]
1191 puts
$f [list
set uifont
$uifont]
1192 puts
$f [list
set tabstop
$tabstop]
1193 puts
$f [list
set findmergefiles
$findmergefiles]
1194 puts
$f [list
set maxgraphpct
$maxgraphpct]
1195 puts
$f [list
set maxwidth
$maxwidth]
1196 puts
$f [list
set cmitmode
$cmitmode]
1197 puts
$f [list
set wrapcomment
$wrapcomment]
1198 puts
$f [list
set showneartags
$showneartags]
1199 puts
$f [list
set showlocalchanges
$showlocalchanges]
1200 puts
$f [list
set datetimeformat
$datetimeformat]
1201 puts
$f [list
set limitdiffs
$limitdiffs]
1202 puts
$f [list
set bgcolor
$bgcolor]
1203 puts
$f [list
set fgcolor
$fgcolor]
1204 puts
$f [list
set colors
$colors]
1205 puts
$f [list
set diffcolors
$diffcolors]
1206 puts
$f [list
set diffcontext
$diffcontext]
1207 puts
$f [list
set selectbgcolor
$selectbgcolor]
1209 puts
$f "set geometry(main) [wm geometry .]"
1210 puts
$f "set geometry(topwidth) [winfo width .tf]"
1211 puts
$f "set geometry(topheight) [winfo height .tf]"
1212 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1213 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1214 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1215 puts
$f "set geometry(botheight) [winfo height .bleft]"
1217 puts
-nonewline $f "set permviews {"
1218 for {set v
0} {$v < $nextviewnum} {incr v
} {
1219 if {$viewperm($v)} {
1220 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1225 file rename
-force "~/.gitk-new" "~/.gitk"
1230 proc resizeclistpanes
{win w
} {
1232 if {[info exists oldwidth
($win)]} {
1233 set s0
[$win sash coord
0]
1234 set s1
[$win sash coord
1]
1236 set sash0
[expr {int
($w/2 - 2)}]
1237 set sash1
[expr {int
($w*5/6 - 2)}]
1239 set factor [expr {1.0 * $w / $oldwidth($win)}]
1240 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1241 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1245 if {$sash1 < $sash0 + 20} {
1246 set sash1
[expr {$sash0 + 20}]
1248 if {$sash1 > $w - 10} {
1249 set sash1
[expr {$w - 10}]
1250 if {$sash0 > $sash1 - 20} {
1251 set sash0
[expr {$sash1 - 20}]
1255 $win sash place
0 $sash0 [lindex
$s0 1]
1256 $win sash place
1 $sash1 [lindex
$s1 1]
1258 set oldwidth
($win) $w
1261 proc resizecdetpanes
{win w
} {
1263 if {[info exists oldwidth
($win)]} {
1264 set s0
[$win sash coord
0]
1266 set sash0
[expr {int
($w*3/4 - 2)}]
1268 set factor [expr {1.0 * $w / $oldwidth($win)}]
1269 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1273 if {$sash0 > $w - 15} {
1274 set sash0
[expr {$w - 15}]
1277 $win sash place
0 $sash0 [lindex
$s0 1]
1279 set oldwidth
($win) $w
1282 proc allcanvs args
{
1283 global canv canv2 canv3
1289 proc bindall
{event action
} {
1290 global canv canv2 canv3
1291 bind $canv $event $action
1292 bind $canv2 $event $action
1293 bind $canv3 $event $action
1299 if {[winfo exists
$w]} {
1304 wm title
$w [mc
"About gitk"]
1305 message
$w.m
-text [mc
"
1306 Gitk - a commit viewer for git
1308 Copyright © 2005-2006 Paul Mackerras
1310 Use and redistribute under the terms of the GNU General Public License"] \
1311 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1312 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1313 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1314 pack
$w.ok
-side bottom
1315 bind $w <Visibility
> "focus $w.ok"
1316 bind $w <Key-Escape
> "destroy $w"
1317 bind $w <Key-Return
> "destroy $w"
1322 if {[winfo exists
$w]} {
1326 if {[tk windowingsystem
] eq
{aqua
}} {
1332 wm title
$w [mc
"Gitk key bindings"]
1333 message
$w.m
-text "
1334 [mc "Gitk key bindings
:"]
1336 [mc "<%s-Q
> Quit
" $M1T]
1337 [mc "<Home
> Move to first commit
"]
1338 [mc "<End
> Move to last commit
"]
1339 [mc "<Up
>, p
, i Move up one commit
"]
1340 [mc "<Down
>, n
, k Move down one commit
"]
1341 [mc "<Left
>, z
, j Go back
in history list
"]
1342 [mc "<Right
>, x
, l Go forward
in history list
"]
1343 [mc "<PageUp
> Move up one page
in commit list
"]
1344 [mc "<PageDown
> Move down one page
in commit list
"]
1345 [mc "<%s-Home
> Scroll to top of commit list
" $M1T]
1346 [mc "<%s-End
> Scroll to bottom of commit list
" $M1T]
1347 [mc "<%s-Up
> Scroll commit list up one line
" $M1T]
1348 [mc "<%s-Down
> Scroll commit list down one line
" $M1T]
1349 [mc "<%s-PageUp
> Scroll commit list up one page
" $M1T]
1350 [mc "<%s-PageDown
> Scroll commit list down one page
" $M1T]
1351 [mc "<Shift-Up
> Find backwards
(upwards
, later commits
)"]
1352 [mc "<Shift-Down
> Find forwards
(downwards
, earlier commits
)"]
1353 [mc "<Delete
>, b Scroll
diff view up one page
"]
1354 [mc "<Backspace
> Scroll
diff view up one page
"]
1355 [mc "<Space
> Scroll
diff view down one page
"]
1356 [mc "u Scroll
diff view up
18 lines
"]
1357 [mc "d Scroll
diff view down
18 lines
"]
1358 [mc "<%s-F
> Find
" $M1T]
1359 [mc "<%s-G
> Move to next
find hit
" $M1T]
1360 [mc "<Return
> Move to next
find hit
"]
1361 [mc "/ Move to next
find hit
, or redo
find"]
1362 [mc "? Move to previous
find hit
"]
1363 [mc "f Scroll
diff view to next
file"]
1364 [mc "<%s-S
> Search
for next hit
in diff view
" $M1T]
1365 [mc "<%s-R
> Search
for previous hit
in diff view
" $M1T]
1366 [mc "<%s-KP
+> Increase font size
" $M1T]
1367 [mc "<%s-plus
> Increase font size
" $M1T]
1368 [mc "<%s-KP-
> Decrease font size
" $M1T]
1369 [mc "<%s-minus
> Decrease font size
" $M1T]
1372 -justify left
-bg white
-border 2 -relief groove
1373 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
1374 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1375 pack
$w.ok
-side bottom
1376 bind $w <Visibility
> "focus $w.ok"
1377 bind $w <Key-Escape
> "destroy $w"
1378 bind $w <Key-Return
> "destroy $w"
1381 # Procedures for manipulating the file list window at the
1382 # bottom right of the overall window.
1384 proc treeview
{w l openlevs
} {
1385 global treecontents treediropen treeheight treeparent treeindex
1395 set treecontents
() {}
1396 $w conf
-state normal
1398 while {[string range
$f 0 $prefixend] ne
$prefix} {
1399 if {$lev <= $openlevs} {
1400 $w mark
set e
:$treeindex($prefix) "end -1c"
1401 $w mark gravity e
:$treeindex($prefix) left
1403 set treeheight
($prefix) $ht
1404 incr ht
[lindex
$htstack end
]
1405 set htstack
[lreplace
$htstack end end
]
1406 set prefixend
[lindex
$prefendstack end
]
1407 set prefendstack
[lreplace
$prefendstack end end
]
1408 set prefix
[string range
$prefix 0 $prefixend]
1411 set tail [string range
$f [expr {$prefixend+1}] end
]
1412 while {[set slash
[string first
"/" $tail]] >= 0} {
1415 lappend prefendstack
$prefixend
1416 incr prefixend
[expr {$slash + 1}]
1417 set d
[string range
$tail 0 $slash]
1418 lappend treecontents
($prefix) $d
1419 set oldprefix
$prefix
1421 set treecontents
($prefix) {}
1422 set treeindex
($prefix) [incr ix
]
1423 set treeparent
($prefix) $oldprefix
1424 set tail [string range
$tail [expr {$slash+1}] end
]
1425 if {$lev <= $openlevs} {
1427 set treediropen
($prefix) [expr {$lev < $openlevs}]
1428 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
1429 $w mark
set d
:$ix "end -1c"
1430 $w mark gravity d
:$ix left
1432 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1434 $w image create end
-align center
-image $bm -padx 1 \
1436 $w insert end
$d [highlight_tag
$prefix]
1437 $w mark
set s
:$ix "end -1c"
1438 $w mark gravity s
:$ix left
1443 if {$lev <= $openlevs} {
1446 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1448 $w insert end
$tail [highlight_tag
$f]
1450 lappend treecontents
($prefix) $tail
1453 while {$htstack ne
{}} {
1454 set treeheight
($prefix) $ht
1455 incr ht
[lindex
$htstack end
]
1456 set htstack
[lreplace
$htstack end end
]
1457 set prefixend
[lindex
$prefendstack end
]
1458 set prefendstack
[lreplace
$prefendstack end end
]
1459 set prefix
[string range
$prefix 0 $prefixend]
1461 $w conf
-state disabled
1464 proc linetoelt
{l
} {
1465 global treeheight treecontents
1470 foreach e
$treecontents($prefix) {
1475 if {[string index
$e end
] eq
"/"} {
1476 set n
$treeheight($prefix$e)
1488 proc highlight_tree
{y prefix
} {
1489 global treeheight treecontents cflist
1491 foreach e
$treecontents($prefix) {
1493 if {[highlight_tag
$path] ne
{}} {
1494 $cflist tag add bold
$y.0 "$y.0 lineend"
1497 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
1498 set y
[highlight_tree
$y $path]
1504 proc treeclosedir
{w dir
} {
1505 global treediropen treeheight treeparent treeindex
1507 set ix
$treeindex($dir)
1508 $w conf
-state normal
1509 $w delete s
:$ix e
:$ix
1510 set treediropen
($dir) 0
1511 $w image configure a
:$ix -image tri-rt
1512 $w conf
-state disabled
1513 set n
[expr {1 - $treeheight($dir)}]
1514 while {$dir ne
{}} {
1515 incr treeheight
($dir) $n
1516 set dir
$treeparent($dir)
1520 proc treeopendir
{w dir
} {
1521 global treediropen treeheight treeparent treecontents treeindex
1523 set ix
$treeindex($dir)
1524 $w conf
-state normal
1525 $w image configure a
:$ix -image tri-dn
1526 $w mark
set e
:$ix s
:$ix
1527 $w mark gravity e
:$ix right
1530 set n
[llength
$treecontents($dir)]
1531 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
1534 incr treeheight
($x) $n
1536 foreach e
$treecontents($dir) {
1538 if {[string index
$e end
] eq
"/"} {
1539 set iy
$treeindex($de)
1540 $w mark
set d
:$iy e
:$ix
1541 $w mark gravity d
:$iy left
1542 $w insert e
:$ix $str
1543 set treediropen
($de) 0
1544 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
1546 $w insert e
:$ix $e [highlight_tag
$de]
1547 $w mark
set s
:$iy e
:$ix
1548 $w mark gravity s
:$iy left
1549 set treeheight
($de) 1
1551 $w insert e
:$ix $str
1552 $w insert e
:$ix $e [highlight_tag
$de]
1555 $w mark gravity e
:$ix left
1556 $w conf
-state disabled
1557 set treediropen
($dir) 1
1558 set top
[lindex
[split [$w index @
0,0] .
] 0]
1559 set ht
[$w cget
-height]
1560 set l
[lindex
[split [$w index s
:$ix] .
] 0]
1563 } elseif
{$l + $n + 1 > $top + $ht} {
1564 set top
[expr {$l + $n + 2 - $ht}]
1572 proc treeclick
{w x y
} {
1573 global treediropen cmitmode ctext cflist cflist_top
1575 if {$cmitmode ne
"tree"} return
1576 if {![info exists cflist_top
]} return
1577 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1578 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1579 $cflist tag add highlight
$l.0 "$l.0 lineend"
1585 set e
[linetoelt
$l]
1586 if {[string index
$e end
] ne
"/"} {
1588 } elseif
{$treediropen($e)} {
1595 proc setfilelist
{id
} {
1596 global treefilelist cflist
1598 treeview
$cflist $treefilelist($id) 0
1601 image create bitmap tri-rt
-background black
-foreground blue
-data {
1602 #define tri-rt_width 13
1603 #define tri-rt_height 13
1604 static unsigned char tri-rt_bits
[] = {
1605 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1606 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1609 #define tri-rt-mask_width 13
1610 #define tri-rt-mask_height 13
1611 static unsigned char tri-rt-mask_bits
[] = {
1612 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1613 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1616 image create bitmap tri-dn
-background black
-foreground blue
-data {
1617 #define tri-dn_width 13
1618 #define tri-dn_height 13
1619 static unsigned char tri-dn_bits
[] = {
1620 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1621 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1624 #define tri-dn-mask_width 13
1625 #define tri-dn-mask_height 13
1626 static unsigned char tri-dn-mask_bits
[] = {
1627 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1628 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1632 image create bitmap reficon-T
-background black
-foreground yellow
-data {
1633 #define tagicon_width 13
1634 #define tagicon_height 9
1635 static unsigned char tagicon_bits
[] = {
1636 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1637 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1639 #define tagicon-mask_width 13
1640 #define tagicon-mask_height 9
1641 static unsigned char tagicon-mask_bits
[] = {
1642 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1643 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1646 #define headicon_width 13
1647 #define headicon_height 9
1648 static unsigned char headicon_bits
[] = {
1649 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1650 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1653 #define headicon-mask_width 13
1654 #define headicon-mask_height 9
1655 static unsigned char headicon-mask_bits
[] = {
1656 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1657 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1659 image create bitmap reficon-H
-background black
-foreground green \
1660 -data $rectdata -maskdata $rectmask
1661 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
1662 -data $rectdata -maskdata $rectmask
1664 proc init_flist
{first
} {
1665 global cflist cflist_top selectedline difffilestart
1667 $cflist conf
-state normal
1668 $cflist delete
0.0 end
1670 $cflist insert end
$first
1672 $cflist tag add highlight
1.0 "1.0 lineend"
1674 catch
{unset cflist_top
}
1676 $cflist conf
-state disabled
1677 set difffilestart
{}
1680 proc highlight_tag
{f
} {
1681 global highlight_paths
1683 foreach p
$highlight_paths {
1684 if {[string match
$p $f]} {
1691 proc highlight_filelist
{} {
1692 global cmitmode cflist
1694 $cflist conf
-state normal
1695 if {$cmitmode ne
"tree"} {
1696 set end
[lindex
[split [$cflist index end
] .
] 0]
1697 for {set l
2} {$l < $end} {incr l
} {
1698 set line
[$cflist get
$l.0 "$l.0 lineend"]
1699 if {[highlight_tag
$line] ne
{}} {
1700 $cflist tag add bold
$l.0 "$l.0 lineend"
1706 $cflist conf
-state disabled
1709 proc unhighlight_filelist
{} {
1712 $cflist conf
-state normal
1713 $cflist tag remove bold
1.0 end
1714 $cflist conf
-state disabled
1717 proc add_flist
{fl
} {
1720 $cflist conf
-state normal
1722 $cflist insert end
"\n"
1723 $cflist insert end
$f [highlight_tag
$f]
1725 $cflist conf
-state disabled
1728 proc sel_flist
{w x y
} {
1729 global ctext difffilestart cflist cflist_top cmitmode
1731 if {$cmitmode eq
"tree"} return
1732 if {![info exists cflist_top
]} return
1733 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1734 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1735 $cflist tag add highlight
$l.0 "$l.0 lineend"
1740 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
1744 proc pop_flist_menu
{w X Y x y
} {
1745 global ctext cflist cmitmode flist_menu flist_menu_file
1746 global treediffs diffids
1749 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1751 if {$cmitmode eq
"tree"} {
1752 set e
[linetoelt
$l]
1753 if {[string index
$e end
] eq
"/"} return
1755 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
1757 set flist_menu_file
$e
1758 tk_popup
$flist_menu $X $Y
1761 proc flist_hl
{only
} {
1762 global flist_menu_file findstring gdttype
1764 set x
[shellquote
$flist_menu_file]
1765 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
1768 append findstring
" " $x
1770 set gdttype
[mc
"touching paths:"]
1773 # Functions for adding and removing shell-type quoting
1775 proc shellquote
{str
} {
1776 if {![string match
"*\['\"\\ \t]*" $str]} {
1779 if {![string match
"*\['\"\\]*" $str]} {
1782 if {![string match
"*'*" $str]} {
1785 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1788 proc shellarglist
{l
} {
1794 append str
[shellquote
$a]
1799 proc shelldequote
{str
} {
1804 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
1805 append ret
[string range
$str $used end
]
1806 set used
[string length
$str]
1809 set first
[lindex
$first 0]
1810 set ch
[string index
$str $first]
1811 if {$first > $used} {
1812 append ret
[string range
$str $used [expr {$first - 1}]]
1815 if {$ch eq
" " ||
$ch eq
"\t"} break
1818 set first
[string first
"'" $str $used]
1820 error
"unmatched single-quote"
1822 append ret
[string range
$str $used [expr {$first - 1}]]
1827 if {$used >= [string length
$str]} {
1828 error
"trailing backslash"
1830 append ret
[string index
$str $used]
1835 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
1836 error
"unmatched double-quote"
1838 set first
[lindex
$first 0]
1839 set ch
[string index
$str $first]
1840 if {$first > $used} {
1841 append ret
[string range
$str $used [expr {$first - 1}]]
1844 if {$ch eq
"\""} break
1846 append ret
[string index
$str $used]
1850 return [list
$used $ret]
1853 proc shellsplit
{str
} {
1856 set str
[string trimleft
$str]
1857 if {$str eq
{}} break
1858 set dq
[shelldequote
$str]
1859 set n
[lindex
$dq 0]
1860 set word
[lindex
$dq 1]
1861 set str
[string range
$str $n end
]
1867 # Code to implement multiple views
1869 proc newview
{ishighlight
} {
1870 global nextviewnum newviewname newviewperm newishighlight
1871 global newviewargs revtreeargs viewargscmd newviewargscmd curview
1873 set newishighlight
$ishighlight
1875 if {[winfo exists
$top]} {
1879 set newviewname
($nextviewnum) "View $nextviewnum"
1880 set newviewperm
($nextviewnum) 0
1881 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
1882 set newviewargscmd
($nextviewnum) $viewargscmd($curview)
1883 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
1888 global viewname viewperm newviewname newviewperm
1889 global viewargs newviewargs viewargscmd newviewargscmd
1891 set top .gitkvedit-
$curview
1892 if {[winfo exists
$top]} {
1896 set newviewname
($curview) $viewname($curview)
1897 set newviewperm
($curview) $viewperm($curview)
1898 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
1899 set newviewargscmd
($curview) $viewargscmd($curview)
1900 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
1903 proc vieweditor
{top n title
} {
1904 global newviewname newviewperm viewfiles bgcolor
1907 wm title
$top $title
1908 label
$top.
nl -text [mc
"Name"]
1909 entry
$top.name
-width 20 -textvariable newviewname
($n)
1910 grid
$top.
nl $top.name
-sticky w
-pady 5
1911 checkbutton
$top.perm
-text [mc
"Remember this view"] \
1912 -variable newviewperm
($n)
1913 grid
$top.perm
- -pady 5 -sticky w
1914 message
$top.al
-aspect 1000 \
1915 -text [mc
"Commits to include (arguments to git rev-list):"]
1916 grid
$top.al
- -sticky w
-pady 5
1917 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
1918 -background $bgcolor
1919 grid
$top.args
- -sticky ew
-padx 5
1921 message
$top.ac
-aspect 1000 \
1922 -text [mc
"Command to generate more commits to include:"]
1923 grid
$top.ac
- -sticky w
-pady 5
1924 entry
$top.argscmd
-width 50 -textvariable newviewargscmd
($n) \
1926 grid
$top.argscmd
- -sticky ew
-padx 5
1928 message
$top.l
-aspect 1000 \
1929 -text [mc
"Enter files and directories to include, one per line:"]
1930 grid
$top.l
- -sticky w
1931 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
1932 if {[info exists viewfiles
($n)]} {
1933 foreach f
$viewfiles($n) {
1934 $top.t insert end
$f
1935 $top.t insert end
"\n"
1937 $top.t delete
{end
- 1c
} end
1938 $top.t mark
set insert
0.0
1940 grid
$top.t
- -sticky ew
-padx 5
1942 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
1943 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
1944 grid
$top.buts.ok
$top.buts.can
1945 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
1946 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
1947 grid
$top.buts
- -pady 10 -sticky ew
1951 proc doviewmenu
{m first cmd op argv
} {
1952 set nmenu
[$m index end
]
1953 for {set i
$first} {$i <= $nmenu} {incr i
} {
1954 if {[$m entrycget
$i -command] eq
$cmd} {
1955 eval $m $op $i $argv
1961 proc allviewmenus
{n op args
} {
1964 doviewmenu .bar.view
5 [list showview
$n] $op $args
1965 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1968 proc newviewok
{top n
} {
1969 global nextviewnum newviewperm newviewname newishighlight
1970 global viewname viewfiles viewperm selectedview curview
1971 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
1974 set newargs
[shellsplit
$newviewargs($n)]
1976 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
1982 foreach f
[split [$top.t get
0.0 end
] "\n"] {
1983 set ft
[string trim
$f]
1988 if {![info exists viewfiles
($n)]} {
1989 # creating a new view
1991 set viewname
($n) $newviewname($n)
1992 set viewperm
($n) $newviewperm($n)
1993 set viewfiles
($n) $files
1994 set viewargs
($n) $newargs
1995 set viewargscmd
($n) $newviewargscmd($n)
1997 if {!$newishighlight} {
2000 run addvhighlight
$n
2003 # editing an existing view
2004 set viewperm
($n) $newviewperm($n)
2005 if {$newviewname($n) ne
$viewname($n)} {
2006 set viewname
($n) $newviewname($n)
2007 doviewmenu .bar.view
5 [list showview
$n] \
2008 entryconf
[list
-label $viewname($n)]
2009 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2010 # entryconf [list -label $viewname($n) -value $viewname($n)]
2012 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n) || \
2013 $newviewargscmd($n) ne
$viewargscmd($n)} {
2014 set viewfiles
($n) $files
2015 set viewargs
($n) $newargs
2016 set viewargscmd
($n) $newviewargscmd($n)
2017 if {$curview == $n} {
2022 catch
{destroy
$top}
2026 global curview viewdata viewperm hlview selectedhlview
2028 if {$curview == 0} return
2029 if {[info exists hlview
] && $hlview == $curview} {
2030 set selectedhlview
[mc
"None"]
2033 allviewmenus
$curview delete
2034 set viewdata
($curview) {}
2035 set viewperm
($curview) 0
2039 proc addviewmenu
{n
} {
2040 global viewname viewhlmenu
2042 .bar.view add radiobutton
-label $viewname($n) \
2043 -command [list showview
$n] -variable selectedview
-value $n
2044 #$viewhlmenu add radiobutton -label $viewname($n) \
2045 # -command [list addvhighlight $n] -variable selectedhlview
2048 proc flatten
{var
} {
2052 foreach i
[array names
$var] {
2053 lappend ret
$i [set $var\
($i\
)]
2058 proc unflatten
{var l
} {
2068 global curview viewdata viewfiles
2069 global displayorder parentlist rowidlist rowisopt rowfinal
2070 global colormap rowtextx commitrow nextcolor canvxmax
2071 global numcommits commitlisted
2072 global selectedline currentid canv canvy0
2074 global pending_select phase
2077 global selectedview selectfirst
2078 global vparentlist vdisporder vcmitlisted
2079 global hlview selectedhlview commitinterest
2081 if {$n == $curview} return
2083 if {[info exists selectedline
]} {
2084 set selid
$currentid
2085 set y
[yc
$selectedline]
2086 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2087 set span
[$canv yview
]
2088 set ytop
[expr {[lindex
$span 0] * $ymax}]
2089 set ybot
[expr {[lindex
$span 1] * $ymax}]
2090 if {$ytop < $y && $y < $ybot} {
2091 set yscreen
[expr {$y - $ytop}]
2093 set yscreen
[expr {($ybot - $ytop) / 2}]
2095 } elseif
{[info exists pending_select
]} {
2096 set selid
$pending_select
2097 unset pending_select
2101 if {$curview >= 0} {
2102 set vparentlist
($curview) $parentlist
2103 set vdisporder
($curview) $displayorder
2104 set vcmitlisted
($curview) $commitlisted
2106 ![info exists viewdata
($curview)] ||
2107 [lindex
$viewdata($curview) 0] ne
{}} {
2108 set viewdata
($curview) \
2109 [list
$phase $rowidlist $rowisopt $rowfinal]
2112 catch
{unset treediffs
}
2114 if {[info exists hlview
] && $hlview == $n} {
2116 set selectedhlview
[mc
"None"]
2118 catch
{unset commitinterest
}
2122 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2123 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2126 if {![info exists viewdata
($n)]} {
2128 set pending_select
$selid
2135 set phase
[lindex
$v 0]
2136 set displayorder
$vdisporder($n)
2137 set parentlist
$vparentlist($n)
2138 set commitlisted
$vcmitlisted($n)
2139 set rowidlist
[lindex
$v 1]
2140 set rowisopt
[lindex
$v 2]
2141 set rowfinal
[lindex
$v 3]
2142 set numcommits
$commitidx($n)
2144 catch
{unset colormap
}
2145 catch
{unset rowtextx
}
2147 set canvxmax
[$canv cget
-width]
2154 if {$selid ne
{} && [info exists commitrow
($n,$selid)]} {
2155 set row
$commitrow($n,$selid)
2156 # try to get the selected row in the same position on the screen
2157 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2158 set ytop
[expr {[yc
$row] - $yscreen}]
2162 set yf
[expr {$ytop * 1.0 / $ymax}]
2164 allcanvs yview moveto
$yf
2168 } elseif
{$selid ne
{}} {
2169 set pending_select
$selid
2171 set row
[first_real_row
]
2172 if {$row < $numcommits} {
2179 if {$phase eq
"getcommits"} {
2180 show_status
[mc
"Reading commits..."]
2183 } elseif
{$numcommits == 0} {
2184 show_status
[mc
"No commits selected"]
2188 # Stuff relating to the highlighting facility
2190 proc ishighlighted
{row
} {
2191 global vhighlights fhighlights nhighlights rhighlights
2193 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2194 return $nhighlights($row)
2196 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2197 return $vhighlights($row)
2199 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2200 return $fhighlights($row)
2202 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2203 return $rhighlights($row)
2208 proc bolden
{row font
} {
2209 global canv linehtag selectedline boldrows
2211 lappend boldrows
$row
2212 $canv itemconf
$linehtag($row) -font $font
2213 if {[info exists selectedline
] && $row == $selectedline} {
2215 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2216 -outline {{}} -tags secsel \
2217 -fill [$canv cget
-selectbackground]]
2222 proc bolden_name
{row font
} {
2223 global canv2 linentag selectedline boldnamerows
2225 lappend boldnamerows
$row
2226 $canv2 itemconf
$linentag($row) -font $font
2227 if {[info exists selectedline
] && $row == $selectedline} {
2228 $canv2 delete secsel
2229 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2230 -outline {{}} -tags secsel \
2231 -fill [$canv2 cget
-selectbackground]]
2240 foreach row
$boldrows {
2241 if {![ishighlighted
$row]} {
2242 bolden
$row mainfont
2244 lappend stillbold
$row
2247 set boldrows
$stillbold
2250 proc addvhighlight
{n
} {
2251 global hlview curview viewdata vhl_done vhighlights commitidx
2253 if {[info exists hlview
]} {
2257 if {$n != $curview && ![info exists viewdata
($n)]} {
2258 set viewdata
($n) [list getcommits
{{}} 0 0 0]
2259 set vparentlist
($n) {}
2260 set vdisporder
($n) {}
2261 set vcmitlisted
($n) {}
2264 set vhl_done
$commitidx($hlview)
2265 if {$vhl_done > 0} {
2270 proc delvhighlight
{} {
2271 global hlview vhighlights
2273 if {![info exists hlview
]} return
2275 catch
{unset vhighlights
}
2279 proc vhighlightmore
{} {
2280 global hlview vhl_done commitidx vhighlights
2281 global displayorder vdisporder curview
2283 set max
$commitidx($hlview)
2284 if {$hlview == $curview} {
2285 set disp
$displayorder
2287 set disp
$vdisporder($hlview)
2289 set vr
[visiblerows
]
2290 set r0
[lindex
$vr 0]
2291 set r1
[lindex
$vr 1]
2292 for {set i
$vhl_done} {$i < $max} {incr i
} {
2293 set id
[lindex
$disp $i]
2294 if {[info exists commitrow
($curview,$id)]} {
2295 set row
$commitrow($curview,$id)
2296 if {$r0 <= $row && $row <= $r1} {
2297 if {![highlighted
$row]} {
2298 bolden
$row mainfontbold
2300 set vhighlights
($row) 1
2307 proc askvhighlight
{row id
} {
2308 global hlview vhighlights commitrow iddrawn
2310 if {[info exists commitrow
($hlview,$id)]} {
2311 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2312 bolden
$row mainfontbold
2314 set vhighlights
($row) 1
2316 set vhighlights
($row) 0
2320 proc hfiles_change
{} {
2321 global highlight_files filehighlight fhighlights fh_serial
2322 global highlight_paths gdttype
2324 if {[info exists filehighlight
]} {
2325 # delete previous highlights
2326 catch
{close
$filehighlight}
2328 catch
{unset fhighlights
}
2330 unhighlight_filelist
2332 set highlight_paths
{}
2333 after cancel do_file_hl
$fh_serial
2335 if {$highlight_files ne
{}} {
2336 after
300 do_file_hl
$fh_serial
2340 proc gdttype_change
{name ix op
} {
2341 global gdttype highlight_files findstring findpattern
2344 if {$findstring ne
{}} {
2345 if {$gdttype eq
[mc
"containing:"]} {
2346 if {$highlight_files ne
{}} {
2347 set highlight_files
{}
2352 if {$findpattern ne
{}} {
2356 set highlight_files
$findstring
2361 # enable/disable findtype/findloc menus too
2364 proc find_change
{name ix op
} {
2365 global gdttype findstring highlight_files
2368 if {$gdttype eq
[mc
"containing:"]} {
2371 if {$highlight_files ne
$findstring} {
2372 set highlight_files
$findstring
2379 proc findcom_change args
{
2380 global nhighlights boldnamerows
2381 global findpattern findtype findstring gdttype
2384 # delete previous highlights, if any
2385 foreach row
$boldnamerows {
2386 bolden_name
$row mainfont
2389 catch
{unset nhighlights
}
2392 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
2394 } elseif
{$findtype eq
[mc
"Regexp"]} {
2395 set findpattern
$findstring
2397 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2399 set findpattern
"*$e*"
2403 proc makepatterns
{l
} {
2406 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2407 if {[string index
$ee end
] eq
"/"} {
2417 proc do_file_hl
{serial
} {
2418 global highlight_files filehighlight highlight_paths gdttype fhl_list
2420 if {$gdttype eq
[mc
"touching paths:"]} {
2421 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
2422 set highlight_paths
[makepatterns
$paths]
2424 set gdtargs
[concat
-- $paths]
2425 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
2426 set gdtargs
[list
"-S$highlight_files"]
2428 # must be "containing:", i.e. we're searching commit info
2431 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
2432 set filehighlight
[open
$cmd r
+]
2433 fconfigure
$filehighlight -blocking 0
2434 filerun
$filehighlight readfhighlight
2440 proc flushhighlights
{} {
2441 global filehighlight fhl_list
2443 if {[info exists filehighlight
]} {
2445 puts
$filehighlight ""
2446 flush
$filehighlight
2450 proc askfilehighlight
{row id
} {
2451 global filehighlight fhighlights fhl_list
2453 lappend fhl_list
$id
2454 set fhighlights
($row) -1
2455 puts
$filehighlight $id
2458 proc readfhighlight
{} {
2459 global filehighlight fhighlights commitrow curview iddrawn
2460 global fhl_list find_dirn
2462 if {![info exists filehighlight
]} {
2466 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
2467 set line
[string trim
$line]
2468 set i
[lsearch
-exact $fhl_list $line]
2469 if {$i < 0} continue
2470 for {set j
0} {$j < $i} {incr j
} {
2471 set id
[lindex
$fhl_list $j]
2472 if {[info exists commitrow
($curview,$id)]} {
2473 set fhighlights
($commitrow($curview,$id)) 0
2476 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
2477 if {$line eq
{}} continue
2478 if {![info exists commitrow
($curview,$line)]} continue
2479 set row
$commitrow($curview,$line)
2480 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
2481 bolden
$row mainfontbold
2483 set fhighlights
($row) 1
2485 if {[eof
$filehighlight]} {
2487 puts
"oops, git diff-tree died"
2488 catch
{close
$filehighlight}
2492 if {[info exists find_dirn
]} {
2498 proc doesmatch
{f
} {
2499 global findtype findpattern
2501 if {$findtype eq
[mc
"Regexp"]} {
2502 return [regexp
$findpattern $f]
2503 } elseif
{$findtype eq
[mc
"IgnCase"]} {
2504 return [string match
-nocase $findpattern $f]
2506 return [string match
$findpattern $f]
2510 proc askfindhighlight
{row id
} {
2511 global nhighlights commitinfo iddrawn
2513 global markingmatches
2515 if {![info exists commitinfo
($id)]} {
2518 set info
$commitinfo($id)
2520 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
2521 foreach f
$info ty
$fldtypes {
2522 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
2524 if {$ty eq
[mc
"Author"]} {
2531 if {$isbold && [info exists iddrawn
($id)]} {
2532 if {![ishighlighted
$row]} {
2533 bolden
$row mainfontbold
2535 bolden_name
$row mainfontbold
2538 if {$markingmatches} {
2539 markrowmatches
$row $id
2542 set nhighlights
($row) $isbold
2545 proc markrowmatches
{row id
} {
2546 global canv canv2 linehtag linentag commitinfo findloc
2548 set headline
[lindex
$commitinfo($id) 0]
2549 set author
[lindex
$commitinfo($id) 1]
2550 $canv delete match
$row
2551 $canv2 delete match
$row
2552 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
2553 set m
[findmatches
$headline]
2555 markmatches
$canv $row $headline $linehtag($row) $m \
2556 [$canv itemcget
$linehtag($row) -font] $row
2559 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
2560 set m
[findmatches
$author]
2562 markmatches
$canv2 $row $author $linentag($row) $m \
2563 [$canv2 itemcget
$linentag($row) -font] $row
2568 proc vrel_change
{name ix op
} {
2569 global highlight_related
2572 if {$highlight_related ne
[mc
"None"]} {
2577 # prepare for testing whether commits are descendents or ancestors of a
2578 proc rhighlight_sel
{a
} {
2579 global descendent desc_todo ancestor anc_todo
2580 global highlight_related rhighlights
2582 catch
{unset descendent
}
2583 set desc_todo
[list
$a]
2584 catch
{unset ancestor
}
2585 set anc_todo
[list
$a]
2586 if {$highlight_related ne
[mc
"None"]} {
2592 proc rhighlight_none
{} {
2595 catch
{unset rhighlights
}
2599 proc is_descendent
{a
} {
2600 global curview children commitrow descendent desc_todo
2603 set la
$commitrow($v,$a)
2607 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2608 set do [lindex
$todo $i]
2609 if {$commitrow($v,$do) < $la} {
2610 lappend leftover
$do
2613 foreach nk
$children($v,$do) {
2614 if {![info exists descendent
($nk)]} {
2615 set descendent
($nk) 1
2623 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2627 set descendent
($a) 0
2628 set desc_todo
$leftover
2631 proc is_ancestor
{a
} {
2632 global curview parentlist commitrow ancestor anc_todo
2635 set la
$commitrow($v,$a)
2639 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2640 set do [lindex
$todo $i]
2641 if {![info exists commitrow
($v,$do)] ||
$commitrow($v,$do) > $la} {
2642 lappend leftover
$do
2645 foreach np
[lindex
$parentlist $commitrow($v,$do)] {
2646 if {![info exists ancestor
($np)]} {
2655 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2660 set anc_todo
$leftover
2663 proc askrelhighlight
{row id
} {
2664 global descendent highlight_related iddrawn rhighlights
2665 global selectedline ancestor
2667 if {![info exists selectedline
]} return
2669 if {$highlight_related eq
[mc
"Descendant"] ||
2670 $highlight_related eq
[mc
"Not descendant"]} {
2671 if {![info exists descendent
($id)]} {
2674 if {$descendent($id) == ($highlight_related eq
[mc
"Descendant"])} {
2677 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
2678 $highlight_related eq
[mc
"Not ancestor"]} {
2679 if {![info exists ancestor
($id)]} {
2682 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
2686 if {[info exists iddrawn
($id)]} {
2687 if {$isbold && ![ishighlighted
$row]} {
2688 bolden
$row mainfontbold
2691 set rhighlights
($row) $isbold
2694 # Graph layout functions
2696 proc shortids
{ids
} {
2699 if {[llength
$id] > 1} {
2700 lappend res
[shortids
$id]
2701 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
2702 lappend res
[string range
$id 0 7]
2713 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
2714 if {($n & $mask) != 0} {
2715 set ret
[concat
$ret $o]
2717 set o
[concat
$o $o]
2722 # Work out where id should go in idlist so that order-token
2723 # values increase from left to right
2724 proc idcol
{idlist id
{i
0}} {
2725 global ordertok curview
2727 set t
$ordertok($curview,$id)
2728 if {$i >= [llength
$idlist] ||
2729 $t < $ordertok($curview,[lindex
$idlist $i])} {
2730 if {$i > [llength
$idlist]} {
2731 set i
[llength
$idlist]
2733 while {[incr i
-1] >= 0 &&
2734 $t < $ordertok($curview,[lindex
$idlist $i])} {}
2737 if {$t > $ordertok($curview,[lindex
$idlist $i])} {
2738 while {[incr i
] < [llength
$idlist] &&
2739 $t >= $ordertok($curview,[lindex
$idlist $i])} {}
2745 proc initlayout
{} {
2746 global rowidlist rowisopt rowfinal displayorder commitlisted
2747 global numcommits canvxmax canv
2750 global colormap rowtextx
2761 set canvxmax
[$canv cget
-width]
2762 catch
{unset colormap
}
2763 catch
{unset rowtextx
}
2767 proc setcanvscroll
{} {
2768 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2770 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2771 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
2772 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
2773 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
2776 proc visiblerows
{} {
2777 global canv numcommits linespc
2779 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2780 if {$ymax eq
{} ||
$ymax == 0} return
2782 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
2783 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
2787 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
2788 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
2789 if {$r1 >= $numcommits} {
2790 set r1
[expr {$numcommits - 1}]
2792 return [list
$r0 $r1]
2795 proc layoutmore
{} {
2796 global commitidx viewcomplete numcommits
2797 global uparrowlen downarrowlen mingaplen curview
2799 set show
$commitidx($curview)
2800 if {$show > $numcommits ||
$viewcomplete($curview)} {
2801 showstuff
$show $viewcomplete($curview)
2805 proc showstuff
{canshow last
} {
2806 global numcommits commitrow pending_select selectedline curview
2807 global mainheadid displayorder selectfirst
2808 global lastscrollset commitinterest
2810 if {$numcommits == 0} {
2812 set phase
"incrdraw"
2816 set prev
$numcommits
2817 set numcommits
$canshow
2818 set t
[clock clicks
-milliseconds]
2819 if {$prev < 100 ||
$last ||
$t - $lastscrollset > 500} {
2820 set lastscrollset
$t
2823 set rows
[visiblerows
]
2824 set r1
[lindex
$rows 1]
2825 if {$r1 >= $canshow} {
2826 set r1
[expr {$canshow - 1}]
2831 if {[info exists pending_select
] &&
2832 [info exists commitrow
($curview,$pending_select)] &&
2833 $commitrow($curview,$pending_select) < $numcommits} {
2834 selectline
$commitrow($curview,$pending_select) 1
2837 if {[info exists selectedline
] ||
[info exists pending_select
]} {
2840 set l
[first_real_row
]
2847 proc doshowlocalchanges
{} {
2848 global curview mainheadid phase commitrow
2850 if {[info exists commitrow
($curview,$mainheadid)] &&
2851 ($phase eq
{} ||
$commitrow($curview,$mainheadid) < $numcommits - 1)} {
2853 } elseif
{$phase ne
{}} {
2854 lappend commitinterest
($mainheadid) {}
2858 proc dohidelocalchanges
{} {
2859 global localfrow localirow lserial
2861 if {$localfrow >= 0} {
2862 removerow
$localfrow
2864 if {$localirow > 0} {
2868 if {$localirow >= 0} {
2869 removerow
$localirow
2875 # spawn off a process to do git diff-index --cached HEAD
2876 proc dodiffindex
{} {
2877 global localirow localfrow lserial showlocalchanges
2879 if {!$showlocalchanges} return
2883 set fd
[open
"|git diff-index --cached HEAD" r
]
2884 fconfigure
$fd -blocking 0
2885 filerun
$fd [list readdiffindex
$fd $lserial]
2888 proc readdiffindex
{fd serial
} {
2889 global localirow commitrow mainheadid nullid2 curview
2890 global commitinfo commitdata lserial
2893 if {[gets
$fd line
] < 0} {
2899 # we only need to see one line and we don't really care what it says...
2902 # now see if there are any local changes not checked in to the index
2903 if {$serial == $lserial} {
2904 set fd
[open
"|git diff-files" r
]
2905 fconfigure
$fd -blocking 0
2906 filerun
$fd [list readdifffiles
$fd $serial]
2909 if {$isdiff && $serial == $lserial && $localirow == -1} {
2910 # add the line for the changes in the index to the graph
2911 set localirow
$commitrow($curview,$mainheadid)
2912 set hl
[mc
"Local changes checked in to index but not committed"]
2913 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
2914 set commitdata
($nullid2) "\n $hl\n"
2915 insertrow
$localirow $nullid2
2920 proc readdifffiles
{fd serial
} {
2921 global localirow localfrow commitrow mainheadid nullid curview
2922 global commitinfo commitdata lserial
2925 if {[gets
$fd line
] < 0} {
2931 # we only need to see one line and we don't really care what it says...
2934 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2935 # add the line for the local diff to the graph
2936 if {$localirow >= 0} {
2937 set localfrow
$localirow
2940 set localfrow
$commitrow($curview,$mainheadid)
2942 set hl
[mc
"Local uncommitted changes, not checked in to index"]
2943 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
2944 set commitdata
($nullid) "\n $hl\n"
2945 insertrow
$localfrow $nullid
2950 proc nextuse
{id row
} {
2951 global commitrow curview children
2953 if {[info exists children
($curview,$id)]} {
2954 foreach kid
$children($curview,$id) {
2955 if {![info exists commitrow
($curview,$kid)]} {
2958 if {$commitrow($curview,$kid) > $row} {
2959 return $commitrow($curview,$kid)
2963 if {[info exists commitrow
($curview,$id)]} {
2964 return $commitrow($curview,$id)
2969 proc prevuse
{id row
} {
2970 global commitrow curview children
2973 if {[info exists children
($curview,$id)]} {
2974 foreach kid
$children($curview,$id) {
2975 if {![info exists commitrow
($curview,$kid)]} break
2976 if {$commitrow($curview,$kid) < $row} {
2977 set ret
$commitrow($curview,$kid)
2984 proc make_idlist
{row
} {
2985 global displayorder parentlist uparrowlen downarrowlen mingaplen
2986 global commitidx curview ordertok children commitrow
2988 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
2992 set ra
[expr {$row - $downarrowlen}]
2996 set rb
[expr {$row + $uparrowlen}]
2997 if {$rb > $commitidx($curview)} {
2998 set rb
$commitidx($curview)
3001 for {} {$r < $ra} {incr r
} {
3002 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3003 foreach p
[lindex
$parentlist $r] {
3004 if {$p eq
$nextid} continue
3005 set rn
[nextuse
$p $r]
3007 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3008 lappend ids
[list
$ordertok($curview,$p) $p]
3012 for {} {$r < $row} {incr r
} {
3013 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3014 foreach p
[lindex
$parentlist $r] {
3015 if {$p eq
$nextid} continue
3016 set rn
[nextuse
$p $r]
3017 if {$rn < 0 ||
$rn >= $row} {
3018 lappend ids
[list
$ordertok($curview,$p) $p]
3022 set id
[lindex
$displayorder $row]
3023 lappend ids
[list
$ordertok($curview,$id) $id]
3025 foreach p
[lindex
$parentlist $r] {
3026 set firstkid
[lindex
$children($curview,$p) 0]
3027 if {$commitrow($curview,$firstkid) < $row} {
3028 lappend ids
[list
$ordertok($curview,$p) $p]
3032 set id
[lindex
$displayorder $r]
3034 set firstkid
[lindex
$children($curview,$id) 0]
3035 if {$firstkid ne
{} && $commitrow($curview,$firstkid) < $row} {
3036 lappend ids
[list
$ordertok($curview,$id) $id]
3041 foreach idx
[lsort
-unique $ids] {
3042 lappend idlist
[lindex
$idx 1]
3047 proc rowsequal
{a b
} {
3048 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3049 set a
[lreplace
$a $i $i]
3051 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3052 set b
[lreplace
$b $i $i]
3054 return [expr {$a eq
$b}]
3057 proc makeupline
{id row rend
col} {
3058 global rowidlist uparrowlen downarrowlen mingaplen
3060 for {set r
$rend} {1} {set r
$rstart} {
3061 set rstart
[prevuse
$id $r]
3062 if {$rstart < 0} return
3063 if {$rstart < $row} break
3065 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3066 set rstart
[expr {$rend - $uparrowlen - 1}]
3068 for {set r
$rstart} {[incr r
] <= $row} {} {
3069 set idlist
[lindex
$rowidlist $r]
3070 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3071 set col [idcol
$idlist $id $col]
3072 lset rowidlist
$r [linsert
$idlist $col $id]
3078 proc layoutrows
{row endrow
} {
3079 global rowidlist rowisopt rowfinal displayorder
3080 global uparrowlen downarrowlen maxwidth mingaplen
3081 global children parentlist
3082 global commitidx viewcomplete curview commitrow
3086 set rm1
[expr {$row - 1}]
3087 foreach id
[lindex
$rowidlist $rm1] {
3092 set final
[lindex
$rowfinal $rm1]
3094 for {} {$row < $endrow} {incr row
} {
3095 set rm1
[expr {$row - 1}]
3096 if {$rm1 < 0 ||
$idlist eq
{}} {
3097 set idlist
[make_idlist
$row]
3100 set id
[lindex
$displayorder $rm1]
3101 set col [lsearch
-exact $idlist $id]
3102 set idlist
[lreplace
$idlist $col $col]
3103 foreach p
[lindex
$parentlist $rm1] {
3104 if {[lsearch
-exact $idlist $p] < 0} {
3105 set col [idcol
$idlist $p $col]
3106 set idlist
[linsert
$idlist $col $p]
3107 # if not the first child, we have to insert a line going up
3108 if {$id ne
[lindex
$children($curview,$p) 0]} {
3109 makeupline
$p $rm1 $row $col
3113 set id
[lindex
$displayorder $row]
3114 if {$row > $downarrowlen} {
3115 set termrow
[expr {$row - $downarrowlen - 1}]
3116 foreach p
[lindex
$parentlist $termrow] {
3117 set i
[lsearch
-exact $idlist $p]
3118 if {$i < 0} continue
3119 set nr
[nextuse
$p $termrow]
3120 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3121 set idlist
[lreplace
$idlist $i $i]
3125 set col [lsearch
-exact $idlist $id]
3127 set col [idcol
$idlist $id]
3128 set idlist
[linsert
$idlist $col $id]
3129 if {$children($curview,$id) ne
{}} {
3130 makeupline
$id $rm1 $row $col
3133 set r
[expr {$row + $uparrowlen - 1}]
3134 if {$r < $commitidx($curview)} {
3136 foreach p
[lindex
$parentlist $r] {
3137 if {[lsearch
-exact $idlist $p] >= 0} continue
3138 set fk
[lindex
$children($curview,$p) 0]
3139 if {$commitrow($curview,$fk) < $row} {
3140 set x
[idcol
$idlist $p $x]
3141 set idlist
[linsert
$idlist $x $p]
3144 if {[incr r
] < $commitidx($curview)} {
3145 set p
[lindex
$displayorder $r]
3146 if {[lsearch
-exact $idlist $p] < 0} {
3147 set fk
[lindex
$children($curview,$p) 0]
3148 if {$fk ne
{} && $commitrow($curview,$fk) < $row} {
3149 set x
[idcol
$idlist $p $x]
3150 set idlist
[linsert
$idlist $x $p]
3156 if {$final && !$viewcomplete($curview) &&
3157 $row + $uparrowlen + $mingaplen + $downarrowlen
3158 >= $commitidx($curview)} {
3161 set l
[llength
$rowidlist]
3163 lappend rowidlist
$idlist
3165 lappend rowfinal
$final
3166 } elseif
{$row < $l} {
3167 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3168 lset rowidlist
$row $idlist
3171 lset rowfinal
$row $final
3173 set pad
[ntimes
[expr {$row - $l}] {}]
3174 set rowidlist
[concat
$rowidlist $pad]
3175 lappend rowidlist
$idlist
3176 set rowfinal
[concat
$rowfinal $pad]
3177 lappend rowfinal
$final
3178 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3184 proc changedrow
{row
} {
3185 global displayorder iddrawn rowisopt need_redisplay
3187 set l
[llength
$rowisopt]
3189 lset rowisopt
$row 0
3190 if {$row + 1 < $l} {
3191 lset rowisopt
[expr {$row + 1}] 0
3192 if {$row + 2 < $l} {
3193 lset rowisopt
[expr {$row + 2}] 0
3197 set id
[lindex
$displayorder $row]
3198 if {[info exists iddrawn
($id)]} {
3199 set need_redisplay
1
3203 proc insert_pad
{row
col npad
} {
3206 set pad
[ntimes
$npad {}]
3207 set idlist
[lindex
$rowidlist $row]
3208 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3209 set aft
[lrange
$idlist $col end
]
3210 set i
[lsearch
-exact $aft {}]
3212 set aft
[lreplace
$aft $i $i]
3214 lset rowidlist
$row [concat
$bef $pad $aft]
3218 proc optimize_rows
{row
col endrow
} {
3219 global rowidlist rowisopt displayorder curview children
3224 for {} {$row < $endrow} {incr row
; set col 0} {
3225 if {[lindex
$rowisopt $row]} continue
3227 set y0
[expr {$row - 1}]
3228 set ym
[expr {$row - 2}]
3229 set idlist
[lindex
$rowidlist $row]
3230 set previdlist
[lindex
$rowidlist $y0]
3231 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3233 set pprevidlist
[lindex
$rowidlist $ym]
3234 if {$pprevidlist eq
{}} continue
3240 for {} {$col < [llength
$idlist]} {incr
col} {
3241 set id
[lindex
$idlist $col]
3242 if {[lindex
$previdlist $col] eq
$id} continue
3247 set x0
[lsearch
-exact $previdlist $id]
3248 if {$x0 < 0} continue
3249 set z
[expr {$x0 - $col}]
3253 set xm
[lsearch
-exact $pprevidlist $id]
3255 set z0
[expr {$xm - $x0}]
3259 # if row y0 is the first child of $id then it's not an arrow
3260 if {[lindex
$children($curview,$id) 0] ne
3261 [lindex
$displayorder $y0]} {
3265 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3266 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3269 # Looking at lines from this row to the previous row,
3270 # make them go straight up if they end in an arrow on
3271 # the previous row; otherwise make them go straight up
3273 if {$z < -1 ||
($z < 0 && $isarrow)} {
3274 # Line currently goes left too much;
3275 # insert pads in the previous row, then optimize it
3276 set npad
[expr {-1 - $z + $isarrow}]
3277 insert_pad
$y0 $x0 $npad
3279 optimize_rows
$y0 $x0 $row
3281 set previdlist
[lindex
$rowidlist $y0]
3282 set x0
[lsearch
-exact $previdlist $id]
3283 set z
[expr {$x0 - $col}]
3285 set pprevidlist
[lindex
$rowidlist $ym]
3286 set xm
[lsearch
-exact $pprevidlist $id]
3287 set z0
[expr {$xm - $x0}]
3289 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3290 # Line currently goes right too much;
3291 # insert pads in this line
3292 set npad
[expr {$z - 1 + $isarrow}]
3293 insert_pad
$row $col $npad
3294 set idlist
[lindex
$rowidlist $row]
3296 set z
[expr {$x0 - $col}]
3299 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3300 # this line links to its first child on row $row-2
3301 set id
[lindex
$displayorder $ym]
3302 set xc
[lsearch
-exact $pprevidlist $id]
3304 set z0
[expr {$xc - $x0}]
3307 # avoid lines jigging left then immediately right
3308 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3309 insert_pad
$y0 $x0 1
3311 optimize_rows
$y0 $x0 $row
3312 set previdlist
[lindex
$rowidlist $y0]
3316 # Find the first column that doesn't have a line going right
3317 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3318 set id
[lindex
$idlist $col]
3319 if {$id eq
{}} break
3320 set x0
[lsearch
-exact $previdlist $id]
3322 # check if this is the link to the first child
3323 set kid
[lindex
$displayorder $y0]
3324 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3325 # it is, work out offset to child
3326 set x0
[lsearch
-exact $previdlist $kid]
3329 if {$x0 <= $col} break
3331 # Insert a pad at that column as long as it has a line and
3332 # isn't the last column
3333 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3334 set idlist
[linsert
$idlist $col {}]
3335 lset rowidlist
$row $idlist
3343 global canvx0 linespc
3344 return [expr {$canvx0 + $col * $linespc}]
3348 global canvy0 linespc
3349 return [expr {$canvy0 + $row * $linespc}]
3352 proc linewidth
{id
} {
3353 global thickerline lthickness
3356 if {[info exists thickerline
] && $id eq
$thickerline} {
3357 set wid
[expr {2 * $lthickness}]
3362 proc rowranges
{id
} {
3363 global commitrow curview children uparrowlen downarrowlen
3366 set kids
$children($curview,$id)
3372 foreach child
$kids {
3373 if {![info exists commitrow
($curview,$child)]} break
3374 set row
$commitrow($curview,$child)
3375 if {![info exists prev
]} {
3376 lappend ret
[expr {$row + 1}]
3378 if {$row <= $prevrow} {
3379 puts
"oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3381 # see if the line extends the whole way from prevrow to row
3382 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3383 [lsearch
-exact [lindex
$rowidlist \
3384 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
3385 # it doesn't, see where it ends
3386 set r
[expr {$prevrow + $downarrowlen}]
3387 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3388 while {[incr r
-1] > $prevrow &&
3389 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3391 while {[incr r
] <= $row &&
3392 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3396 # see where it starts up again
3397 set r
[expr {$row - $uparrowlen}]
3398 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3399 while {[incr r
] < $row &&
3400 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3402 while {[incr r
-1] >= $prevrow &&
3403 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3409 if {$child eq
$id} {
3418 proc drawlineseg
{id row endrow arrowlow
} {
3419 global rowidlist displayorder iddrawn linesegs
3420 global canv colormap linespc curview maxlinelen parentlist
3422 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
3423 set le
[expr {$row + 1}]
3426 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
3432 set x
[lindex
$displayorder $le]
3437 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
3438 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
3454 if {[info exists linesegs
($id)]} {
3455 set lines
$linesegs($id)
3457 set r0
[lindex
$li 0]
3459 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
3469 set li
[lindex
$lines [expr {$i-1}]]
3470 set r1
[lindex
$li 1]
3471 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
3476 set x
[lindex
$cols [expr {$le - $row}]]
3477 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
3478 set dir
[expr {$xp - $x}]
3480 set ith
[lindex
$lines $i 2]
3481 set coords
[$canv coords
$ith]
3482 set ah
[$canv itemcget
$ith -arrow]
3483 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
3484 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
3485 if {$x2 ne
{} && $x - $x2 == $dir} {
3486 set coords
[lrange
$coords 0 end-2
]
3489 set coords
[list
[xc
$le $x] [yc
$le]]
3492 set itl
[lindex
$lines [expr {$i-1}] 2]
3493 set al
[$canv itemcget
$itl -arrow]
3494 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
3495 } elseif
{$arrowlow} {
3496 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
3497 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
3501 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
3502 for {set y
$le} {[incr y
-1] > $row} {} {
3504 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
3505 set ndir
[expr {$xp - $x}]
3506 if {$dir != $ndir ||
$xp < 0} {
3507 lappend coords
[xc
$y $x] [yc
$y]
3513 # join parent line to first child
3514 set ch
[lindex
$displayorder $row]
3515 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
3517 puts
"oops: drawlineseg: child $ch not on row $row"
3518 } elseif
{$xc != $x} {
3519 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
3520 set d
[expr {int
(0.5 * $linespc)}]
3523 set x2
[expr {$x1 - $d}]
3525 set x2
[expr {$x1 + $d}]
3528 set y1
[expr {$y2 + $d}]
3529 lappend coords
$x1 $y1 $x2 $y2
3530 } elseif
{$xc < $x - 1} {
3531 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
3532 } elseif
{$xc > $x + 1} {
3533 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
3537 lappend coords
[xc
$row $x] [yc
$row]
3539 set xn
[xc
$row $xp]
3541 lappend coords
$xn $yn
3545 set t
[$canv create line
$coords -width [linewidth
$id] \
3546 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
3549 set lines
[linsert
$lines $i [list
$row $le $t]]
3551 $canv coords
$ith $coords
3552 if {$arrow ne
$ah} {
3553 $canv itemconf
$ith -arrow $arrow
3555 lset lines
$i 0 $row
3558 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
3559 set ndir
[expr {$xo - $xp}]
3560 set clow
[$canv coords
$itl]
3561 if {$dir == $ndir} {
3562 set clow
[lrange
$clow 2 end
]
3564 set coords
[concat
$coords $clow]
3566 lset lines
[expr {$i-1}] 1 $le
3568 # coalesce two pieces
3570 set b
[lindex
$lines [expr {$i-1}] 0]
3571 set e
[lindex
$lines $i 1]
3572 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
3574 $canv coords
$itl $coords
3575 if {$arrow ne
$al} {
3576 $canv itemconf
$itl -arrow $arrow
3580 set linesegs
($id) $lines
3584 proc drawparentlinks
{id row
} {
3585 global rowidlist canv colormap curview parentlist
3586 global idpos linespc
3588 set rowids
[lindex
$rowidlist $row]
3589 set col [lsearch
-exact $rowids $id]
3590 if {$col < 0} return
3591 set olds
[lindex
$parentlist $row]
3592 set row2
[expr {$row + 1}]
3593 set x
[xc
$row $col]
3596 set d
[expr {int
(0.5 * $linespc)}]
3597 set ymid
[expr {$y + $d}]
3598 set ids
[lindex
$rowidlist $row2]
3599 # rmx = right-most X coord used
3602 set i
[lsearch
-exact $ids $p]
3604 puts
"oops, parent $p of $id not in list"
3607 set x2
[xc
$row2 $i]
3611 set j
[lsearch
-exact $rowids $p]
3613 # drawlineseg will do this one for us
3617 # should handle duplicated parents here...
3618 set coords
[list
$x $y]
3620 # if attaching to a vertical segment, draw a smaller
3621 # slant for visual distinctness
3624 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
3626 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
3628 } elseif
{$i < $col && $i < $j} {
3629 # segment slants towards us already
3630 lappend coords
[xc
$row $j] $y
3632 if {$i < $col - 1} {
3633 lappend coords
[expr {$x2 + $linespc}] $y
3634 } elseif
{$i > $col + 1} {
3635 lappend coords
[expr {$x2 - $linespc}] $y
3637 lappend coords
$x2 $y2
3640 lappend coords
$x2 $y2
3642 set t
[$canv create line
$coords -width [linewidth
$p] \
3643 -fill $colormap($p) -tags lines.
$p]
3647 if {$rmx > [lindex
$idpos($id) 1]} {
3648 lset idpos
($id) 1 $rmx
3653 proc drawlines
{id
} {
3656 $canv itemconf lines.
$id -width [linewidth
$id]
3659 proc drawcmittext
{id row
col} {
3660 global linespc canv canv2 canv3 canvy0 fgcolor curview
3661 global commitlisted commitinfo rowidlist parentlist
3662 global rowtextx idpos idtags idheads idotherrefs
3663 global linehtag linentag linedtag selectedline
3664 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3666 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3667 set listed
[lindex
$commitlisted $row]
3668 if {$id eq
$nullid} {
3670 } elseif
{$id eq
$nullid2} {
3673 set ofill
[expr {$listed != 0 ?
$listed == 2 ?
"gray" : "blue" : "white"}]
3675 set x
[xc
$row $col]
3677 set orad
[expr {$linespc / 3}]
3679 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
3680 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3681 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3682 } elseif
{$listed == 3} {
3683 # triangle pointing left for left-side commits
3684 set t
[$canv create polygon \
3685 [expr {$x - $orad}] $y \
3686 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3687 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3688 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3690 # triangle pointing right for right-side commits
3691 set t
[$canv create polygon \
3692 [expr {$x + $orad - 1}] $y \
3693 [expr {$x - $orad}] [expr {$y - $orad}] \
3694 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3695 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3698 $canv bind $t <1> {selcanvline
{} %x
%y
}
3699 set rmx
[llength
[lindex
$rowidlist $row]]
3700 set olds
[lindex
$parentlist $row]
3702 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
3704 set i
[lsearch
-exact $nextids $p]
3710 set xt
[xc
$row $rmx]
3711 set rowtextx
($row) $xt
3712 set idpos
($id) [list
$x $xt $y]
3713 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
3714 ||
[info exists idotherrefs
($id)]} {
3715 set xt
[drawtags
$id $x $xt $y]
3717 set headline
[lindex
$commitinfo($id) 0]
3718 set name
[lindex
$commitinfo($id) 1]
3719 set date [lindex
$commitinfo($id) 2]
3720 set date [formatdate
$date]
3723 set isbold
[ishighlighted
$row]
3725 lappend boldrows
$row
3726 set font mainfontbold
3728 lappend boldnamerows
$row
3729 set nfont mainfontbold
3732 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
3733 -text $headline -font $font -tags text
]
3734 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
3735 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
3736 -text $name -font $nfont -tags text
]
3737 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
3738 -text $date -font mainfont
-tags text
]
3739 if {[info exists selectedline
] && $selectedline == $row} {
3742 set xr
[expr {$xt + [font measure
$font $headline]}]
3743 if {$xr > $canvxmax} {
3749 proc drawcmitrow
{row
} {
3750 global displayorder rowidlist nrows_drawn
3751 global iddrawn markingmatches
3752 global commitinfo parentlist numcommits
3753 global filehighlight fhighlights findpattern nhighlights
3754 global hlview vhighlights
3755 global highlight_related rhighlights
3757 if {$row >= $numcommits} return
3759 set id
[lindex
$displayorder $row]
3760 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
3761 askvhighlight
$row $id
3763 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
3764 askfilehighlight
$row $id
3766 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
3767 askfindhighlight
$row $id
3769 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
3770 askrelhighlight
$row $id
3772 if {![info exists iddrawn
($id)]} {
3773 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
3775 puts
"oops, row $row id $id not in list"
3778 if {![info exists commitinfo
($id)]} {
3782 drawcmittext
$id $row $col
3786 if {$markingmatches} {
3787 markrowmatches
$row $id
3791 proc drawcommits
{row
{endrow
{}}} {
3792 global numcommits iddrawn displayorder curview need_redisplay
3793 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3798 if {$endrow eq
{}} {
3801 if {$endrow >= $numcommits} {
3802 set endrow
[expr {$numcommits - 1}]
3805 set rl1
[expr {$row - $downarrowlen - 3}]
3809 set ro1
[expr {$row - 3}]
3813 set r2
[expr {$endrow + $uparrowlen + 3}]
3814 if {$r2 > $numcommits} {
3817 for {set r
$rl1} {$r < $r2} {incr r
} {
3818 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
3822 set rl1
[expr {$r + 1}]
3828 optimize_rows
$ro1 0 $r2
3829 if {$need_redisplay ||
$nrows_drawn > 2000} {
3834 # make the lines join to already-drawn rows either side
3835 set r
[expr {$row - 1}]
3836 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
3839 set er
[expr {$endrow + 1}]
3840 if {$er >= $numcommits ||
3841 ![info exists iddrawn
([lindex
$displayorder $er])]} {
3844 for {} {$r <= $er} {incr r
} {
3845 set id
[lindex
$displayorder $r]
3846 set wasdrawn
[info exists iddrawn
($id)]
3848 if {$r == $er} break
3849 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3850 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
3851 drawparentlinks
$id $r
3853 set rowids
[lindex
$rowidlist $r]
3854 foreach lid
$rowids {
3855 if {$lid eq
{}} continue
3856 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
3858 # see if this is the first child of any of its parents
3859 foreach p
[lindex
$parentlist $r] {
3860 if {[lsearch
-exact $rowids $p] < 0} {
3861 # make this line extend up to the child
3862 set lineend
($p) [drawlineseg
$p $r $er 0]
3866 set lineend
($lid) [drawlineseg
$lid $r $er 1]
3872 proc drawfrac
{f0 f1
} {
3875 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3876 if {$ymax eq
{} ||
$ymax == 0} return
3877 set y0
[expr {int
($f0 * $ymax)}]
3878 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
3879 set y1
[expr {int
($f1 * $ymax)}]
3880 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
3881 drawcommits
$row $endrow
3884 proc drawvisible
{} {
3886 eval drawfrac
[$canv yview
]
3889 proc clear_display
{} {
3890 global iddrawn linesegs need_redisplay nrows_drawn
3891 global vhighlights fhighlights nhighlights rhighlights
3894 catch
{unset iddrawn
}
3895 catch
{unset linesegs
}
3896 catch
{unset vhighlights
}
3897 catch
{unset fhighlights
}
3898 catch
{unset nhighlights
}
3899 catch
{unset rhighlights
}
3900 set need_redisplay
0
3904 proc findcrossings
{id
} {
3905 global rowidlist parentlist numcommits displayorder
3909 foreach
{s e
} [rowranges
$id] {
3910 if {$e >= $numcommits} {
3911 set e
[expr {$numcommits - 1}]
3913 if {$e <= $s} continue
3914 for {set row
$e} {[incr row
-1] >= $s} {} {
3915 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
3917 set olds
[lindex
$parentlist $row]
3918 set kid
[lindex
$displayorder $row]
3919 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
3920 if {$kidx < 0} continue
3921 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
3923 set px
[lsearch
-exact $nextrow $p]
3924 if {$px < 0} continue
3925 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
3926 if {[lsearch
-exact $ccross $p] >= 0} continue
3927 if {$x == $px + ($kidx < $px?
-1: 1)} {
3929 } elseif
{[lsearch
-exact $cross $p] < 0} {
3936 return [concat
$ccross {{}} $cross]
3939 proc assigncolor
{id
} {
3940 global colormap colors nextcolor
3941 global commitrow parentlist children children curview
3943 if {[info exists colormap
($id)]} return
3944 set ncolors
[llength
$colors]
3945 if {[info exists children
($curview,$id)]} {
3946 set kids
$children($curview,$id)
3950 if {[llength
$kids] == 1} {
3951 set child
[lindex
$kids 0]
3952 if {[info exists colormap
($child)]
3953 && [llength
[lindex
$parentlist $commitrow($curview,$child)]] == 1} {
3954 set colormap
($id) $colormap($child)
3960 foreach x
[findcrossings
$id] {
3962 # delimiter between corner crossings and other crossings
3963 if {[llength
$badcolors] >= $ncolors - 1} break
3964 set origbad
$badcolors
3966 if {[info exists colormap
($x)]
3967 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
3968 lappend badcolors
$colormap($x)
3971 if {[llength
$badcolors] >= $ncolors} {
3972 set badcolors
$origbad
3974 set origbad
$badcolors
3975 if {[llength
$badcolors] < $ncolors - 1} {
3976 foreach child
$kids {
3977 if {[info exists colormap
($child)]
3978 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
3979 lappend badcolors
$colormap($child)
3981 foreach p
[lindex
$parentlist $commitrow($curview,$child)] {
3982 if {[info exists colormap
($p)]
3983 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
3984 lappend badcolors
$colormap($p)
3988 if {[llength
$badcolors] >= $ncolors} {
3989 set badcolors
$origbad
3992 for {set i
0} {$i <= $ncolors} {incr i
} {
3993 set c
[lindex
$colors $nextcolor]
3994 if {[incr nextcolor
] >= $ncolors} {
3997 if {[lsearch
-exact $badcolors $c]} break
3999 set colormap
($id) $c
4002 proc bindline
{t id
} {
4005 $canv bind $t <Enter
> "lineenter %x %y $id"
4006 $canv bind $t <Motion
> "linemotion %x %y $id"
4007 $canv bind $t <Leave
> "lineleave $id"
4008 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4011 proc drawtags
{id x xt y1
} {
4012 global idtags idheads idotherrefs mainhead
4013 global linespc lthickness
4014 global canv commitrow rowtextx curview fgcolor bgcolor
4019 if {[info exists idtags
($id)]} {
4020 set marks
$idtags($id)
4021 set ntags
[llength
$marks]
4023 if {[info exists idheads
($id)]} {
4024 set marks
[concat
$marks $idheads($id)]
4025 set nheads
[llength
$idheads($id)]
4027 if {[info exists idotherrefs
($id)]} {
4028 set marks
[concat
$marks $idotherrefs($id)]
4034 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4035 set yt
[expr {$y1 - 0.5 * $linespc}]
4036 set yb
[expr {$yt + $linespc - 1}]
4040 foreach tag
$marks {
4042 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4043 set wid
[font measure mainfontbold
$tag]
4045 set wid
[font measure mainfont
$tag]
4049 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4051 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4052 -width $lthickness -fill black
-tags tag.
$id]
4054 foreach tag
$marks x
$xvals wid
$wvals {
4055 set xl
[expr {$x + $delta}]
4056 set xr
[expr {$x + $delta + $wid + $lthickness}]
4058 if {[incr ntags
-1] >= 0} {
4060 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4061 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4062 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4063 $canv bind $t <1> [list showtag
$tag 1]
4064 set rowtextx
($commitrow($curview,$id)) [expr {$xr + $linespc}]
4066 # draw a head or other ref
4067 if {[incr nheads
-1] >= 0} {
4069 if {$tag eq
$mainhead} {
4070 set font mainfontbold
4075 set xl
[expr {$xl - $delta/2}]
4076 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4077 -width 1 -outline black
-fill $col -tags tag.
$id
4078 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4079 set rwid
[font measure mainfont
$remoteprefix]
4080 set xi
[expr {$x + 1}]
4081 set yti
[expr {$yt + 1}]
4082 set xri
[expr {$x + $rwid}]
4083 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4084 -width 0 -fill "#ffddaa" -tags tag.
$id
4087 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4088 -font $font -tags [list tag.
$id text
]]
4090 $canv bind $t <1> [list showtag
$tag 1]
4091 } elseif
{$nheads >= 0} {
4092 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4098 proc xcoord
{i level
ln} {
4099 global canvx0 xspc1 xspc2
4101 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4102 if {$i > 0 && $i == $level} {
4103 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4104 } elseif
{$i > $level} {
4105 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4110 proc show_status
{msg
} {
4114 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4115 -tags text
-fill $fgcolor
4118 # Insert a new commit as the child of the commit on row $row.
4119 # The new commit will be displayed on row $row and the commits
4120 # on that row and below will move down one row.
4121 proc insertrow
{row newcmit
} {
4122 global displayorder parentlist commitlisted children
4123 global commitrow curview rowidlist rowisopt rowfinal numcommits
4125 global selectedline commitidx ordertok
4127 if {$row >= $numcommits} {
4128 puts
"oops, inserting new row $row but only have $numcommits rows"
4131 set p
[lindex
$displayorder $row]
4132 set displayorder
[linsert
$displayorder $row $newcmit]
4133 set parentlist
[linsert
$parentlist $row $p]
4134 set kids
$children($curview,$p)
4135 lappend kids
$newcmit
4136 set children
($curview,$p) $kids
4137 set children
($curview,$newcmit) {}
4138 set commitlisted
[linsert
$commitlisted $row 1]
4139 set l
[llength
$displayorder]
4140 for {set r
$row} {$r < $l} {incr r
} {
4141 set id
[lindex
$displayorder $r]
4142 set commitrow
($curview,$id) $r
4144 incr commitidx
($curview)
4145 set ordertok
($curview,$newcmit) $ordertok($curview,$p)
4147 if {$row < [llength
$rowidlist]} {
4148 set idlist
[lindex
$rowidlist $row]
4149 if {$idlist ne
{}} {
4150 if {[llength
$kids] == 1} {
4151 set col [lsearch
-exact $idlist $p]
4152 lset idlist
$col $newcmit
4154 set col [llength
$idlist]
4155 lappend idlist
$newcmit
4158 set rowidlist
[linsert
$rowidlist $row $idlist]
4159 set rowisopt
[linsert
$rowisopt $row 0]
4160 set rowfinal
[linsert
$rowfinal $row [lindex
$rowfinal $row]]
4165 if {[info exists selectedline
] && $selectedline >= $row} {
4171 # Remove a commit that was inserted with insertrow on row $row.
4172 proc removerow
{row
} {
4173 global displayorder parentlist commitlisted children
4174 global commitrow curview rowidlist rowisopt rowfinal numcommits
4176 global linesegends selectedline commitidx
4178 if {$row >= $numcommits} {
4179 puts
"oops, removing row $row but only have $numcommits rows"
4182 set rp1
[expr {$row + 1}]
4183 set id
[lindex
$displayorder $row]
4184 set p
[lindex
$parentlist $row]
4185 set displayorder
[lreplace
$displayorder $row $row]
4186 set parentlist
[lreplace
$parentlist $row $row]
4187 set commitlisted
[lreplace
$commitlisted $row $row]
4188 set kids
$children($curview,$p)
4189 set i
[lsearch
-exact $kids $id]
4191 set kids
[lreplace
$kids $i $i]
4192 set children
($curview,$p) $kids
4194 set l
[llength
$displayorder]
4195 for {set r
$row} {$r < $l} {incr r
} {
4196 set id
[lindex
$displayorder $r]
4197 set commitrow
($curview,$id) $r
4199 incr commitidx
($curview) -1
4201 if {$row < [llength
$rowidlist]} {
4202 set rowidlist
[lreplace
$rowidlist $row $row]
4203 set rowisopt
[lreplace
$rowisopt $row $row]
4204 set rowfinal
[lreplace
$rowfinal $row $row]
4209 if {[info exists selectedline
] && $selectedline > $row} {
4210 incr selectedline
-1
4215 # Don't change the text pane cursor if it is currently the hand cursor,
4216 # showing that we are over a sha1 ID link.
4217 proc settextcursor
{c
} {
4218 global ctext curtextcursor
4220 if {[$ctext cget
-cursor] == $curtextcursor} {
4221 $ctext config
-cursor $c
4223 set curtextcursor
$c
4226 proc nowbusy
{what
{name
{}}} {
4227 global isbusy busyname statusw
4229 if {[array names isbusy
] eq
{}} {
4230 . config
-cursor watch
4234 set busyname
($what) $name
4236 $statusw conf
-text $name
4240 proc notbusy
{what
} {
4241 global isbusy maincursor textcursor busyname statusw
4245 if {$busyname($what) ne
{} &&
4246 [$statusw cget
-text] eq
$busyname($what)} {
4247 $statusw conf
-text {}
4250 if {[array names isbusy
] eq
{}} {
4251 . config
-cursor $maincursor
4252 settextcursor
$textcursor
4256 proc findmatches
{f
} {
4257 global findtype findstring
4258 if {$findtype == [mc
"Regexp"]} {
4259 set matches
[regexp
-indices -all -inline $findstring $f]
4262 if {$findtype == [mc
"IgnCase"]} {
4263 set f
[string tolower
$f]
4264 set fs
[string tolower
$fs]
4268 set l
[string length
$fs]
4269 while {[set j
[string first
$fs $f $i]] >= 0} {
4270 lappend matches
[list
$j [expr {$j+$l-1}]]
4271 set i
[expr {$j + $l}]
4277 proc dofind
{{dirn
1} {wrap
1}} {
4278 global findstring findstartline findcurline selectedline numcommits
4279 global gdttype filehighlight fh_serial find_dirn findallowwrap
4281 if {[info exists find_dirn
]} {
4282 if {$find_dirn == $dirn} return
4286 if {$findstring eq
{} ||
$numcommits == 0} return
4287 if {![info exists selectedline
]} {
4288 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4290 set findstartline
$selectedline
4292 set findcurline
$findstartline
4293 nowbusy finding
[mc
"Searching"]
4294 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4295 after cancel do_file_hl
$fh_serial
4296 do_file_hl
$fh_serial
4299 set findallowwrap
$wrap
4303 proc stopfinding
{} {
4304 global find_dirn findcurline fprogcoord
4306 if {[info exists find_dirn
]} {
4316 global commitdata commitinfo numcommits findpattern findloc
4317 global findstartline findcurline displayorder
4318 global find_dirn gdttype fhighlights fprogcoord
4319 global findallowwrap
4321 if {![info exists find_dirn
]} {
4324 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4327 if {$find_dirn > 0} {
4329 if {$l >= $numcommits} {
4332 if {$l <= $findstartline} {
4333 set lim
[expr {$findstartline + 1}]
4336 set moretodo
$findallowwrap
4343 if {$l >= $findstartline} {
4344 set lim
[expr {$findstartline - 1}]
4347 set moretodo
$findallowwrap
4350 set n
[expr {($lim - $l) * $find_dirn}]
4357 if {$gdttype eq
[mc
"containing:"]} {
4358 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4359 set id
[lindex
$displayorder $l]
4360 # shouldn't happen unless git log doesn't give all the commits...
4361 if {![info exists commitdata
($id)]} continue
4362 if {![doesmatch
$commitdata($id)]} continue
4363 if {![info exists commitinfo
($id)]} {
4366 set info
$commitinfo($id)
4367 foreach f
$info ty
$fldtypes {
4368 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4377 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4378 set id
[lindex
$displayorder $l]
4379 if {![info exists fhighlights
($l)]} {
4380 askfilehighlight
$l $id
4383 set findcurline
[expr {$l - $find_dirn}]
4385 } elseif
{$fhighlights($l)} {
4391 if {$found ||
($domore && !$moretodo)} {
4407 set findcurline
[expr {$l - $find_dirn}]
4409 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
4413 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
4418 proc findselectline
{l
} {
4419 global findloc commentend ctext findcurline markingmatches gdttype
4421 set markingmatches
1
4424 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
4425 # highlight the matches in the comments
4426 set f
[$ctext get
1.0 $commentend]
4427 set matches
[findmatches
$f]
4428 foreach match
$matches {
4429 set start
[lindex
$match 0]
4430 set end
[expr {[lindex
$match 1] + 1}]
4431 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
4437 # mark the bits of a headline or author that match a find string
4438 proc markmatches
{canv l str tag matches font row
} {
4441 set bbox
[$canv bbox
$tag]
4442 set x0
[lindex
$bbox 0]
4443 set y0
[lindex
$bbox 1]
4444 set y1
[lindex
$bbox 3]
4445 foreach match
$matches {
4446 set start
[lindex
$match 0]
4447 set end
[lindex
$match 1]
4448 if {$start > $end} continue
4449 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
4450 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
4451 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
4452 [expr {$x0+$xlen+2}] $y1 \
4453 -outline {} -tags [list match
$l matches
] -fill yellow
]
4455 if {[info exists selectedline
] && $row == $selectedline} {
4456 $canv raise
$t secsel
4461 proc unmarkmatches
{} {
4462 global markingmatches
4464 allcanvs delete matches
4465 set markingmatches
0
4469 proc selcanvline
{w x y
} {
4470 global canv canvy0 ctext linespc
4472 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4473 if {$ymax == {}} return
4474 set yfrac
[lindex
[$canv yview
] 0]
4475 set y
[expr {$y + $yfrac * $ymax}]
4476 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
4481 if {![info exists rowtextx
($l)] ||
$x < $rowtextx($l)} return
4487 proc commit_descriptor
{p
} {
4489 if {![info exists commitinfo
($p)]} {
4493 if {[llength
$commitinfo($p)] > 1} {
4494 set l
[lindex
$commitinfo($p) 0]
4499 # append some text to the ctext widget, and make any SHA1 ID
4500 # that we know about be a clickable link.
4501 proc appendwithlinks
{text tags
} {
4502 global ctext commitrow linknum curview pendinglinks
4504 set start
[$ctext index
"end - 1c"]
4505 $ctext insert end
$text $tags
4506 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
4510 set linkid
[string range
$text $s $e]
4512 $ctext tag delete link
$linknum
4513 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
4514 setlink
$linkid link
$linknum
4519 proc setlink
{id lk
} {
4520 global curview commitrow ctext pendinglinks commitinterest
4522 if {[info exists commitrow
($curview,$id)]} {
4523 $ctext tag conf
$lk -foreground blue
-underline 1
4524 $ctext tag
bind $lk <1> [list selectline
$commitrow($curview,$id) 1]
4525 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
4526 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
4528 lappend pendinglinks
($id) $lk
4529 lappend commitinterest
($id) {makelink
%I
}
4533 proc makelink
{id
} {
4536 if {![info exists pendinglinks
($id)]} return
4537 foreach lk
$pendinglinks($id) {
4540 unset pendinglinks
($id)
4543 proc linkcursor
{w inc
} {
4544 global linkentercount curtextcursor
4546 if {[incr linkentercount
$inc] > 0} {
4547 $w configure
-cursor hand2
4549 $w configure
-cursor $curtextcursor
4550 if {$linkentercount < 0} {
4551 set linkentercount
0
4556 proc viewnextline
{dir
} {
4560 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4561 set wnow
[$canv yview
]
4562 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4563 set newtop
[expr {$wtop + $dir * $linespc}]
4566 } elseif
{$newtop > $ymax} {
4569 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4572 # add a list of tag or branch names at position pos
4573 # returns the number of names inserted
4574 proc appendrefs
{pos ids var
} {
4575 global ctext commitrow linknum curview
$var maxrefs
4577 if {[catch
{$ctext index
$pos}]} {
4580 $ctext conf
-state normal
4581 $ctext delete
$pos "$pos lineend"
4584 foreach tag
[set $var\
($id\
)] {
4585 lappend tags
[list
$tag $id]
4588 if {[llength
$tags] > $maxrefs} {
4589 $ctext insert
$pos "many ([llength $tags])"
4591 set tags
[lsort
-index 0 -decreasing $tags]
4594 set id
[lindex
$ti 1]
4597 $ctext tag delete
$lk
4598 $ctext insert
$pos $sep
4599 $ctext insert
$pos [lindex
$ti 0] $lk
4604 $ctext conf
-state disabled
4605 return [llength
$tags]
4608 # called when we have finished computing the nearby tags
4609 proc dispneartags
{delay
} {
4610 global selectedline currentid showneartags tagphase
4612 if {![info exists selectedline
] ||
!$showneartags} return
4613 after cancel dispnexttag
4615 after
200 dispnexttag
4618 after idle dispnexttag
4623 proc dispnexttag
{} {
4624 global selectedline currentid showneartags tagphase ctext
4626 if {![info exists selectedline
] ||
!$showneartags} return
4627 switch
-- $tagphase {
4629 set dtags
[desctags
$currentid]
4631 appendrefs precedes
$dtags idtags
4635 set atags
[anctags
$currentid]
4637 appendrefs follows
$atags idtags
4641 set dheads
[descheads
$currentid]
4642 if {$dheads ne
{}} {
4643 if {[appendrefs branch
$dheads idheads
] > 1
4644 && [$ctext get
"branch -3c"] eq
"h"} {
4645 # turn "Branch" into "Branches"
4646 $ctext conf
-state normal
4647 $ctext insert
"branch -2c" "es"
4648 $ctext conf
-state disabled
4653 if {[incr tagphase
] <= 2} {
4654 after idle dispnexttag
4658 proc make_secsel
{l
} {
4659 global linehtag linentag linedtag canv canv2 canv3
4661 if {![info exists linehtag
($l)]} return
4663 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
4664 -tags secsel
-fill [$canv cget
-selectbackground]]
4666 $canv2 delete secsel
4667 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
4668 -tags secsel
-fill [$canv2 cget
-selectbackground]]
4670 $canv3 delete secsel
4671 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
4672 -tags secsel
-fill [$canv3 cget
-selectbackground]]
4676 proc selectline
{l isnew
} {
4677 global canv ctext commitinfo selectedline
4679 global canvy0 linespc parentlist children curview
4680 global currentid sha1entry
4681 global commentend idtags linknum
4682 global mergemax numcommits pending_select
4683 global cmitmode showneartags allcommits
4685 catch
{unset pending_select
}
4690 if {$l < 0 ||
$l >= $numcommits} return
4691 set y
[expr {$canvy0 + $l * $linespc}]
4692 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4693 set ytop
[expr {$y - $linespc - 1}]
4694 set ybot
[expr {$y + $linespc + 1}]
4695 set wnow
[$canv yview
]
4696 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4697 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
4698 set wh
[expr {$wbot - $wtop}]
4700 if {$ytop < $wtop} {
4701 if {$ybot < $wtop} {
4702 set newtop
[expr {$y - $wh / 2.0}]
4705 if {$newtop > $wtop - $linespc} {
4706 set newtop
[expr {$wtop - $linespc}]
4709 } elseif
{$ybot > $wbot} {
4710 if {$ytop > $wbot} {
4711 set newtop
[expr {$y - $wh / 2.0}]
4713 set newtop
[expr {$ybot - $wh}]
4714 if {$newtop < $wtop + $linespc} {
4715 set newtop
[expr {$wtop + $linespc}]
4719 if {$newtop != $wtop} {
4723 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4730 addtohistory
[list selectline
$l 0]
4735 set id
[lindex
$displayorder $l]
4737 $sha1entry delete
0 end
4738 $sha1entry insert
0 $id
4739 $sha1entry selection from
0
4740 $sha1entry selection to end
4743 $ctext conf
-state normal
4746 set info
$commitinfo($id)
4747 set date [formatdate
[lindex
$info 2]]
4748 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
4749 set date [formatdate
[lindex
$info 4]]
4750 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
4751 if {[info exists idtags
($id)]} {
4752 $ctext insert end
[mc
"Tags:"]
4753 foreach tag
$idtags($id) {
4754 $ctext insert end
" $tag"
4756 $ctext insert end
"\n"
4760 set olds
[lindex
$parentlist $l]
4761 if {[llength
$olds] > 1} {
4764 if {$np >= $mergemax} {
4769 $ctext insert end
"[mc "Parent
"]: " $tag
4770 appendwithlinks
[commit_descriptor
$p] {}
4775 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
4779 foreach c
$children($curview,$id) {
4780 append headers
"[mc "Child
"]: [commit_descriptor $c]"
4783 # make anything that looks like a SHA1 ID be a clickable link
4784 appendwithlinks
$headers {}
4785 if {$showneartags} {
4786 if {![info exists allcommits
]} {
4789 $ctext insert end
"[mc "Branch
"]: "
4790 $ctext mark
set branch
"end -1c"
4791 $ctext mark gravity branch left
4792 $ctext insert end
"\n[mc "Follows
"]: "
4793 $ctext mark
set follows
"end -1c"
4794 $ctext mark gravity follows left
4795 $ctext insert end
"\n[mc "Precedes
"]: "
4796 $ctext mark
set precedes
"end -1c"
4797 $ctext mark gravity precedes left
4798 $ctext insert end
"\n"
4801 $ctext insert end
"\n"
4802 set comment
[lindex
$info 5]
4803 if {[string first
"\r" $comment] >= 0} {
4804 set comment
[string map
{"\r" "\n "} $comment]
4806 appendwithlinks
$comment {comment
}
4808 $ctext tag remove found
1.0 end
4809 $ctext conf
-state disabled
4810 set commentend
[$ctext index
"end - 1c"]
4812 init_flist
[mc
"Comments"]
4813 if {$cmitmode eq
"tree"} {
4815 } elseif
{[llength
$olds] <= 1} {
4822 proc selfirstline
{} {
4827 proc sellastline
{} {
4830 set l
[expr {$numcommits - 1}]
4834 proc selnextline
{dir
} {
4837 if {![info exists selectedline
]} return
4838 set l
[expr {$selectedline + $dir}]
4843 proc selnextpage
{dir
} {
4844 global canv linespc selectedline numcommits
4846 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
4850 allcanvs yview scroll
[expr {$dir * $lpp}] units
4852 if {![info exists selectedline
]} return
4853 set l
[expr {$selectedline + $dir * $lpp}]
4856 } elseif
{$l >= $numcommits} {
4857 set l
[expr $numcommits - 1]
4863 proc unselectline
{} {
4864 global selectedline currentid
4866 catch
{unset selectedline
}
4867 catch
{unset currentid
}
4868 allcanvs delete secsel
4872 proc reselectline
{} {
4875 if {[info exists selectedline
]} {
4876 selectline
$selectedline 0
4880 proc addtohistory
{cmd
} {
4881 global
history historyindex curview
4883 set elt
[list
$curview $cmd]
4884 if {$historyindex > 0
4885 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
4889 if {$historyindex < [llength
$history]} {
4890 set history [lreplace
$history $historyindex end
$elt]
4892 lappend
history $elt
4895 if {$historyindex > 1} {
4896 .tf.bar.leftbut conf
-state normal
4898 .tf.bar.leftbut conf
-state disabled
4900 .tf.bar.rightbut conf
-state disabled
4906 set view
[lindex
$elt 0]
4907 set cmd
[lindex
$elt 1]
4908 if {$curview != $view} {
4915 global
history historyindex
4918 if {$historyindex > 1} {
4919 incr historyindex
-1
4920 godo
[lindex
$history [expr {$historyindex - 1}]]
4921 .tf.bar.rightbut conf
-state normal
4923 if {$historyindex <= 1} {
4924 .tf.bar.leftbut conf
-state disabled
4929 global
history historyindex
4932 if {$historyindex < [llength
$history]} {
4933 set cmd
[lindex
$history $historyindex]
4936 .tf.bar.leftbut conf
-state normal
4938 if {$historyindex >= [llength
$history]} {
4939 .tf.bar.rightbut conf
-state disabled
4944 global treefilelist treeidlist diffids diffmergeid treepending
4945 global nullid nullid2
4948 catch
{unset diffmergeid
}
4949 if {![info exists treefilelist
($id)]} {
4950 if {![info exists treepending
]} {
4951 if {$id eq
$nullid} {
4952 set cmd
[list | git ls-files
]
4953 } elseif
{$id eq
$nullid2} {
4954 set cmd
[list | git ls-files
--stage -t]
4956 set cmd
[list | git ls-tree
-r $id]
4958 if {[catch
{set gtf
[open
$cmd r
]}]} {
4962 set treefilelist
($id) {}
4963 set treeidlist
($id) {}
4964 fconfigure
$gtf -blocking 0
4965 filerun
$gtf [list gettreeline
$gtf $id]
4972 proc gettreeline
{gtf id
} {
4973 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4976 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
4977 if {$diffids eq
$nullid} {
4980 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
4981 set i
[string first
"\t" $line]
4982 if {$i < 0} continue
4983 set sha1
[lindex
$line 2]
4984 set fname
[string range
$line [expr {$i+1}] end
]
4985 if {[string index
$fname 0] eq
"\""} {
4986 set fname
[lindex
$fname 0]
4988 lappend treeidlist
($id) $sha1
4990 lappend treefilelist
($id) $fname
4993 return [expr {$nl >= 1000?
2: 1}]
4997 if {$cmitmode ne
"tree"} {
4998 if {![info exists diffmergeid
]} {
4999 gettreediffs
$diffids
5001 } elseif
{$id ne
$diffids} {
5010 global treefilelist treeidlist diffids nullid nullid2
5011 global ctext commentend
5013 set i
[lsearch
-exact $treefilelist($diffids) $f]
5015 puts
"oops, $f not in list for id $diffids"
5018 if {$diffids eq
$nullid} {
5019 if {[catch
{set bf
[open
$f r
]} err
]} {
5020 puts
"oops, can't read $f: $err"
5024 set blob
[lindex
$treeidlist($diffids) $i]
5025 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5026 puts
"oops, error reading blob $blob: $err"
5030 fconfigure
$bf -blocking 0
5031 filerun
$bf [list getblobline
$bf $diffids]
5032 $ctext config
-state normal
5033 clear_ctext
$commentend
5034 $ctext insert end
"\n"
5035 $ctext insert end
"$f\n" filesep
5036 $ctext config
-state disabled
5037 $ctext yview
$commentend
5041 proc getblobline
{bf id
} {
5042 global diffids cmitmode ctext
5044 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5048 $ctext config
-state normal
5050 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5051 $ctext insert end
"$line\n"
5054 # delete last newline
5055 $ctext delete
"end - 2c" "end - 1c"
5059 $ctext config
-state disabled
5060 return [expr {$nl >= 1000?
2: 1}]
5063 proc mergediff
{id l
} {
5064 global diffmergeid mdifffd
5068 global limitdiffs viewfiles curview
5072 # this doesn't seem to actually affect anything...
5073 set cmd
[concat | git diff-tree
--no-commit-id --cc -U$diffcontext $id]
5074 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5075 set cmd
[concat
$cmd -- $viewfiles($curview)]
5077 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5078 error_popup
"[mc "Error getting merge diffs
:"] $err"
5081 fconfigure
$mdf -blocking 0
5082 set mdifffd
($id) $mdf
5083 set np
[llength
[lindex
$parentlist $l]]
5085 filerun
$mdf [list getmergediffline
$mdf $id $np]
5088 proc getmergediffline
{mdf id np
} {
5089 global diffmergeid ctext cflist mergemax
5090 global difffilestart mdifffd
5092 $ctext conf
-state normal
5094 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5095 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5096 ||
$mdf != $mdifffd($id)} {
5100 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5101 # start of a new file
5102 $ctext insert end
"\n"
5103 set here
[$ctext index
"end - 1c"]
5104 lappend difffilestart
$here
5105 add_flist
[list
$fname]
5106 set l
[expr {(78 - [string length
$fname]) / 2}]
5107 set pad
[string range
"----------------------------------------" 1 $l]
5108 $ctext insert end
"$pad $fname $pad\n" filesep
5109 } elseif
{[regexp
{^@@
} $line]} {
5110 $ctext insert end
"$line\n" hunksep
5111 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5114 # parse the prefix - one ' ', '-' or '+' for each parent
5119 for {set j
0} {$j < $np} {incr j
} {
5120 set c
[string range
$line $j $j]
5123 } elseif
{$c == "-"} {
5125 } elseif
{$c == "+"} {
5134 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5135 # line doesn't appear in result, parents in $minuses have the line
5136 set num
[lindex
$minuses 0]
5137 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5138 # line appears in result, parents in $pluses don't have the line
5139 lappend tags mresult
5140 set num
[lindex
$spaces 0]
5143 if {$num >= $mergemax} {
5148 $ctext insert end
"$line\n" $tags
5151 $ctext conf
-state disabled
5156 return [expr {$nr >= 1000?
2: 1}]
5159 proc startdiff
{ids
} {
5160 global treediffs diffids treepending diffmergeid nullid nullid2
5164 catch
{unset diffmergeid
}
5165 if {![info exists treediffs
($ids)] ||
5166 [lsearch
-exact $ids $nullid] >= 0 ||
5167 [lsearch
-exact $ids $nullid2] >= 0} {
5168 if {![info exists treepending
]} {
5176 proc path_filter
{filter name
} {
5178 set l
[string length
$p]
5179 if {[string index
$p end
] eq
"/"} {
5180 if {[string compare
-length $l $p $name] == 0} {
5184 if {[string compare
-length $l $p $name] == 0 &&
5185 ([string length
$name] == $l ||
5186 [string index
$name $l] eq
"/")} {
5194 proc addtocflist
{ids
} {
5197 add_flist
$treediffs($ids)
5201 proc diffcmd
{ids flags
} {
5202 global nullid nullid2
5204 set i
[lsearch
-exact $ids $nullid]
5205 set j
[lsearch
-exact $ids $nullid2]
5207 if {[llength
$ids] > 1 && $j < 0} {
5208 # comparing working directory with some specific revision
5209 set cmd
[concat | git diff-index
$flags]
5211 lappend cmd
-R [lindex
$ids 1]
5213 lappend cmd
[lindex
$ids 0]
5216 # comparing working directory with index
5217 set cmd
[concat | git diff-files
$flags]
5222 } elseif
{$j >= 0} {
5223 set cmd
[concat | git diff-index
--cached $flags]
5224 if {[llength
$ids] > 1} {
5225 # comparing index with specific revision
5227 lappend cmd
-R [lindex
$ids 1]
5229 lappend cmd
[lindex
$ids 0]
5232 # comparing index with HEAD
5236 set cmd
[concat | git diff-tree
-r $flags $ids]
5241 proc gettreediffs
{ids
} {
5242 global treediff treepending
5244 set treepending
$ids
5246 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5247 fconfigure
$gdtf -blocking 0
5248 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5251 proc gettreediffline
{gdtf ids
} {
5252 global treediff treediffs treepending diffids diffmergeid
5253 global cmitmode viewfiles curview limitdiffs
5256 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5257 set i
[string first
"\t" $line]
5259 set file [string range
$line [expr {$i+1}] end
]
5260 if {[string index
$file 0] eq
"\""} {
5261 set file [lindex
$file 0]
5263 lappend treediff
$file
5267 return [expr {$nr >= 1000?
2: 1}]
5270 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5272 foreach f
$treediff {
5273 if {[path_filter
$viewfiles($curview) $f]} {
5277 set treediffs
($ids) $flist
5279 set treediffs
($ids) $treediff
5282 if {$cmitmode eq
"tree"} {
5284 } elseif
{$ids != $diffids} {
5285 if {![info exists diffmergeid
]} {
5286 gettreediffs
$diffids
5294 # empty string or positive integer
5295 proc diffcontextvalidate
{v
} {
5296 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5299 proc diffcontextchange
{n1 n2 op
} {
5300 global diffcontextstring diffcontext
5302 if {[string is integer
-strict $diffcontextstring]} {
5303 if {$diffcontextstring > 0} {
5304 set diffcontext
$diffcontextstring
5310 proc changeignorespace
{} {
5314 proc getblobdiffs
{ids
} {
5315 global blobdifffd diffids env
5316 global diffinhdr treediffs
5319 global limitdiffs viewfiles curview
5321 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5325 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5326 set cmd
[concat
$cmd -- $viewfiles($curview)]
5328 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5329 puts
"error getting diffs: $err"
5333 fconfigure
$bdf -blocking 0
5334 set blobdifffd
($ids) $bdf
5335 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5338 proc setinlist
{var i val
} {
5341 while {[llength
[set $var]] < $i} {
5344 if {[llength
[set $var]] == $i} {
5351 proc makediffhdr
{fname ids
} {
5352 global ctext curdiffstart treediffs
5354 set i
[lsearch
-exact $treediffs($ids) $fname]
5356 setinlist difffilestart
$i $curdiffstart
5358 set l
[expr {(78 - [string length
$fname]) / 2}]
5359 set pad
[string range
"----------------------------------------" 1 $l]
5360 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5363 proc getblobdiffline
{bdf ids
} {
5364 global diffids blobdifffd ctext curdiffstart
5365 global diffnexthead diffnextnote difffilestart
5366 global diffinhdr treediffs
5369 $ctext conf
-state normal
5370 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5371 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5375 if {![string compare
-length 11 "diff --git " $line]} {
5376 # trim off "diff --git "
5377 set line
[string range
$line 11 end
]
5379 # start of a new file
5380 $ctext insert end
"\n"
5381 set curdiffstart
[$ctext index
"end - 1c"]
5382 $ctext insert end
"\n" filesep
5383 # If the name hasn't changed the length will be odd,
5384 # the middle char will be a space, and the two bits either
5385 # side will be a/name and b/name, or "a/name" and "b/name".
5386 # If the name has changed we'll get "rename from" and
5387 # "rename to" or "copy from" and "copy to" lines following this,
5388 # and we'll use them to get the filenames.
5389 # This complexity is necessary because spaces in the filename(s)
5390 # don't get escaped.
5391 set l
[string length
$line]
5392 set i
[expr {$l / 2}]
5393 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5394 [string range
$line 2 [expr {$i - 1}]] eq \
5395 [string range
$line [expr {$i + 3}] end
])} {
5398 # unescape if quoted and chop off the a/ from the front
5399 if {[string index
$line 0] eq
"\""} {
5400 set fname
[string range
[lindex
$line 0] 2 end
]
5402 set fname
[string range
$line 2 [expr {$i - 1}]]
5404 makediffhdr
$fname $ids
5406 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5407 $line match f1l f1c f2l f2c rest
]} {
5408 $ctext insert end
"$line\n" hunksep
5411 } elseif
{$diffinhdr} {
5412 if {![string compare
-length 12 "rename from " $line]} {
5413 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5414 if {[string index
$fname 0] eq
"\""} {
5415 set fname
[lindex
$fname 0]
5417 set i
[lsearch
-exact $treediffs($ids) $fname]
5419 setinlist difffilestart
$i $curdiffstart
5421 } elseif
{![string compare
-length 10 $line "rename to "] ||
5422 ![string compare
-length 8 $line "copy to "]} {
5423 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
5424 if {[string index
$fname 0] eq
"\""} {
5425 set fname
[lindex
$fname 0]
5427 makediffhdr
$fname $ids
5428 } elseif
{[string compare
-length 3 $line "---"] == 0} {
5431 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
5435 $ctext insert end
"$line\n" filesep
5438 set x
[string range
$line 0 0]
5439 if {$x == "-" ||
$x == "+"} {
5440 set tag
[expr {$x == "+"}]
5441 $ctext insert end
"$line\n" d
$tag
5442 } elseif
{$x == " "} {
5443 $ctext insert end
"$line\n"
5445 # "\ No newline at end of file",
5446 # or something else we don't recognize
5447 $ctext insert end
"$line\n" hunksep
5451 $ctext conf
-state disabled
5456 return [expr {$nr >= 1000?
2: 1}]
5459 proc changediffdisp
{} {
5460 global ctext diffelide
5462 $ctext tag conf d0
-elide [lindex
$diffelide 0]
5463 $ctext tag conf d1
-elide [lindex
$diffelide 1]
5467 global difffilestart ctext
5468 set prev
[lindex
$difffilestart 0]
5469 set here
[$ctext index @
0,0]
5470 foreach loc
$difffilestart {
5471 if {[$ctext compare
$loc >= $here]} {
5481 global difffilestart ctext
5482 set here
[$ctext index @
0,0]
5483 foreach loc
$difffilestart {
5484 if {[$ctext compare
$loc > $here]} {
5491 proc clear_ctext
{{first
1.0}} {
5492 global ctext smarktop smarkbot
5495 set l
[lindex
[split $first .
] 0]
5496 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
5499 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
5502 $ctext delete
$first end
5503 if {$first eq
"1.0"} {
5504 catch
{unset pendinglinks
}
5508 proc settabs
{{firstab
{}}} {
5509 global firsttabstop tabstop ctext have_tk85
5511 if {$firstab ne
{} && $have_tk85} {
5512 set firsttabstop
$firstab
5514 set w
[font measure textfont
"0"]
5515 if {$firsttabstop != 0} {
5516 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
5517 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5518 } elseif
{$have_tk85 ||
$tabstop != 8} {
5519 $ctext conf
-tabs [expr {$tabstop * $w}]
5521 $ctext conf
-tabs {}
5525 proc incrsearch
{name ix op
} {
5526 global ctext searchstring searchdirn
5528 $ctext tag remove found
1.0 end
5529 if {[catch
{$ctext index anchor
}]} {
5530 # no anchor set, use start of selection, or of visible area
5531 set sel
[$ctext tag ranges sel
]
5533 $ctext mark
set anchor
[lindex
$sel 0]
5534 } elseif
{$searchdirn eq
"-forwards"} {
5535 $ctext mark
set anchor @
0,0
5537 $ctext mark
set anchor @
0,[winfo height
$ctext]
5540 if {$searchstring ne
{}} {
5541 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
5550 global sstring ctext searchstring searchdirn
5553 $sstring icursor end
5554 set searchdirn
-forwards
5555 if {$searchstring ne
{}} {
5556 set sel
[$ctext tag ranges sel
]
5558 set start
"[lindex $sel 0] + 1c"
5559 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5562 set match
[$ctext search
-count mlen
-- $searchstring $start]
5563 $ctext tag remove sel
1.0 end
5569 set mend
"$match + $mlen c"
5570 $ctext tag add sel
$match $mend
5571 $ctext mark
unset anchor
5575 proc dosearchback
{} {
5576 global sstring ctext searchstring searchdirn
5579 $sstring icursor end
5580 set searchdirn
-backwards
5581 if {$searchstring ne
{}} {
5582 set sel
[$ctext tag ranges sel
]
5584 set start
[lindex
$sel 0]
5585 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5586 set start @
0,[winfo height
$ctext]
5588 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
5589 $ctext tag remove sel
1.0 end
5595 set mend
"$match + $ml c"
5596 $ctext tag add sel
$match $mend
5597 $ctext mark
unset anchor
5601 proc searchmark
{first last
} {
5602 global ctext searchstring
5606 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
5607 if {$match eq
{}} break
5608 set mend
"$match + $mlen c"
5609 $ctext tag add found
$match $mend
5613 proc searchmarkvisible
{doall
} {
5614 global ctext smarktop smarkbot
5616 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
5617 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
5618 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
5619 # no overlap with previous
5620 searchmark
$topline $botline
5621 set smarktop
$topline
5622 set smarkbot
$botline
5624 if {$topline < $smarktop} {
5625 searchmark
$topline [expr {$smarktop-1}]
5626 set smarktop
$topline
5628 if {$botline > $smarkbot} {
5629 searchmark
[expr {$smarkbot+1}] $botline
5630 set smarkbot
$botline
5635 proc scrolltext
{f0 f1
} {
5638 .bleft.sb
set $f0 $f1
5639 if {$searchstring ne
{}} {
5645 global linespc charspc canvx0 canvy0
5646 global xspc1 xspc2 lthickness
5648 set linespc
[font metrics mainfont
-linespace]
5649 set charspc
[font measure mainfont
"m"]
5650 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
5651 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
5652 set lthickness
[expr {int
($linespc / 9) + 1}]
5653 set xspc1
(0) $linespc
5661 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5662 if {$ymax eq
{} ||
$ymax == 0} return
5663 set span
[$canv yview
]
5666 allcanvs yview moveto
[lindex
$span 0]
5668 if {[info exists selectedline
]} {
5669 selectline
$selectedline 0
5670 allcanvs yview moveto
[lindex
$span 0]
5674 proc parsefont
{f n
} {
5677 set fontattr
($f,family
) [lindex
$n 0]
5679 if {$s eq
{} ||
$s == 0} {
5682 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
5684 set fontattr
($f,size
) $s
5685 set fontattr
($f,weight
) normal
5686 set fontattr
($f,slant
) roman
5687 foreach style
[lrange
$n 2 end
] {
5690 "bold" {set fontattr
($f,weight
) $style}
5692 "italic" {set fontattr
($f,slant
) $style}
5697 proc fontflags
{f
{isbold
0}} {
5700 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
5701 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
5702 -slant $fontattr($f,slant
)]
5708 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
5709 if {$fontattr($f,weight
) eq
"bold"} {
5712 if {$fontattr($f,slant
) eq
"italic"} {
5718 proc incrfont
{inc
} {
5719 global mainfont textfont ctext canv phase cflist showrefstop
5720 global stopped entries fontattr
5723 set s
$fontattr(mainfont
,size
)
5728 set fontattr
(mainfont
,size
) $s
5729 font config mainfont
-size $s
5730 font config mainfontbold
-size $s
5731 set mainfont
[fontname mainfont
]
5732 set s
$fontattr(textfont
,size
)
5737 set fontattr
(textfont
,size
) $s
5738 font config textfont
-size $s
5739 font config textfontbold
-size $s
5740 set textfont
[fontname textfont
]
5747 global sha1entry sha1string
5748 if {[string length
$sha1string] == 40} {
5749 $sha1entry delete
0 end
5753 proc sha1change
{n1 n2 op
} {
5754 global sha1string currentid sha1but
5755 if {$sha1string == {}
5756 ||
([info exists currentid
] && $sha1string == $currentid)} {
5761 if {[$sha1but cget
-state] == $state} return
5762 if {$state == "normal"} {
5763 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
5765 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
5769 proc gotocommit
{} {
5770 global sha1string currentid commitrow tagids headids
5771 global displayorder numcommits curview
5773 if {$sha1string == {}
5774 ||
([info exists currentid
] && $sha1string == $currentid)} return
5775 if {[info exists tagids
($sha1string)]} {
5776 set id
$tagids($sha1string)
5777 } elseif
{[info exists headids
($sha1string)]} {
5778 set id
$headids($sha1string)
5780 set id
[string tolower
$sha1string]
5781 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
5783 foreach i
$displayorder {
5784 if {[string match
$id* $i]} {
5788 if {$matches ne
{}} {
5789 if {[llength
$matches] > 1} {
5790 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
5793 set id
[lindex
$matches 0]
5797 if {[info exists commitrow
($curview,$id)]} {
5798 selectline
$commitrow($curview,$id) 1
5801 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
5802 set msg
[mc
"SHA1 id %s is not known" $sha1string]
5804 set msg
[mc
"Tag/Head %s is not known" $sha1string]
5809 proc lineenter
{x y id
} {
5810 global hoverx hovery hoverid hovertimer
5811 global commitinfo canv
5813 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5817 if {[info exists hovertimer
]} {
5818 after cancel
$hovertimer
5820 set hovertimer
[after
500 linehover
]
5824 proc linemotion
{x y id
} {
5825 global hoverx hovery hoverid hovertimer
5827 if {[info exists hoverid
] && $id == $hoverid} {
5830 if {[info exists hovertimer
]} {
5831 after cancel
$hovertimer
5833 set hovertimer
[after
500 linehover
]
5837 proc lineleave
{id
} {
5838 global hoverid hovertimer canv
5840 if {[info exists hoverid
] && $id == $hoverid} {
5842 if {[info exists hovertimer
]} {
5843 after cancel
$hovertimer
5851 global hoverx hovery hoverid hovertimer
5852 global canv linespc lthickness
5855 set text
[lindex
$commitinfo($hoverid) 0]
5856 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5857 if {$ymax == {}} return
5858 set yfrac
[lindex
[$canv yview
] 0]
5859 set x
[expr {$hoverx + 2 * $linespc}]
5860 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5861 set x0
[expr {$x - 2 * $lthickness}]
5862 set y0
[expr {$y - 2 * $lthickness}]
5863 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
5864 set y1
[expr {$y + $linespc + 2 * $lthickness}]
5865 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
5866 -fill \
#ffff80 -outline black -width 1 -tags hover]
5868 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
5873 proc clickisonarrow
{id y
} {
5876 set ranges
[rowranges
$id]
5877 set thresh
[expr {2 * $lthickness + 6}]
5878 set n
[expr {[llength
$ranges] - 1}]
5879 for {set i
1} {$i < $n} {incr i
} {
5880 set row
[lindex
$ranges $i]
5881 if {abs
([yc
$row] - $y) < $thresh} {
5888 proc arrowjump
{id n y
} {
5891 # 1 <-> 2, 3 <-> 4, etc...
5892 set n
[expr {(($n - 1) ^
1) + 1}]
5893 set row
[lindex
[rowranges
$id] $n]
5895 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5896 if {$ymax eq
{} ||
$ymax <= 0} return
5897 set view
[$canv yview
]
5898 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
5899 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
5903 allcanvs yview moveto
$yfrac
5906 proc lineclick
{x y id isnew
} {
5907 global ctext commitinfo children canv thickerline curview commitrow
5909 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5914 # draw this line thicker than normal
5918 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5919 if {$ymax eq
{}} return
5920 set yfrac
[lindex
[$canv yview
] 0]
5921 set y
[expr {$y + $yfrac * $ymax}]
5923 set dirn
[clickisonarrow
$id $y]
5925 arrowjump
$id $dirn $y
5930 addtohistory
[list lineclick
$x $y $id 0]
5932 # fill the details pane with info about this line
5933 $ctext conf
-state normal
5936 $ctext insert end
"[mc "Parent
"]:\t"
5937 $ctext insert end
$id link0
5939 set info
$commitinfo($id)
5940 $ctext insert end
"\n\t[lindex $info 0]\n"
5941 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
5942 set date [formatdate
[lindex
$info 2]]
5943 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
5944 set kids
$children($curview,$id)
5946 $ctext insert end
"\n[mc "Children
"]:"
5948 foreach child
$kids {
5950 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
5951 set info
$commitinfo($child)
5952 $ctext insert end
"\n\t"
5953 $ctext insert end
$child link
$i
5954 setlink
$child link
$i
5955 $ctext insert end
"\n\t[lindex $info 0]"
5956 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
5957 set date [formatdate
[lindex
$info 2]]
5958 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
5961 $ctext conf
-state disabled
5965 proc normalline
{} {
5967 if {[info exists thickerline
]} {
5975 global commitrow curview
5976 if {[info exists commitrow
($curview,$id)]} {
5977 selectline
$commitrow($curview,$id) 1
5983 if {![info exists startmstime
]} {
5984 set startmstime
[clock clicks
-milliseconds]
5986 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
5989 proc rowmenu
{x y id
} {
5990 global rowctxmenu commitrow selectedline rowmenuid curview
5991 global nullid nullid2 fakerowmenu mainhead
5995 if {![info exists selectedline
]
5996 ||
$commitrow($curview,$id) eq
$selectedline} {
6001 if {$id ne
$nullid && $id ne
$nullid2} {
6002 set menu
$rowctxmenu
6003 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6005 set menu
$fakerowmenu
6007 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6008 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6009 $menu entryconfigure
[mc
"Make patch"] -state $state
6010 tk_popup
$menu $x $y
6013 proc diffvssel
{dirn
} {
6014 global rowmenuid selectedline displayorder
6016 if {![info exists selectedline
]} return
6018 set oldid
[lindex
$displayorder $selectedline]
6019 set newid
$rowmenuid
6021 set oldid
$rowmenuid
6022 set newid
[lindex
$displayorder $selectedline]
6024 addtohistory
[list doseldiff
$oldid $newid]
6025 doseldiff
$oldid $newid
6028 proc doseldiff
{oldid newid
} {
6032 $ctext conf
-state normal
6034 init_flist
[mc
"Top"]
6035 $ctext insert end
"[mc "From
"] "
6036 $ctext insert end
$oldid link0
6037 setlink
$oldid link0
6038 $ctext insert end
"\n "
6039 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6040 $ctext insert end
"\n\n[mc "To
"] "
6041 $ctext insert end
$newid link1
6042 setlink
$newid link1
6043 $ctext insert end
"\n "
6044 $ctext insert end
[lindex
$commitinfo($newid) 0]
6045 $ctext insert end
"\n"
6046 $ctext conf
-state disabled
6047 $ctext tag remove found
1.0 end
6048 startdiff
[list
$oldid $newid]
6052 global rowmenuid currentid commitinfo patchtop patchnum
6054 if {![info exists currentid
]} return
6055 set oldid
$currentid
6056 set oldhead
[lindex
$commitinfo($oldid) 0]
6057 set newid
$rowmenuid
6058 set newhead
[lindex
$commitinfo($newid) 0]
6061 catch
{destroy
$top}
6063 label
$top.title
-text [mc
"Generate patch"]
6064 grid
$top.title
- -pady 10
6065 label
$top.from
-text [mc
"From:"]
6066 entry
$top.fromsha1
-width 40 -relief flat
6067 $top.fromsha1 insert
0 $oldid
6068 $top.fromsha1 conf
-state readonly
6069 grid
$top.from
$top.fromsha1
-sticky w
6070 entry
$top.fromhead
-width 60 -relief flat
6071 $top.fromhead insert
0 $oldhead
6072 $top.fromhead conf
-state readonly
6073 grid x
$top.fromhead
-sticky w
6074 label
$top.to
-text [mc
"To:"]
6075 entry
$top.tosha1
-width 40 -relief flat
6076 $top.tosha1 insert
0 $newid
6077 $top.tosha1 conf
-state readonly
6078 grid
$top.to
$top.tosha1
-sticky w
6079 entry
$top.tohead
-width 60 -relief flat
6080 $top.tohead insert
0 $newhead
6081 $top.tohead conf
-state readonly
6082 grid x
$top.tohead
-sticky w
6083 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6084 grid
$top.
rev x
-pady 10
6085 label
$top.flab
-text [mc
"Output file:"]
6086 entry
$top.fname
-width 60
6087 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6089 grid
$top.flab
$top.fname
-sticky w
6091 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6092 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6093 grid
$top.buts.gen
$top.buts.can
6094 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6095 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6096 grid
$top.buts
- -pady 10 -sticky ew
6100 proc mkpatchrev
{} {
6103 set oldid
[$patchtop.fromsha1 get
]
6104 set oldhead
[$patchtop.fromhead get
]
6105 set newid
[$patchtop.tosha1 get
]
6106 set newhead
[$patchtop.tohead get
]
6107 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6108 v
[list
$newid $newhead $oldid $oldhead] {
6109 $patchtop.
$e conf
-state normal
6110 $patchtop.
$e delete
0 end
6111 $patchtop.
$e insert
0 $v
6112 $patchtop.
$e conf
-state readonly
6117 global patchtop nullid nullid2
6119 set oldid
[$patchtop.fromsha1 get
]
6120 set newid
[$patchtop.tosha1 get
]
6121 set fname
[$patchtop.fname get
]
6122 set cmd
[diffcmd
[list
$oldid $newid] -p]
6123 # trim off the initial "|"
6124 set cmd
[lrange
$cmd 1 end
]
6125 lappend cmd
>$fname &
6126 if {[catch
{eval exec $cmd} err
]} {
6127 error_popup
"[mc "Error creating
patch:"] $err"
6129 catch
{destroy
$patchtop}
6133 proc mkpatchcan
{} {
6136 catch
{destroy
$patchtop}
6141 global rowmenuid mktagtop commitinfo
6145 catch
{destroy
$top}
6147 label
$top.title
-text [mc
"Create tag"]
6148 grid
$top.title
- -pady 10
6149 label
$top.id
-text [mc
"ID:"]
6150 entry
$top.sha1
-width 40 -relief flat
6151 $top.sha1 insert
0 $rowmenuid
6152 $top.sha1 conf
-state readonly
6153 grid
$top.id
$top.sha1
-sticky w
6154 entry
$top.
head -width 60 -relief flat
6155 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6156 $top.
head conf
-state readonly
6157 grid x
$top.
head -sticky w
6158 label
$top.tlab
-text [mc
"Tag name:"]
6159 entry
$top.tag
-width 60
6160 grid
$top.tlab
$top.tag
-sticky w
6162 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6163 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6164 grid
$top.buts.gen
$top.buts.can
6165 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6166 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6167 grid
$top.buts
- -pady 10 -sticky ew
6172 global mktagtop env tagids idtags
6174 set id
[$mktagtop.sha1 get
]
6175 set tag
[$mktagtop.tag get
]
6177 error_popup
[mc
"No tag name specified"]
6180 if {[info exists tagids
($tag)]} {
6181 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6185 exec git tag
$tag $id
6187 error_popup
"[mc "Error creating tag
:"] $err"
6191 set tagids
($tag) $id
6192 lappend idtags
($id) $tag
6199 proc redrawtags
{id
} {
6200 global canv linehtag commitrow idpos selectedline curview
6201 global canvxmax iddrawn
6203 if {![info exists commitrow
($curview,$id)]} return
6204 if {![info exists iddrawn
($id)]} return
6205 drawcommits
$commitrow($curview,$id)
6206 $canv delete tag.
$id
6207 set xt
[eval drawtags
$id $idpos($id)]
6208 $canv coords
$linehtag($commitrow($curview,$id)) $xt [lindex
$idpos($id) 2]
6209 set text
[$canv itemcget
$linehtag($commitrow($curview,$id)) -text]
6210 set xr
[expr {$xt + [font measure mainfont
$text]}]
6211 if {$xr > $canvxmax} {
6215 if {[info exists selectedline
]
6216 && $selectedline == $commitrow($curview,$id)} {
6217 selectline
$selectedline 0
6224 catch
{destroy
$mktagtop}
6233 proc writecommit
{} {
6234 global rowmenuid wrcomtop commitinfo wrcomcmd
6236 set top .writecommit
6238 catch
{destroy
$top}
6240 label
$top.title
-text [mc
"Write commit to file"]
6241 grid
$top.title
- -pady 10
6242 label
$top.id
-text [mc
"ID:"]
6243 entry
$top.sha1
-width 40 -relief flat
6244 $top.sha1 insert
0 $rowmenuid
6245 $top.sha1 conf
-state readonly
6246 grid
$top.id
$top.sha1
-sticky w
6247 entry
$top.
head -width 60 -relief flat
6248 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6249 $top.
head conf
-state readonly
6250 grid x
$top.
head -sticky w
6251 label
$top.clab
-text [mc
"Command:"]
6252 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6253 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6254 label
$top.flab
-text [mc
"Output file:"]
6255 entry
$top.fname
-width 60
6256 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6257 grid
$top.flab
$top.fname
-sticky w
6259 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6260 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6261 grid
$top.buts.gen
$top.buts.can
6262 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6263 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6264 grid
$top.buts
- -pady 10 -sticky ew
6271 set id
[$wrcomtop.sha1 get
]
6272 set cmd
"echo $id | [$wrcomtop.cmd get]"
6273 set fname
[$wrcomtop.fname get
]
6274 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6275 error_popup
"[mc "Error writing commit
:"] $err"
6277 catch
{destroy
$wrcomtop}
6284 catch
{destroy
$wrcomtop}
6289 global rowmenuid mkbrtop
6292 catch
{destroy
$top}
6294 label
$top.title
-text [mc
"Create new branch"]
6295 grid
$top.title
- -pady 10
6296 label
$top.id
-text [mc
"ID:"]
6297 entry
$top.sha1
-width 40 -relief flat
6298 $top.sha1 insert
0 $rowmenuid
6299 $top.sha1 conf
-state readonly
6300 grid
$top.id
$top.sha1
-sticky w
6301 label
$top.nlab
-text [mc
"Name:"]
6302 entry
$top.name
-width 40
6303 grid
$top.nlab
$top.name
-sticky w
6305 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6306 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6307 grid
$top.buts.go
$top.buts.can
6308 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6309 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6310 grid
$top.buts
- -pady 10 -sticky ew
6315 global headids idheads
6317 set name
[$top.name get
]
6318 set id
[$top.sha1 get
]
6320 error_popup
[mc
"Please specify a name for the new branch"]
6323 catch
{destroy
$top}
6327 exec git branch
$name $id
6332 set headids
($name) $id
6333 lappend idheads
($id) $name
6342 proc cherrypick
{} {
6343 global rowmenuid curview commitrow
6346 set oldhead
[exec git rev-parse HEAD
]
6347 set dheads
[descheads
$rowmenuid]
6348 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6349 set ok
[confirm_popup
[mc
"Commit %s is already\
6350 included in branch %s -- really re-apply it?" \
6351 [string range
$rowmenuid 0 7] $mainhead]]
6354 nowbusy cherrypick
[mc
"Cherry-picking"]
6356 # Unfortunately git-cherry-pick writes stuff to stderr even when
6357 # no error occurs, and exec takes that as an indication of error...
6358 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6363 set newhead
[exec git rev-parse HEAD
]
6364 if {$newhead eq
$oldhead} {
6366 error_popup
[mc
"No changes committed"]
6369 addnewchild
$newhead $oldhead
6370 if {[info exists commitrow
($curview,$oldhead)]} {
6371 insertrow
$commitrow($curview,$oldhead) $newhead
6372 if {$mainhead ne
{}} {
6373 movehead
$newhead $mainhead
6374 movedhead
$newhead $mainhead
6383 global mainheadid mainhead rowmenuid confirm_ok resettype
6386 set w
".confirmreset"
6389 wm title
$w [mc
"Confirm reset"]
6390 message
$w.m
-text \
6391 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6392 -justify center
-aspect 1000
6393 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6394 frame
$w.f
-relief sunken
-border 2
6395 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6396 grid
$w.f.rt
-sticky w
6398 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6399 -text [mc
"Soft: Leave working tree and index untouched"]
6400 grid
$w.f.soft
-sticky w
6401 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6402 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6403 grid
$w.f.mixed
-sticky w
6404 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6405 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6406 grid
$w.f.hard
-sticky w
6407 pack
$w.f
-side top
-fill x
6408 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6409 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6410 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6411 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6412 bind $w <Visibility
> "grab $w; focus $w"
6414 if {!$confirm_ok} return
6415 if {[catch
{set fd
[open \
6416 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
6420 filerun
$fd [list readresetstat
$fd]
6421 nowbusy
reset [mc
"Resetting"]
6425 proc readresetstat
{fd
} {
6426 global mainhead mainheadid showlocalchanges rprogcoord
6428 if {[gets
$fd line
] >= 0} {
6429 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
6430 set rprogcoord
[expr {1.0 * $m / $n}]
6438 if {[catch
{close
$fd} err
]} {
6441 set oldhead
$mainheadid
6442 set newhead
[exec git rev-parse HEAD
]
6443 if {$newhead ne
$oldhead} {
6444 movehead
$newhead $mainhead
6445 movedhead
$newhead $mainhead
6446 set mainheadid
$newhead
6450 if {$showlocalchanges} {
6456 # context menu for a head
6457 proc headmenu
{x y id
head} {
6458 global headmenuid headmenuhead headctxmenu mainhead
6462 set headmenuhead
$head
6464 if {$head eq
$mainhead} {
6467 $headctxmenu entryconfigure
0 -state $state
6468 $headctxmenu entryconfigure
1 -state $state
6469 tk_popup
$headctxmenu $x $y
6473 global headmenuid headmenuhead mainhead headids
6474 global showlocalchanges mainheadid
6476 # check the tree is clean first??
6477 set oldmainhead
$mainhead
6478 nowbusy checkout
[mc
"Checking out"]
6482 exec git checkout
-q $headmenuhead
6488 set mainhead
$headmenuhead
6489 set mainheadid
$headmenuid
6490 if {[info exists headids
($oldmainhead)]} {
6491 redrawtags
$headids($oldmainhead)
6493 redrawtags
$headmenuid
6495 if {$showlocalchanges} {
6501 global headmenuid headmenuhead mainhead
6504 set head $headmenuhead
6506 # this check shouldn't be needed any more...
6507 if {$head eq
$mainhead} {
6508 error_popup
[mc
"Cannot delete the currently checked-out branch"]
6511 set dheads
[descheads
$id]
6512 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
6513 # the stuff on this branch isn't on any other branch
6514 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
6515 branch.\nReally delete branch %s?" $head $head]]} return
6519 if {[catch
{exec git branch
-D $head} err
]} {
6524 removehead
$id $head
6525 removedhead
$id $head
6532 # Display a list of tags and heads
6534 global showrefstop bgcolor fgcolor selectbgcolor
6535 global bglist fglist reflistfilter reflist maincursor
6538 set showrefstop
$top
6539 if {[winfo exists
$top]} {
6545 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
6546 text
$top.list
-background $bgcolor -foreground $fgcolor \
6547 -selectbackground $selectbgcolor -font mainfont \
6548 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6549 -width 30 -height 20 -cursor $maincursor \
6550 -spacing1 1 -spacing3 1 -state disabled
6551 $top.list tag configure highlight
-background $selectbgcolor
6552 lappend bglist
$top.list
6553 lappend fglist
$top.list
6554 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
6555 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
6556 grid
$top.list
$top.ysb
-sticky nsew
6557 grid
$top.xsb x
-sticky ew
6559 label
$top.f.l
-text "[mc "Filter
"]: "
6560 entry
$top.f.e
-width 20 -textvariable reflistfilter
6561 set reflistfilter
"*"
6562 trace add variable reflistfilter
write reflistfilter_change
6563 pack
$top.f.e
-side right
-fill x
-expand 1
6564 pack
$top.f.l
-side left
6565 grid
$top.f
- -sticky ew
-pady 2
6566 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
6568 grid columnconfigure
$top 0 -weight 1
6569 grid rowconfigure
$top 0 -weight 1
6570 bind $top.list
<1> {break}
6571 bind $top.list
<B1-Motion
> {break}
6572 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
6577 proc sel_reflist
{w x y
} {
6578 global showrefstop reflist headids tagids otherrefids
6580 if {![winfo exists
$showrefstop]} return
6581 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
6582 set ref
[lindex
$reflist [expr {$l-1}]]
6583 set n
[lindex
$ref 0]
6584 switch
-- [lindex
$ref 1] {
6585 "H" {selbyid
$headids($n)}
6586 "T" {selbyid
$tagids($n)}
6587 "o" {selbyid
$otherrefids($n)}
6589 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
6592 proc unsel_reflist
{} {
6595 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6596 $showrefstop.list tag remove highlight
0.0 end
6599 proc reflistfilter_change
{n1 n2 op
} {
6600 global reflistfilter
6602 after cancel refill_reflist
6603 after
200 refill_reflist
6606 proc refill_reflist
{} {
6607 global reflist reflistfilter showrefstop headids tagids otherrefids
6608 global commitrow curview commitinterest
6610 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6612 foreach n
[array names headids
] {
6613 if {[string match
$reflistfilter $n]} {
6614 if {[info exists commitrow
($curview,$headids($n))]} {
6615 lappend refs
[list
$n H
]
6617 set commitinterest
($headids($n)) {run refill_reflist
}
6621 foreach n
[array names tagids
] {
6622 if {[string match
$reflistfilter $n]} {
6623 if {[info exists commitrow
($curview,$tagids($n))]} {
6624 lappend refs
[list
$n T
]
6626 set commitinterest
($tagids($n)) {run refill_reflist
}
6630 foreach n
[array names otherrefids
] {
6631 if {[string match
$reflistfilter $n]} {
6632 if {[info exists commitrow
($curview,$otherrefids($n))]} {
6633 lappend refs
[list
$n o
]
6635 set commitinterest
($otherrefids($n)) {run refill_reflist
}
6639 set refs
[lsort
-index 0 $refs]
6640 if {$refs eq
$reflist} return
6642 # Update the contents of $showrefstop.list according to the
6643 # differences between $reflist (old) and $refs (new)
6644 $showrefstop.list conf
-state normal
6645 $showrefstop.list insert end
"\n"
6648 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
6649 if {$i < [llength
$reflist]} {
6650 if {$j < [llength
$refs]} {
6651 set cmp [string compare
[lindex
$reflist $i 0] \
6652 [lindex
$refs $j 0]]
6654 set cmp [string compare
[lindex
$reflist $i 1] \
6655 [lindex
$refs $j 1]]
6665 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
6673 set l
[expr {$j + 1}]
6674 $showrefstop.list image create
$l.0 -align baseline \
6675 -image reficon-
[lindex
$refs $j 1] -padx 2
6676 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
6682 # delete last newline
6683 $showrefstop.list delete end-2c end-1c
6684 $showrefstop.list conf
-state disabled
6687 # Stuff for finding nearby tags
6688 proc getallcommits
{} {
6689 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6690 global idheads idtags idotherrefs allparents tagobjid
6692 if {![info exists allcommits
]} {
6698 set allccache
[file join [gitdir
] "gitk.cache"]
6700 set f
[open
$allccache r
]
6709 set cmd
[list | git rev-list
--parents]
6710 set allcupdate
[expr {$seeds ne
{}}]
6714 set refs
[concat
[array names idheads
] [array names idtags
] \
6715 [array names idotherrefs
]]
6718 foreach name
[array names tagobjid
] {
6719 lappend tagobjs
$tagobjid($name)
6721 foreach id
[lsort
-unique $refs] {
6722 if {![info exists allparents
($id)] &&
6723 [lsearch
-exact $tagobjs $id] < 0} {
6734 set fd
[open
[concat
$cmd $ids] r
]
6735 fconfigure
$fd -blocking 0
6738 filerun
$fd [list getallclines
$fd]
6744 # Since most commits have 1 parent and 1 child, we group strings of
6745 # such commits into "arcs" joining branch/merge points (BMPs), which
6746 # are commits that either don't have 1 parent or don't have 1 child.
6748 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6749 # arcout(id) - outgoing arcs for BMP
6750 # arcids(a) - list of IDs on arc including end but not start
6751 # arcstart(a) - BMP ID at start of arc
6752 # arcend(a) - BMP ID at end of arc
6753 # growing(a) - arc a is still growing
6754 # arctags(a) - IDs out of arcids (excluding end) that have tags
6755 # archeads(a) - IDs out of arcids (excluding end) that have heads
6756 # The start of an arc is at the descendent end, so "incoming" means
6757 # coming from descendents, and "outgoing" means going towards ancestors.
6759 proc getallclines
{fd
} {
6760 global allparents allchildren idtags idheads nextarc
6761 global arcnos arcids arctags arcout arcend arcstart archeads growing
6762 global seeds allcommits cachedarcs allcupdate
6765 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
6766 set id
[lindex
$line 0]
6767 if {[info exists allparents
($id)]} {
6772 set olds
[lrange
$line 1 end
]
6773 set allparents
($id) $olds
6774 if {![info exists allchildren
($id)]} {
6775 set allchildren
($id) {}
6780 if {[llength
$olds] == 1 && [llength
$a] == 1} {
6781 lappend arcids
($a) $id
6782 if {[info exists idtags
($id)]} {
6783 lappend arctags
($a) $id
6785 if {[info exists idheads
($id)]} {
6786 lappend archeads
($a) $id
6788 if {[info exists allparents
($olds)]} {
6789 # seen parent already
6790 if {![info exists arcout
($olds)]} {
6793 lappend arcids
($a) $olds
6794 set arcend
($a) $olds
6797 lappend allchildren
($olds) $id
6798 lappend arcnos
($olds) $a
6802 foreach a
$arcnos($id) {
6803 lappend arcids
($a) $id
6810 lappend allchildren
($p) $id
6811 set a
[incr nextarc
]
6812 set arcstart
($a) $id
6819 if {[info exists allparents
($p)]} {
6820 # seen it already, may need to make a new branch
6821 if {![info exists arcout
($p)]} {
6824 lappend arcids
($a) $p
6828 lappend arcnos
($p) $a
6833 global cached_dheads cached_dtags cached_atags
6834 catch
{unset cached_dheads
}
6835 catch
{unset cached_dtags
}
6836 catch
{unset cached_atags
}
6839 return [expr {$nid >= 1000?
2: 1}]
6843 fconfigure
$fd -blocking 1
6846 # got an error reading the list of commits
6847 # if we were updating, try rereading the whole thing again
6853 error_popup
"[mc "Error reading commit topology information
;\
6854 branch and preceding
/following tag information\
6855 will be incomplete.
"]\n($err)"
6858 if {[incr allcommits
-1] == 0} {
6868 proc recalcarc
{a
} {
6869 global arctags archeads arcids idtags idheads
6873 foreach id
[lrange
$arcids($a) 0 end-1
] {
6874 if {[info exists idtags
($id)]} {
6877 if {[info exists idheads
($id)]} {
6882 set archeads
($a) $ah
6886 global arcnos arcids nextarc arctags archeads idtags idheads
6887 global arcstart arcend arcout allparents growing
6890 if {[llength
$a] != 1} {
6891 puts
"oops splitarc called but [llength $a] arcs already"
6895 set i
[lsearch
-exact $arcids($a) $p]
6897 puts
"oops splitarc $p not in arc $a"
6900 set na
[incr nextarc
]
6901 if {[info exists arcend
($a)]} {
6902 set arcend
($na) $arcend($a)
6904 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
6905 set j
[lsearch
-exact $arcnos($l) $a]
6906 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
6908 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
6909 set arcids
($a) [lrange
$arcids($a) 0 $i]
6911 set arcstart
($na) $p
6913 set arcids
($na) $tail
6914 if {[info exists growing
($a)]} {
6920 if {[llength
$arcnos($id)] == 1} {
6923 set j
[lsearch
-exact $arcnos($id) $a]
6924 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
6928 # reconstruct tags and heads lists
6929 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
6934 set archeads
($na) {}
6938 # Update things for a new commit added that is a child of one
6939 # existing commit. Used when cherry-picking.
6940 proc addnewchild
{id p
} {
6941 global allparents allchildren idtags nextarc
6942 global arcnos arcids arctags arcout arcend arcstart archeads growing
6943 global seeds allcommits
6945 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
6946 set allparents
($id) [list
$p]
6947 set allchildren
($id) {}
6950 lappend allchildren
($p) $id
6951 set a
[incr nextarc
]
6952 set arcstart
($a) $id
6955 set arcids
($a) [list
$p]
6957 if {![info exists arcout
($p)]} {
6960 lappend arcnos
($p) $a
6961 set arcout
($id) [list
$a]
6964 # This implements a cache for the topology information.
6965 # The cache saves, for each arc, the start and end of the arc,
6966 # the ids on the arc, and the outgoing arcs from the end.
6967 proc readcache
{f
} {
6968 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6969 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6974 if {$lim - $a > 500} {
6975 set lim
[expr {$a + 500}]
6979 # finish reading the cache and setting up arctags, etc.
6981 if {$line ne
"1"} {error
"bad final version"}
6983 foreach id
[array names idtags
] {
6984 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6985 [llength
$allparents($id)] == 1} {
6986 set a
[lindex
$arcnos($id) 0]
6987 if {$arctags($a) eq
{}} {
6992 foreach id
[array names idheads
] {
6993 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6994 [llength
$allparents($id)] == 1} {
6995 set a
[lindex
$arcnos($id) 0]
6996 if {$archeads($a) eq
{}} {
7001 foreach id
[lsort
-unique $possible_seeds] {
7002 if {$arcnos($id) eq
{}} {
7008 while {[incr a
] <= $lim} {
7010 if {[llength
$line] != 3} {error
"bad line"}
7011 set s
[lindex
$line 0]
7013 lappend arcout
($s) $a
7014 if {![info exists arcnos
($s)]} {
7015 lappend possible_seeds
$s
7018 set e
[lindex
$line 1]
7023 if {![info exists arcout
($e)]} {
7027 set arcids
($a) [lindex
$line 2]
7028 foreach id
$arcids($a) {
7029 lappend allparents
($s) $id
7031 lappend arcnos
($id) $a
7033 if {![info exists allparents
($s)]} {
7034 set allparents
($s) {}
7039 set nextarc
[expr {$a - 1}]
7052 global nextarc cachedarcs possible_seeds
7056 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7057 # make sure it's an integer
7058 set cachedarcs
[expr {int
([lindex
$line 1])}]
7059 if {$cachedarcs < 0} {error
"bad number of arcs"}
7061 set possible_seeds
{}
7069 proc dropcache
{err
} {
7070 global allcwait nextarc cachedarcs seeds
7072 #puts "dropping cache ($err)"
7073 foreach v
{arcnos arcout arcids arcstart arcend growing \
7074 arctags archeads allparents allchildren
} {
7085 proc writecache
{f
} {
7086 global cachearc cachedarcs allccache
7087 global arcstart arcend arcnos arcids arcout
7091 if {$lim - $a > 1000} {
7092 set lim
[expr {$a + 1000}]
7095 while {[incr a
] <= $lim} {
7096 if {[info exists arcend
($a)]} {
7097 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7099 puts
$f [list
$arcstart($a) {} $arcids($a)]
7104 catch
{file delete
$allccache}
7105 #puts "writing cache failed ($err)"
7108 set cachearc
[expr {$a - 1}]
7109 if {$a > $cachedarcs} {
7118 global nextarc cachedarcs cachearc allccache
7120 if {$nextarc == $cachedarcs} return
7122 set cachedarcs
$nextarc
7124 set f
[open
$allccache w
]
7125 puts
$f [list
1 $cachedarcs]
7130 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7131 # or 0 if neither is true.
7132 proc anc_or_desc
{a b
} {
7133 global arcout arcstart arcend arcnos cached_isanc
7135 if {$arcnos($a) eq
$arcnos($b)} {
7136 # Both are on the same arc(s); either both are the same BMP,
7137 # or if one is not a BMP, the other is also not a BMP or is
7138 # the BMP at end of the arc (and it only has 1 incoming arc).
7139 # Or both can be BMPs with no incoming arcs.
7140 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7143 # assert {[llength $arcnos($a)] == 1}
7144 set arc
[lindex
$arcnos($a) 0]
7145 set i
[lsearch
-exact $arcids($arc) $a]
7146 set j
[lsearch
-exact $arcids($arc) $b]
7147 if {$i < 0 ||
$i > $j} {
7154 if {![info exists arcout
($a)]} {
7155 set arc
[lindex
$arcnos($a) 0]
7156 if {[info exists arcend
($arc)]} {
7157 set aend
$arcend($arc)
7161 set a
$arcstart($arc)
7165 if {![info exists arcout
($b)]} {
7166 set arc
[lindex
$arcnos($b) 0]
7167 if {[info exists arcend
($arc)]} {
7168 set bend
$arcend($arc)
7172 set b
$arcstart($arc)
7182 if {[info exists cached_isanc
($a,$bend)]} {
7183 if {$cached_isanc($a,$bend)} {
7187 if {[info exists cached_isanc
($b,$aend)]} {
7188 if {$cached_isanc($b,$aend)} {
7191 if {[info exists cached_isanc
($a,$bend)]} {
7196 set todo
[list
$a $b]
7199 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7200 set x
[lindex
$todo $i]
7201 if {$anc($x) eq
{}} {
7204 foreach arc
$arcnos($x) {
7205 set xd
$arcstart($arc)
7207 set cached_isanc
($a,$bend) 1
7208 set cached_isanc
($b,$aend) 0
7210 } elseif
{$xd eq
$aend} {
7211 set cached_isanc
($b,$aend) 1
7212 set cached_isanc
($a,$bend) 0
7215 if {![info exists anc
($xd)]} {
7216 set anc
($xd) $anc($x)
7218 } elseif
{$anc($xd) ne
$anc($x)} {
7223 set cached_isanc
($a,$bend) 0
7224 set cached_isanc
($b,$aend) 0
7228 # This identifies whether $desc has an ancestor that is
7229 # a growing tip of the graph and which is not an ancestor of $anc
7230 # and returns 0 if so and 1 if not.
7231 # If we subsequently discover a tag on such a growing tip, and that
7232 # turns out to be a descendent of $anc (which it could, since we
7233 # don't necessarily see children before parents), then $desc
7234 # isn't a good choice to display as a descendent tag of
7235 # $anc (since it is the descendent of another tag which is
7236 # a descendent of $anc). Similarly, $anc isn't a good choice to
7237 # display as a ancestor tag of $desc.
7239 proc is_certain
{desc anc
} {
7240 global arcnos arcout arcstart arcend growing problems
7243 if {[llength
$arcnos($anc)] == 1} {
7244 # tags on the same arc are certain
7245 if {$arcnos($desc) eq
$arcnos($anc)} {
7248 if {![info exists arcout
($anc)]} {
7249 # if $anc is partway along an arc, use the start of the arc instead
7250 set a
[lindex
$arcnos($anc) 0]
7251 set anc
$arcstart($a)
7254 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7257 set a
[lindex
$arcnos($desc) 0]
7263 set anclist
[list
$x]
7267 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7268 set x
[lindex
$anclist $i]
7273 foreach a
$arcout($x) {
7274 if {[info exists growing
($a)]} {
7275 if {![info exists growanc
($x)] && $dl($x)} {
7281 if {[info exists dl
($y)]} {
7285 if {![info exists
done($y)]} {
7288 if {[info exists growanc
($x)]} {
7292 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7293 set z
[lindex
$xl $k]
7294 foreach c
$arcout($z) {
7295 if {[info exists arcend
($c)]} {
7297 if {[info exists dl
($v)] && $dl($v)} {
7299 if {![info exists
done($v)]} {
7302 if {[info exists growanc
($v)]} {
7312 } elseif
{$y eq
$anc ||
!$dl($x)} {
7323 foreach x
[array names growanc
] {
7332 proc validate_arctags
{a
} {
7333 global arctags idtags
7337 foreach id
$arctags($a) {
7339 if {![info exists idtags
($id)]} {
7340 set na
[lreplace
$na $i $i]
7347 proc validate_archeads
{a
} {
7348 global archeads idheads
7351 set na
$archeads($a)
7352 foreach id
$archeads($a) {
7354 if {![info exists idheads
($id)]} {
7355 set na
[lreplace
$na $i $i]
7359 set archeads
($a) $na
7362 # Return the list of IDs that have tags that are descendents of id,
7363 # ignoring IDs that are descendents of IDs already reported.
7364 proc desctags
{id
} {
7365 global arcnos arcstart arcids arctags idtags allparents
7366 global growing cached_dtags
7368 if {![info exists allparents
($id)]} {
7371 set t1
[clock clicks
-milliseconds]
7373 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7374 # part-way along an arc; check that arc first
7375 set a
[lindex
$arcnos($id) 0]
7376 if {$arctags($a) ne
{}} {
7378 set i
[lsearch
-exact $arcids($a) $id]
7380 foreach t
$arctags($a) {
7381 set j
[lsearch
-exact $arcids($a) $t]
7389 set id
$arcstart($a)
7390 if {[info exists idtags
($id)]} {
7394 if {[info exists cached_dtags
($id)]} {
7395 return $cached_dtags($id)
7402 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7403 set id
[lindex
$todo $i]
7405 set ta
[info exists hastaggedancestor
($id)]
7409 # ignore tags on starting node
7410 if {!$ta && $i > 0} {
7411 if {[info exists idtags
($id)]} {
7414 } elseif
{[info exists cached_dtags
($id)]} {
7415 set tagloc
($id) $cached_dtags($id)
7419 foreach a
$arcnos($id) {
7421 if {!$ta && $arctags($a) ne
{}} {
7423 if {$arctags($a) ne
{}} {
7424 lappend tagloc
($id) [lindex
$arctags($a) end
]
7427 if {$ta ||
$arctags($a) ne
{}} {
7428 set tomark
[list
$d]
7429 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7430 set dd [lindex
$tomark $j]
7431 if {![info exists hastaggedancestor
($dd)]} {
7432 if {[info exists
done($dd)]} {
7433 foreach b
$arcnos($dd) {
7434 lappend tomark
$arcstart($b)
7436 if {[info exists tagloc
($dd)]} {
7439 } elseif
{[info exists queued
($dd)]} {
7442 set hastaggedancestor
($dd) 1
7446 if {![info exists queued
($d)]} {
7449 if {![info exists hastaggedancestor
($d)]} {
7456 foreach id
[array names tagloc
] {
7457 if {![info exists hastaggedancestor
($id)]} {
7458 foreach t
$tagloc($id) {
7459 if {[lsearch
-exact $tags $t] < 0} {
7465 set t2
[clock clicks
-milliseconds]
7468 # remove tags that are descendents of other tags
7469 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7470 set a
[lindex
$tags $i]
7471 for {set j
0} {$j < $i} {incr j
} {
7472 set b
[lindex
$tags $j]
7473 set r
[anc_or_desc
$a $b]
7475 set tags
[lreplace
$tags $j $j]
7478 } elseif
{$r == -1} {
7479 set tags
[lreplace
$tags $i $i]
7486 if {[array names growing
] ne
{}} {
7487 # graph isn't finished, need to check if any tag could get
7488 # eclipsed by another tag coming later. Simply ignore any
7489 # tags that could later get eclipsed.
7492 if {[is_certain
$t $origid]} {
7496 if {$tags eq
$ctags} {
7497 set cached_dtags
($origid) $tags
7502 set cached_dtags
($origid) $tags
7504 set t3
[clock clicks
-milliseconds]
7505 if {0 && $t3 - $t1 >= 100} {
7506 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
7507 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7513 global arcnos arcids arcout arcend arctags idtags allparents
7514 global growing cached_atags
7516 if {![info exists allparents
($id)]} {
7519 set t1
[clock clicks
-milliseconds]
7521 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7522 # part-way along an arc; check that arc first
7523 set a
[lindex
$arcnos($id) 0]
7524 if {$arctags($a) ne
{}} {
7526 set i
[lsearch
-exact $arcids($a) $id]
7527 foreach t
$arctags($a) {
7528 set j
[lsearch
-exact $arcids($a) $t]
7534 if {![info exists arcend
($a)]} {
7538 if {[info exists idtags
($id)]} {
7542 if {[info exists cached_atags
($id)]} {
7543 return $cached_atags($id)
7551 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7552 set id
[lindex
$todo $i]
7554 set td
[info exists hastaggeddescendent
($id)]
7558 # ignore tags on starting node
7559 if {!$td && $i > 0} {
7560 if {[info exists idtags
($id)]} {
7563 } elseif
{[info exists cached_atags
($id)]} {
7564 set tagloc
($id) $cached_atags($id)
7568 foreach a
$arcout($id) {
7569 if {!$td && $arctags($a) ne
{}} {
7571 if {$arctags($a) ne
{}} {
7572 lappend tagloc
($id) [lindex
$arctags($a) 0]
7575 if {![info exists arcend
($a)]} continue
7577 if {$td ||
$arctags($a) ne
{}} {
7578 set tomark
[list
$d]
7579 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7580 set dd [lindex
$tomark $j]
7581 if {![info exists hastaggeddescendent
($dd)]} {
7582 if {[info exists
done($dd)]} {
7583 foreach b
$arcout($dd) {
7584 if {[info exists arcend
($b)]} {
7585 lappend tomark
$arcend($b)
7588 if {[info exists tagloc
($dd)]} {
7591 } elseif
{[info exists queued
($dd)]} {
7594 set hastaggeddescendent
($dd) 1
7598 if {![info exists queued
($d)]} {
7601 if {![info exists hastaggeddescendent
($d)]} {
7607 set t2
[clock clicks
-milliseconds]
7610 foreach id
[array names tagloc
] {
7611 if {![info exists hastaggeddescendent
($id)]} {
7612 foreach t
$tagloc($id) {
7613 if {[lsearch
-exact $tags $t] < 0} {
7620 # remove tags that are ancestors of other tags
7621 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7622 set a
[lindex
$tags $i]
7623 for {set j
0} {$j < $i} {incr j
} {
7624 set b
[lindex
$tags $j]
7625 set r
[anc_or_desc
$a $b]
7627 set tags
[lreplace
$tags $j $j]
7630 } elseif
{$r == 1} {
7631 set tags
[lreplace
$tags $i $i]
7638 if {[array names growing
] ne
{}} {
7639 # graph isn't finished, need to check if any tag could get
7640 # eclipsed by another tag coming later. Simply ignore any
7641 # tags that could later get eclipsed.
7644 if {[is_certain
$origid $t]} {
7648 if {$tags eq
$ctags} {
7649 set cached_atags
($origid) $tags
7654 set cached_atags
($origid) $tags
7656 set t3
[clock clicks
-milliseconds]
7657 if {0 && $t3 - $t1 >= 100} {
7658 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
7659 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7664 # Return the list of IDs that have heads that are descendents of id,
7665 # including id itself if it has a head.
7666 proc descheads
{id
} {
7667 global arcnos arcstart arcids archeads idheads cached_dheads
7670 if {![info exists allparents
($id)]} {
7674 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7675 # part-way along an arc; check it first
7676 set a
[lindex
$arcnos($id) 0]
7677 if {$archeads($a) ne
{}} {
7678 validate_archeads
$a
7679 set i
[lsearch
-exact $arcids($a) $id]
7680 foreach t
$archeads($a) {
7681 set j
[lsearch
-exact $arcids($a) $t]
7686 set id
$arcstart($a)
7692 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7693 set id
[lindex
$todo $i]
7694 if {[info exists cached_dheads
($id)]} {
7695 set ret
[concat
$ret $cached_dheads($id)]
7697 if {[info exists idheads
($id)]} {
7700 foreach a
$arcnos($id) {
7701 if {$archeads($a) ne
{}} {
7702 validate_archeads
$a
7703 if {$archeads($a) ne
{}} {
7704 set ret
[concat
$ret $archeads($a)]
7708 if {![info exists seen
($d)]} {
7715 set ret
[lsort
-unique $ret]
7716 set cached_dheads
($origid) $ret
7717 return [concat
$ret $aret]
7720 proc addedtag
{id
} {
7721 global arcnos arcout cached_dtags cached_atags
7723 if {![info exists arcnos
($id)]} return
7724 if {![info exists arcout
($id)]} {
7725 recalcarc
[lindex
$arcnos($id) 0]
7727 catch
{unset cached_dtags
}
7728 catch
{unset cached_atags
}
7731 proc addedhead
{hid
head} {
7732 global arcnos arcout cached_dheads
7734 if {![info exists arcnos
($hid)]} return
7735 if {![info exists arcout
($hid)]} {
7736 recalcarc
[lindex
$arcnos($hid) 0]
7738 catch
{unset cached_dheads
}
7741 proc removedhead
{hid
head} {
7742 global cached_dheads
7744 catch
{unset cached_dheads
}
7747 proc movedhead
{hid
head} {
7748 global arcnos arcout cached_dheads
7750 if {![info exists arcnos
($hid)]} return
7751 if {![info exists arcout
($hid)]} {
7752 recalcarc
[lindex
$arcnos($hid) 0]
7754 catch
{unset cached_dheads
}
7757 proc changedrefs
{} {
7758 global cached_dheads cached_dtags cached_atags
7759 global arctags archeads arcnos arcout idheads idtags
7761 foreach id
[concat
[array names idheads
] [array names idtags
]] {
7762 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
7763 set a
[lindex
$arcnos($id) 0]
7764 if {![info exists donearc
($a)]} {
7770 catch
{unset cached_dtags
}
7771 catch
{unset cached_atags
}
7772 catch
{unset cached_dheads
}
7775 proc rereadrefs
{} {
7776 global idtags idheads idotherrefs mainhead
7778 set refids
[concat
[array names idtags
] \
7779 [array names idheads
] [array names idotherrefs
]]
7780 foreach id
$refids {
7781 if {![info exists ref
($id)]} {
7782 set ref
($id) [listrefs
$id]
7785 set oldmainhead
$mainhead
7788 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
7789 [array names idheads
] [array names idotherrefs
]]]
7790 foreach id
$refids {
7791 set v
[listrefs
$id]
7792 if {![info exists ref
($id)] ||
$ref($id) != $v ||
7793 ($id eq
$oldmainhead && $id ne
$mainhead) ||
7794 ($id eq
$mainhead && $id ne
$oldmainhead)} {
7801 proc listrefs
{id
} {
7802 global idtags idheads idotherrefs
7805 if {[info exists idtags
($id)]} {
7809 if {[info exists idheads
($id)]} {
7813 if {[info exists idotherrefs
($id)]} {
7814 set z
$idotherrefs($id)
7816 return [list
$x $y $z]
7819 proc showtag
{tag isnew
} {
7820 global ctext tagcontents tagids linknum tagobjid
7823 addtohistory
[list showtag
$tag 0]
7825 $ctext conf
-state normal
7829 if {![info exists tagcontents
($tag)]} {
7831 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
7834 if {[info exists tagcontents
($tag)]} {
7835 set text
$tagcontents($tag)
7837 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
7839 appendwithlinks
$text {}
7840 $ctext conf
-state disabled
7851 proc mkfontdisp
{font top
which} {
7852 global fontattr fontpref
$font
7854 set fontpref
($font) [set $font]
7855 button
$top.
${font}but
-text $which -font optionfont \
7856 -command [list choosefont
$font $which]
7857 label
$top.
$font -relief flat
-font $font \
7858 -text $fontattr($font,family
) -justify left
7859 grid x
$top.
${font}but
$top.
$font -sticky w
7862 proc choosefont
{font
which} {
7863 global fontparam fontlist fonttop fontattr
7865 set fontparam
(which) $which
7866 set fontparam
(font
) $font
7867 set fontparam
(family
) [font actual
$font -family]
7868 set fontparam
(size
) $fontattr($font,size
)
7869 set fontparam
(weight
) $fontattr($font,weight
)
7870 set fontparam
(slant
) $fontattr($font,slant
)
7873 if {![winfo exists
$top]} {
7875 eval font config sample
[font actual
$font]
7877 wm title
$top [mc
"Gitk font chooser"]
7878 label
$top.l
-textvariable fontparam
(which)
7879 pack
$top.l
-side top
7880 set fontlist
[lsort
[font families
]]
7882 listbox
$top.f.fam
-listvariable fontlist \
7883 -yscrollcommand [list
$top.f.sb
set]
7884 bind $top.f.fam
<<ListboxSelect>> selfontfam
7885 scrollbar $top.f.sb -command [list $top.f.fam yview]
7886 pack $top.f.sb -side right -fill y
7887 pack $top.f.fam -side left -fill both -expand 1
7888 pack $top.f -side top -fill both -expand 1
7890 spinbox $top.g.size -from 4 -to 40 -width 4 \
7891 -textvariable fontparam(size) \
7892 -validatecommand {string is integer -strict %s}
7893 checkbutton $top.g.bold -padx 5 \
7894 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7895 -variable fontparam(weight) -onvalue bold -offvalue normal
7896 checkbutton $top.g.ital -padx 5 \
7897 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7898 -variable fontparam(slant) -onvalue italic -offvalue roman
7899 pack $top.g.size $top.g.bold $top.g.ital -side left
7900 pack $top.g -side top
7901 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7903 $top.c create text 100 25 -anchor center -text $which -font sample \
7904 -fill black -tags text
7905 bind $top.c <Configure> [list centertext $top.c]
7906 pack $top.c -side top -fill x
7908 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7909 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7910 grid $top.buts.ok $top.buts.can
7911 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7912 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7913 pack $top.buts -side bottom -fill x
7914 trace add variable fontparam write chg_fontparam
7917 $top.c itemconf text -text $which
7919 set i [lsearch -exact $fontlist $fontparam(family)]
7921 $top.f.fam selection set $i
7926 proc centertext {w} {
7927 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7931 global fontparam fontpref prefstop
7933 set f $fontparam(font)
7934 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7935 if {$fontparam(weight) eq "bold"} {
7936 lappend fontpref($f) "bold"
7938 if {$fontparam(slant) eq "italic"} {
7939 lappend fontpref($f) "italic"
7942 $w conf -text $fontparam(family) -font $fontpref($f)
7948 global fonttop fontparam
7950 if {[info exists fonttop]} {
7951 catch {destroy $fonttop}
7952 catch {font delete sample}
7958 proc selfontfam {} {
7959 global fonttop fontparam
7961 set i [$fonttop.f.fam curselection]
7963 set fontparam(family) [$fonttop.f.fam get $i]
7967 proc chg_fontparam {v sub op} {
7970 font config sample -$sub $fontparam($sub)
7974 global maxwidth maxgraphpct
7975 global oldprefs prefstop showneartags showlocalchanges
7976 global bgcolor fgcolor ctext diffcolors selectbgcolor
7977 global tabstop limitdiffs
7981 if {[winfo exists $top]} {
7985 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7986 limitdiffs tabstop} {
7987 set oldprefs($v) [set $v]
7990 wm title $top [mc "Gitk preferences"]
7991 label $top.ldisp -text [mc "Commit list display options"]
7992 grid $top.ldisp - -sticky w -pady 10
7993 label $top.spacer -text " "
7994 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
7996 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7997 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7998 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8000 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8001 grid x $top.maxpctl $top.maxpct -sticky w
8002 frame $top.showlocal
8003 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8004 checkbutton $top.showlocal.b -variable showlocalchanges
8005 pack $top.showlocal.b $top.showlocal.l -side left
8006 grid x $top.showlocal -sticky w
8008 label $top.ddisp -text [mc "Diff display options"]
8009 grid $top.ddisp - -sticky w -pady 10
8010 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8011 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8012 grid x $top.tabstopl $top.tabstop -sticky w
8014 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8015 checkbutton $top.ntag.b -variable showneartags
8016 pack $top.ntag.b $top.ntag.l -side left
8017 grid x $top.ntag -sticky w
8019 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8020 checkbutton $top.ldiff.b -variable limitdiffs
8021 pack $top.ldiff.b $top.ldiff.l -side left
8022 grid x $top.ldiff -sticky w
8024 label $top.cdisp -text [mc "Colors: press to choose"]
8025 grid $top.cdisp - -sticky w -pady 10
8026 label $top.bg -padx 40 -relief sunk -background $bgcolor
8027 button $top.bgbut -text [mc "Background"] -font optionfont \
8028 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8029 grid x $top.bgbut $top.bg -sticky w
8030 label $top.fg -padx 40 -relief sunk -background $fgcolor
8031 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8032 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8033 grid x $top.fgbut $top.fg -sticky w
8034 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8035 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8036 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8037 [list $ctext tag conf d0 -foreground]]
8038 grid x $top.diffoldbut $top.diffold -sticky w
8039 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8040 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8041 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8042 [list $ctext tag conf d1 -foreground]]
8043 grid x $top.diffnewbut $top.diffnew -sticky w
8044 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8045 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8046 -command [list choosecolor diffcolors 2 $top.hunksep \
8047 "diff hunk header" \
8048 [list $ctext tag conf hunksep -foreground]]
8049 grid x $top.hunksepbut $top.hunksep -sticky w
8050 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8051 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8052 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8053 grid x $top.selbgbut $top.selbgsep -sticky w
8055 label $top.cfont -text [mc "Fonts: press to choose"]
8056 grid $top.cfont - -sticky w -pady 10
8057 mkfontdisp mainfont $top [mc "Main font"]
8058 mkfontdisp textfont $top [mc "Diff display font"]
8059 mkfontdisp uifont $top [mc "User interface font"]
8062 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8063 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8064 grid $top.buts.ok $top.buts.can
8065 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8066 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8067 grid $top.buts - - -pady 10 -sticky ew
8068 bind $top <Visibility> "focus $top.buts.ok"
8071 proc choosecolor {v vi w x cmd} {
8074 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8075 -title [mc "Gitk: choose color for %s" $x]]
8076 if {$c eq {}} return
8077 $w conf -background $c
8083 global bglist cflist
8085 $w configure -selectbackground $c
8087 $cflist tag configure highlight \
8088 -background [$cflist cget -selectbackground]
8089 allcanvs itemconf secsel -fill $c
8096 $w conf -background $c
8104 $w conf -foreground $c
8106 allcanvs itemconf text -fill $c
8107 $canv itemconf circle -outline $c
8111 global oldprefs prefstop
8113 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8114 limitdiffs tabstop} {
8116 set $v $oldprefs($v)
8118 catch {destroy $prefstop}
8124 global maxwidth maxgraphpct
8125 global oldprefs prefstop showneartags showlocalchanges
8126 global fontpref mainfont textfont uifont
8127 global limitdiffs treediffs
8129 catch {destroy $prefstop}
8133 if {$mainfont ne $fontpref(mainfont)} {
8134 set mainfont $fontpref(mainfont)
8135 parsefont mainfont $mainfont
8136 eval font configure mainfont [fontflags mainfont]
8137 eval font configure mainfontbold [fontflags mainfont 1]
8141 if {$textfont ne $fontpref(textfont)} {
8142 set textfont $fontpref(textfont)
8143 parsefont textfont $textfont
8144 eval font configure textfont [fontflags textfont]
8145 eval font configure textfontbold [fontflags textfont 1]
8147 if {$uifont ne $fontpref(uifont)} {
8148 set uifont $fontpref(uifont)
8149 parsefont uifont $uifont
8150 eval font configure uifont [fontflags uifont]
8153 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8154 if {$showlocalchanges} {
8160 if {$limitdiffs != $oldprefs(limitdiffs)} {
8161 # treediffs elements are limited by path
8162 catch {unset treediffs}
8164 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8165 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8167 } elseif {$showneartags != $oldprefs(showneartags) ||
8168 $limitdiffs != $oldprefs(limitdiffs)} {
8173 proc formatdate {d} {
8174 global datetimeformat
8176 set d [clock format $d -format $datetimeformat]
8181 # This list of encoding names and aliases is distilled from
8182 # http://www.iana.org/assignments/character-sets.
8183 # Not all of them are supported by Tcl.
8184 set encoding_aliases {
8185 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8186 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8187 { ISO-10646-UTF-1 csISO10646UTF1 }
8188 { ISO_646.basic:1983 ref csISO646basic1983 }
8189 { INVARIANT csINVARIANT }
8190 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8191 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8192 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8193 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8194 { NATS-DANO iso-ir-9-1 csNATSDANO }
8195 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8196 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8197 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8198 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8199 { ISO-2022-KR csISO2022KR }
8201 { ISO-2022-JP csISO2022JP }
8202 { ISO-2022-JP-2 csISO2022JP2 }
8203 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8205 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8206 { IT iso-ir-15 ISO646-IT csISO15Italian }
8207 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8208 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8209 { greek7-old iso-ir-18 csISO18Greek7Old }
8210 { latin-greek iso-ir-19 csISO19LatinGreek }
8211 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8212 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8213 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8214 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8215 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8216 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8217 { INIS iso-ir-49 csISO49INIS }
8218 { INIS-8 iso-ir-50 csISO50INIS8 }
8219 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8220 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8221 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8222 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8223 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8224 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8226 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8227 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8228 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8229 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8230 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8231 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8232 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8233 { greek7 iso-ir-88 csISO88Greek7 }
8234 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8235 { iso-ir-90 csISO90 }
8236 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8237 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8238 csISO92JISC62991984b }
8239 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8240 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8241 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8242 csISO95JIS62291984handadd }
8243 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8244 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8245 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8246 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8248 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8249 { T.61-7bit iso-ir-102 csISO102T617bit }
8250 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8251 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8252 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8253 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8254 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8255 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8256 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8257 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8258 arabic csISOLatinArabic }
8259 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8260 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8261 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8262 greek greek8 csISOLatinGreek }
8263 { T.101-G2 iso-ir-128 csISO128T101G2 }
8264 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8266 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8267 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8268 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8269 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8270 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8271 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8272 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8273 csISOLatinCyrillic }
8274 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8275 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8276 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8277 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8278 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8279 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8280 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8281 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8282 { ISO_10367-box iso-ir-155 csISO10367Box }
8283 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8284 { latin-lap lap iso-ir-158 csISO158Lap }
8285 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8286 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8289 { JIS_X0201 X0201 csHalfWidthKatakana }
8290 { KSC5636 ISO646-KR csKSC5636 }
8291 { ISO-10646-UCS-2 csUnicode }
8292 { ISO-10646-UCS-4 csUCS4 }
8293 { DEC-MCS dec csDECMCS }
8294 { hp-roman8 roman8 r8 csHPRoman8 }
8295 { macintosh mac csMacintosh }
8296 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8298 { IBM038 EBCDIC-INT cp038 csIBM038 }
8299 { IBM273 CP273 csIBM273 }
8300 { IBM274 EBCDIC-BE CP274 csIBM274 }
8301 { IBM275 EBCDIC-BR cp275 csIBM275 }
8302 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8303 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8304 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8305 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8306 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8307 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8308 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8309 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8310 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8311 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8312 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8313 { IBM437 cp437 437 csPC8CodePage437 }
8314 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8315 { IBM775 cp775 csPC775Baltic }
8316 { IBM850 cp850 850 csPC850Multilingual }
8317 { IBM851 cp851 851 csIBM851 }
8318 { IBM852 cp852 852 csPCp852 }
8319 { IBM855 cp855 855 csIBM855 }
8320 { IBM857 cp857 857 csIBM857 }
8321 { IBM860 cp860 860 csIBM860 }
8322 { IBM861 cp861 861 cp-is csIBM861 }
8323 { IBM862 cp862 862 csPC862LatinHebrew }
8324 { IBM863 cp863 863 csIBM863 }
8325 { IBM864 cp864 csIBM864 }
8326 { IBM865 cp865 865 csIBM865 }
8327 { IBM866 cp866 866 csIBM866 }
8328 { IBM868 CP868 cp-ar csIBM868 }
8329 { IBM869 cp869 869 cp-gr csIBM869 }
8330 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8331 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8332 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8333 { IBM891 cp891 csIBM891 }
8334 { IBM903 cp903 csIBM903 }
8335 { IBM904 cp904 904 csIBBM904 }
8336 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8337 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8338 { IBM1026 CP1026 csIBM1026 }
8339 { EBCDIC-AT-DE csIBMEBCDICATDE }
8340 { EBCDIC-AT-DE-A csEBCDICATDEA }
8341 { EBCDIC-CA-FR csEBCDICCAFR }
8342 { EBCDIC-DK-NO csEBCDICDKNO }
8343 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8344 { EBCDIC-FI-SE csEBCDICFISE }
8345 { EBCDIC-FI-SE-A csEBCDICFISEA }
8346 { EBCDIC-FR csEBCDICFR }
8347 { EBCDIC-IT csEBCDICIT }
8348 { EBCDIC-PT csEBCDICPT }
8349 { EBCDIC-ES csEBCDICES }
8350 { EBCDIC-ES-A csEBCDICESA }
8351 { EBCDIC-ES-S csEBCDICESS }
8352 { EBCDIC-UK csEBCDICUK }
8353 { EBCDIC-US csEBCDICUS }
8354 { UNKNOWN-8BIT csUnknown8BiT }
8355 { MNEMONIC csMnemonic }
8360 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8361 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8362 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8363 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8364 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8365 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8366 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8367 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8368 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8369 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8370 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8371 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8372 { IBM1047 IBM-1047 }
8373 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8374 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8375 { UNICODE-1-1 csUnicode11 }
8378 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8379 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8381 { ISO-8859-15 ISO_8859-15 Latin-9 }
8382 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8383 { GBK CP936 MS936 windows-936 }
8384 { JIS_Encoding csJISEncoding }
8385 { Shift_JIS MS_Kanji csShiftJIS }
8386 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8388 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8389 { ISO-10646-UCS-Basic csUnicodeASCII }
8390 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8391 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8392 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8393 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8394 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8395 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8396 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8397 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8398 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8399 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8400 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8401 { Ventura-US csVenturaUS }
8402 { Ventura-International csVenturaInternational }
8403 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8404 { PC8-Turkish csPC8Turkish }
8405 { IBM-Symbols csIBMSymbols }
8406 { IBM-Thai csIBMThai }
8407 { HP-Legal csHPLegal }
8408 { HP-Pi-font csHPPiFont }
8409 { HP-Math8 csHPMath8 }
8410 { Adobe-Symbol-Encoding csHPPSMath }
8411 { HP-DeskTop csHPDesktop }
8412 { Ventura-Math csVenturaMath }
8413 { Microsoft-Publishing csMicrosoftPublishing }
8414 { Windows-31J csWindows31J }
8419 proc tcl_encoding {enc} {
8420 global encoding_aliases
8421 set names [encoding names]
8422 set lcnames [string tolower $names]
8423 set enc [string tolower $enc]
8424 set i [lsearch -exact $lcnames $enc]
8426 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8427 if {[regsub {^iso[-_]} $enc iso encx]} {
8428 set i [lsearch -exact $lcnames $encx]
8432 foreach l $encoding_aliases {
8433 set ll [string tolower $l]
8434 if {[lsearch -exact $ll $enc] < 0} continue
8435 # look through the aliases for one that tcl knows about
8437 set i [lsearch -exact $lcnames $e]
8439 if {[regsub {^iso[-_]} $e iso ex]} {
8440 set i [lsearch -exact $lcnames $ex]
8449 return [lindex $names $i]
8454 # First check that Tcl/Tk is recent enough
8455 if {[catch {package require Tk 8.4} err]} {
8456 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8457 Gitk requires at least Tcl/Tk 8.4."]
8463 set wrcomcmd "git diff-tree --stdin -p --pretty"
8467 set gitencoding [exec git config --get i18n.commitencoding]
8469 if {$gitencoding == ""} {
8470 set gitencoding "utf-8"
8472 set tclencoding [tcl_encoding $gitencoding]
8473 if {$tclencoding == {}} {
8474 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8477 set mainfont {Helvetica 9}
8478 set textfont {Courier 9}
8479 set uifont {Helvetica 9 bold}
8481 set findmergefiles 0
8489 set cmitmode "patch"
8490 set wrapcomment "none"
8494 set showlocalchanges 1
8496 set datetimeformat "%Y-%m-%d %H:%M:%S"
8498 set colors {green red blue magenta darkgrey brown orange}
8501 set diffcolors {red "#00a000" blue}
8504 set selectbgcolor gray85
8506 ## For msgcat loading, first locate the installation location.
8507 if { [info exists ::env(GITK_MSGSDIR)] } {
8508 ## Msgsdir was manually set in the environment.
8509 set gitk_msgsdir $::env(GITK_MSGSDIR)
8511 ## Let's guess the prefix from argv0.
8512 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8513 set gitk_libdir [file join $gitk_prefix share gitk lib]
8514 set gitk_msgsdir [file join $gitk_libdir msgs]
8518 ## Internationalization (i18n) through msgcat and gettext. See
8519 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8520 package require msgcat
8521 namespace import ::msgcat::mc
8522 ## And eventually load the actual message catalog
8523 ::msgcat::mcload $gitk_msgsdir
8525 catch {source ~/.gitk}
8527 font create optionfont -family sans-serif -size -12
8529 parsefont mainfont $mainfont
8530 eval font create mainfont [fontflags mainfont]
8531 eval font create mainfontbold [fontflags mainfont 1]
8533 parsefont textfont $textfont
8534 eval font create textfont [fontflags textfont]
8535 eval font create textfontbold [fontflags textfont 1]
8537 parsefont uifont $uifont
8538 eval font create uifont [fontflags uifont]
8542 # check that we can find a .git directory somewhere...
8543 if {[catch {set gitdir [gitdir]}]} {
8544 show_error {} . [mc "Cannot find a git repository here."]
8547 if {![file isdirectory $gitdir]} {
8548 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8554 set cmdline_files {}
8556 set revtreeargscmd {}
8558 switch -glob -- $arg {
8560 "-d" { set datemode 1 }
8563 lappend revtreeargs $arg
8566 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8570 set revtreeargscmd [string range $arg 10 end]
8573 lappend revtreeargs $arg
8579 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8580 # no -- on command line, but some arguments (other than -d)
8582 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8583 set cmdline_files [split $f "\n"]
8584 set n [llength $cmdline_files]
8585 set revtreeargs [lrange $revtreeargs 0 end-$n]
8586 # Unfortunately git rev-parse doesn't produce an error when
8587 # something is both a revision and a filename. To be consistent
8588 # with git log and git rev-list, check revtreeargs for filenames.
8589 foreach arg $revtreeargs {
8590 if {[file exists $arg]} {
8591 show_error {} . [mc "Ambiguous argument '%s': both revision\
8597 # unfortunately we get both stdout and stderr in $err,
8598 # so look for "fatal:".
8599 set i [string first "fatal:" $err]
8601 set err [string range $err [expr {$i + 6}] end]
8603 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8609 # find the list of unmerged files
8613 set fd [open "| git ls-files -u" r]
8615 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8618 while {[gets $fd line] >= 0} {
8619 set i [string first "\t" $line]
8620 if {$i < 0} continue
8621 set fname [string range $line [expr {$i+1}] end]
8622 if {[lsearch -exact $mlist $fname] >= 0} continue
8624 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8625 lappend mlist $fname
8630 if {$nr_unmerged == 0} {
8631 show_error {} . [mc "No files selected: --merge specified but\
8632 no files are unmerged."]
8634 show_error {} . [mc "No files selected: --merge specified but\
8635 no unmerged files are within file limit."]
8639 set cmdline_files $mlist
8642 set nullid "0000000000000000000000000000000000000000"
8643 set nullid2 "0000000000000000000000000000000000000001"
8645 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8652 set highlight_paths {}
8654 set searchdirn -forwards
8658 set markingmatches 0
8659 set linkentercount 0
8660 set need_redisplay 0
8667 set selectedhlview [mc "None"]
8668 set highlight_related [mc "None"]
8669 set highlight_files {}
8673 set viewargscmd(0) {}
8684 # wait for the window to become visible
8686 wm title . "[file tail $argv0]: [file tail [pwd]]"
8689 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8690 # create a view for the files/dirs specified on the command line
8694 set viewname(1) [mc "Command line"]
8695 set viewfiles(1) $cmdline_files
8696 set viewargs(1) $revtreeargs
8697 set viewargscmd(1) $revtreeargscmd
8700 .bar.view entryconf [mc "Edit view..."] -state normal
8701 .bar.view entryconf [mc "Delete view"] -state normal
8704 if {[info exists permviews]} {
8705 foreach v $permviews {
8708 set viewname($n) [lindex $v 0]
8709 set viewfiles($n) [lindex $v 1]
8710 set viewargs($n) [lindex $v 2]
8711 set viewargscmd($n) [lindex $v 3]