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
1186 if {$stuffsaved} return
1187 if {![winfo viewable .
]} return
1189 set f
[open
"~/.gitk-new" w
]
1190 puts
$f [list
set mainfont
$mainfont]
1191 puts
$f [list
set textfont
$textfont]
1192 puts
$f [list
set uifont
$uifont]
1193 puts
$f [list
set tabstop
$tabstop]
1194 puts
$f [list
set findmergefiles
$findmergefiles]
1195 puts
$f [list
set maxgraphpct
$maxgraphpct]
1196 puts
$f [list
set maxwidth
$maxwidth]
1197 puts
$f [list
set cmitmode
$cmitmode]
1198 puts
$f [list
set wrapcomment
$wrapcomment]
1199 puts
$f [list
set autoselect
$autoselect]
1200 puts
$f [list
set showneartags
$showneartags]
1201 puts
$f [list
set showlocalchanges
$showlocalchanges]
1202 puts
$f [list
set datetimeformat
$datetimeformat]
1203 puts
$f [list
set limitdiffs
$limitdiffs]
1204 puts
$f [list
set bgcolor
$bgcolor]
1205 puts
$f [list
set fgcolor
$fgcolor]
1206 puts
$f [list
set colors
$colors]
1207 puts
$f [list
set diffcolors
$diffcolors]
1208 puts
$f [list
set diffcontext
$diffcontext]
1209 puts
$f [list
set selectbgcolor
$selectbgcolor]
1211 puts
$f "set geometry(main) [wm geometry .]"
1212 puts
$f "set geometry(topwidth) [winfo width .tf]"
1213 puts
$f "set geometry(topheight) [winfo height .tf]"
1214 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1215 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1216 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1217 puts
$f "set geometry(botheight) [winfo height .bleft]"
1219 puts
-nonewline $f "set permviews {"
1220 for {set v
0} {$v < $nextviewnum} {incr v
} {
1221 if {$viewperm($v)} {
1222 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v) $viewargscmd($v)]}"
1227 file rename
-force "~/.gitk-new" "~/.gitk"
1232 proc resizeclistpanes
{win w
} {
1234 if {[info exists oldwidth
($win)]} {
1235 set s0
[$win sash coord
0]
1236 set s1
[$win sash coord
1]
1238 set sash0
[expr {int
($w/2 - 2)}]
1239 set sash1
[expr {int
($w*5/6 - 2)}]
1241 set factor [expr {1.0 * $w / $oldwidth($win)}]
1242 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1243 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1247 if {$sash1 < $sash0 + 20} {
1248 set sash1
[expr {$sash0 + 20}]
1250 if {$sash1 > $w - 10} {
1251 set sash1
[expr {$w - 10}]
1252 if {$sash0 > $sash1 - 20} {
1253 set sash0
[expr {$sash1 - 20}]
1257 $win sash place
0 $sash0 [lindex
$s0 1]
1258 $win sash place
1 $sash1 [lindex
$s1 1]
1260 set oldwidth
($win) $w
1263 proc resizecdetpanes
{win w
} {
1265 if {[info exists oldwidth
($win)]} {
1266 set s0
[$win sash coord
0]
1268 set sash0
[expr {int
($w*3/4 - 2)}]
1270 set factor [expr {1.0 * $w / $oldwidth($win)}]
1271 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1275 if {$sash0 > $w - 15} {
1276 set sash0
[expr {$w - 15}]
1279 $win sash place
0 $sash0 [lindex
$s0 1]
1281 set oldwidth
($win) $w
1284 proc allcanvs args
{
1285 global canv canv2 canv3
1291 proc bindall
{event action
} {
1292 global canv canv2 canv3
1293 bind $canv $event $action
1294 bind $canv2 $event $action
1295 bind $canv3 $event $action
1301 if {[winfo exists
$w]} {
1306 wm title
$w [mc
"About gitk"]
1307 message
$w.m
-text [mc
"
1308 Gitk - a commit viewer for git
1310 Copyright © 2005-2006 Paul Mackerras
1312 Use and redistribute under the terms of the GNU General Public License"] \
1313 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1314 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1315 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1316 pack
$w.ok
-side bottom
1317 bind $w <Visibility
> "focus $w.ok"
1318 bind $w <Key-Escape
> "destroy $w"
1319 bind $w <Key-Return
> "destroy $w"
1324 if {[winfo exists
$w]} {
1328 if {[tk windowingsystem
] eq
{aqua
}} {
1334 wm title
$w [mc
"Gitk key bindings"]
1335 message
$w.m
-text "
1336 [mc "Gitk key bindings
:"]
1338 [mc "<%s-Q
> Quit
" $M1T]
1339 [mc "<Home
> Move to first commit
"]
1340 [mc "<End
> Move to last commit
"]
1341 [mc "<Up
>, p
, i Move up one commit
"]
1342 [mc "<Down
>, n
, k Move down one commit
"]
1343 [mc "<Left
>, z
, j Go back
in history list
"]
1344 [mc "<Right
>, x
, l Go forward
in history list
"]
1345 [mc "<PageUp
> Move up one page
in commit list
"]
1346 [mc "<PageDown
> Move down one page
in commit list
"]
1347 [mc "<%s-Home
> Scroll to top of commit list
" $M1T]
1348 [mc "<%s-End
> Scroll to bottom of commit list
" $M1T]
1349 [mc "<%s-Up
> Scroll commit list up one line
" $M1T]
1350 [mc "<%s-Down
> Scroll commit list down one line
" $M1T]
1351 [mc "<%s-PageUp
> Scroll commit list up one page
" $M1T]
1352 [mc "<%s-PageDown
> Scroll commit list down one page
" $M1T]
1353 [mc "<Shift-Up
> Find backwards
(upwards
, later commits
)"]
1354 [mc "<Shift-Down
> Find forwards
(downwards
, earlier commits
)"]
1355 [mc "<Delete
>, b Scroll
diff view up one page
"]
1356 [mc "<Backspace
> Scroll
diff view up one page
"]
1357 [mc "<Space
> Scroll
diff view down one page
"]
1358 [mc "u Scroll
diff view up
18 lines
"]
1359 [mc "d Scroll
diff view down
18 lines
"]
1360 [mc "<%s-F
> Find
" $M1T]
1361 [mc "<%s-G
> Move to next
find hit
" $M1T]
1362 [mc "<Return
> Move to next
find hit
"]
1363 [mc "/ Move to next
find hit
, or redo
find"]
1364 [mc "? Move to previous
find hit
"]
1365 [mc "f Scroll
diff view to next
file"]
1366 [mc "<%s-S
> Search
for next hit
in diff view
" $M1T]
1367 [mc "<%s-R
> Search
for previous hit
in diff view
" $M1T]
1368 [mc "<%s-KP
+> Increase font size
" $M1T]
1369 [mc "<%s-plus
> Increase font size
" $M1T]
1370 [mc "<%s-KP-
> Decrease font size
" $M1T]
1371 [mc "<%s-minus
> Decrease font size
" $M1T]
1374 -justify left
-bg white
-border 2 -relief groove
1375 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
1376 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1377 pack
$w.ok
-side bottom
1378 bind $w <Visibility
> "focus $w.ok"
1379 bind $w <Key-Escape
> "destroy $w"
1380 bind $w <Key-Return
> "destroy $w"
1383 # Procedures for manipulating the file list window at the
1384 # bottom right of the overall window.
1386 proc treeview
{w l openlevs
} {
1387 global treecontents treediropen treeheight treeparent treeindex
1397 set treecontents
() {}
1398 $w conf
-state normal
1400 while {[string range
$f 0 $prefixend] ne
$prefix} {
1401 if {$lev <= $openlevs} {
1402 $w mark
set e
:$treeindex($prefix) "end -1c"
1403 $w mark gravity e
:$treeindex($prefix) left
1405 set treeheight
($prefix) $ht
1406 incr ht
[lindex
$htstack end
]
1407 set htstack
[lreplace
$htstack end end
]
1408 set prefixend
[lindex
$prefendstack end
]
1409 set prefendstack
[lreplace
$prefendstack end end
]
1410 set prefix
[string range
$prefix 0 $prefixend]
1413 set tail [string range
$f [expr {$prefixend+1}] end
]
1414 while {[set slash
[string first
"/" $tail]] >= 0} {
1417 lappend prefendstack
$prefixend
1418 incr prefixend
[expr {$slash + 1}]
1419 set d
[string range
$tail 0 $slash]
1420 lappend treecontents
($prefix) $d
1421 set oldprefix
$prefix
1423 set treecontents
($prefix) {}
1424 set treeindex
($prefix) [incr ix
]
1425 set treeparent
($prefix) $oldprefix
1426 set tail [string range
$tail [expr {$slash+1}] end
]
1427 if {$lev <= $openlevs} {
1429 set treediropen
($prefix) [expr {$lev < $openlevs}]
1430 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
1431 $w mark
set d
:$ix "end -1c"
1432 $w mark gravity d
:$ix left
1434 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1436 $w image create end
-align center
-image $bm -padx 1 \
1438 $w insert end
$d [highlight_tag
$prefix]
1439 $w mark
set s
:$ix "end -1c"
1440 $w mark gravity s
:$ix left
1445 if {$lev <= $openlevs} {
1448 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1450 $w insert end
$tail [highlight_tag
$f]
1452 lappend treecontents
($prefix) $tail
1455 while {$htstack ne
{}} {
1456 set treeheight
($prefix) $ht
1457 incr ht
[lindex
$htstack end
]
1458 set htstack
[lreplace
$htstack end end
]
1459 set prefixend
[lindex
$prefendstack end
]
1460 set prefendstack
[lreplace
$prefendstack end end
]
1461 set prefix
[string range
$prefix 0 $prefixend]
1463 $w conf
-state disabled
1466 proc linetoelt
{l
} {
1467 global treeheight treecontents
1472 foreach e
$treecontents($prefix) {
1477 if {[string index
$e end
] eq
"/"} {
1478 set n
$treeheight($prefix$e)
1490 proc highlight_tree
{y prefix
} {
1491 global treeheight treecontents cflist
1493 foreach e
$treecontents($prefix) {
1495 if {[highlight_tag
$path] ne
{}} {
1496 $cflist tag add bold
$y.0 "$y.0 lineend"
1499 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
1500 set y
[highlight_tree
$y $path]
1506 proc treeclosedir
{w dir
} {
1507 global treediropen treeheight treeparent treeindex
1509 set ix
$treeindex($dir)
1510 $w conf
-state normal
1511 $w delete s
:$ix e
:$ix
1512 set treediropen
($dir) 0
1513 $w image configure a
:$ix -image tri-rt
1514 $w conf
-state disabled
1515 set n
[expr {1 - $treeheight($dir)}]
1516 while {$dir ne
{}} {
1517 incr treeheight
($dir) $n
1518 set dir
$treeparent($dir)
1522 proc treeopendir
{w dir
} {
1523 global treediropen treeheight treeparent treecontents treeindex
1525 set ix
$treeindex($dir)
1526 $w conf
-state normal
1527 $w image configure a
:$ix -image tri-dn
1528 $w mark
set e
:$ix s
:$ix
1529 $w mark gravity e
:$ix right
1532 set n
[llength
$treecontents($dir)]
1533 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
1536 incr treeheight
($x) $n
1538 foreach e
$treecontents($dir) {
1540 if {[string index
$e end
] eq
"/"} {
1541 set iy
$treeindex($de)
1542 $w mark
set d
:$iy e
:$ix
1543 $w mark gravity d
:$iy left
1544 $w insert e
:$ix $str
1545 set treediropen
($de) 0
1546 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
1548 $w insert e
:$ix $e [highlight_tag
$de]
1549 $w mark
set s
:$iy e
:$ix
1550 $w mark gravity s
:$iy left
1551 set treeheight
($de) 1
1553 $w insert e
:$ix $str
1554 $w insert e
:$ix $e [highlight_tag
$de]
1557 $w mark gravity e
:$ix left
1558 $w conf
-state disabled
1559 set treediropen
($dir) 1
1560 set top
[lindex
[split [$w index @
0,0] .
] 0]
1561 set ht
[$w cget
-height]
1562 set l
[lindex
[split [$w index s
:$ix] .
] 0]
1565 } elseif
{$l + $n + 1 > $top + $ht} {
1566 set top
[expr {$l + $n + 2 - $ht}]
1574 proc treeclick
{w x y
} {
1575 global treediropen cmitmode ctext cflist cflist_top
1577 if {$cmitmode ne
"tree"} return
1578 if {![info exists cflist_top
]} return
1579 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1580 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1581 $cflist tag add highlight
$l.0 "$l.0 lineend"
1587 set e
[linetoelt
$l]
1588 if {[string index
$e end
] ne
"/"} {
1590 } elseif
{$treediropen($e)} {
1597 proc setfilelist
{id
} {
1598 global treefilelist cflist
1600 treeview
$cflist $treefilelist($id) 0
1603 image create bitmap tri-rt
-background black
-foreground blue
-data {
1604 #define tri-rt_width 13
1605 #define tri-rt_height 13
1606 static unsigned char tri-rt_bits
[] = {
1607 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1608 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1611 #define tri-rt-mask_width 13
1612 #define tri-rt-mask_height 13
1613 static unsigned char tri-rt-mask_bits
[] = {
1614 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1615 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1618 image create bitmap tri-dn
-background black
-foreground blue
-data {
1619 #define tri-dn_width 13
1620 #define tri-dn_height 13
1621 static unsigned char tri-dn_bits
[] = {
1622 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1623 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1626 #define tri-dn-mask_width 13
1627 #define tri-dn-mask_height 13
1628 static unsigned char tri-dn-mask_bits
[] = {
1629 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1630 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1634 image create bitmap reficon-T
-background black
-foreground yellow
-data {
1635 #define tagicon_width 13
1636 #define tagicon_height 9
1637 static unsigned char tagicon_bits
[] = {
1638 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1639 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1641 #define tagicon-mask_width 13
1642 #define tagicon-mask_height 9
1643 static unsigned char tagicon-mask_bits
[] = {
1644 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1645 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1648 #define headicon_width 13
1649 #define headicon_height 9
1650 static unsigned char headicon_bits
[] = {
1651 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1652 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1655 #define headicon-mask_width 13
1656 #define headicon-mask_height 9
1657 static unsigned char headicon-mask_bits
[] = {
1658 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1659 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1661 image create bitmap reficon-H
-background black
-foreground green \
1662 -data $rectdata -maskdata $rectmask
1663 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
1664 -data $rectdata -maskdata $rectmask
1666 proc init_flist
{first
} {
1667 global cflist cflist_top selectedline difffilestart
1669 $cflist conf
-state normal
1670 $cflist delete
0.0 end
1672 $cflist insert end
$first
1674 $cflist tag add highlight
1.0 "1.0 lineend"
1676 catch
{unset cflist_top
}
1678 $cflist conf
-state disabled
1679 set difffilestart
{}
1682 proc highlight_tag
{f
} {
1683 global highlight_paths
1685 foreach p
$highlight_paths {
1686 if {[string match
$p $f]} {
1693 proc highlight_filelist
{} {
1694 global cmitmode cflist
1696 $cflist conf
-state normal
1697 if {$cmitmode ne
"tree"} {
1698 set end
[lindex
[split [$cflist index end
] .
] 0]
1699 for {set l
2} {$l < $end} {incr l
} {
1700 set line
[$cflist get
$l.0 "$l.0 lineend"]
1701 if {[highlight_tag
$line] ne
{}} {
1702 $cflist tag add bold
$l.0 "$l.0 lineend"
1708 $cflist conf
-state disabled
1711 proc unhighlight_filelist
{} {
1714 $cflist conf
-state normal
1715 $cflist tag remove bold
1.0 end
1716 $cflist conf
-state disabled
1719 proc add_flist
{fl
} {
1722 $cflist conf
-state normal
1724 $cflist insert end
"\n"
1725 $cflist insert end
$f [highlight_tag
$f]
1727 $cflist conf
-state disabled
1730 proc sel_flist
{w x y
} {
1731 global ctext difffilestart cflist cflist_top cmitmode
1733 if {$cmitmode eq
"tree"} return
1734 if {![info exists cflist_top
]} return
1735 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1736 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1737 $cflist tag add highlight
$l.0 "$l.0 lineend"
1742 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
1746 proc pop_flist_menu
{w X Y x y
} {
1747 global ctext cflist cmitmode flist_menu flist_menu_file
1748 global treediffs diffids
1751 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1753 if {$cmitmode eq
"tree"} {
1754 set e
[linetoelt
$l]
1755 if {[string index
$e end
] eq
"/"} return
1757 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
1759 set flist_menu_file
$e
1760 tk_popup
$flist_menu $X $Y
1763 proc flist_hl
{only
} {
1764 global flist_menu_file findstring gdttype
1766 set x
[shellquote
$flist_menu_file]
1767 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
1770 append findstring
" " $x
1772 set gdttype
[mc
"touching paths:"]
1775 # Functions for adding and removing shell-type quoting
1777 proc shellquote
{str
} {
1778 if {![string match
"*\['\"\\ \t]*" $str]} {
1781 if {![string match
"*\['\"\\]*" $str]} {
1784 if {![string match
"*'*" $str]} {
1787 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1790 proc shellarglist
{l
} {
1796 append str
[shellquote
$a]
1801 proc shelldequote
{str
} {
1806 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
1807 append ret
[string range
$str $used end
]
1808 set used
[string length
$str]
1811 set first
[lindex
$first 0]
1812 set ch
[string index
$str $first]
1813 if {$first > $used} {
1814 append ret
[string range
$str $used [expr {$first - 1}]]
1817 if {$ch eq
" " ||
$ch eq
"\t"} break
1820 set first
[string first
"'" $str $used]
1822 error
"unmatched single-quote"
1824 append ret
[string range
$str $used [expr {$first - 1}]]
1829 if {$used >= [string length
$str]} {
1830 error
"trailing backslash"
1832 append ret
[string index
$str $used]
1837 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
1838 error
"unmatched double-quote"
1840 set first
[lindex
$first 0]
1841 set ch
[string index
$str $first]
1842 if {$first > $used} {
1843 append ret
[string range
$str $used [expr {$first - 1}]]
1846 if {$ch eq
"\""} break
1848 append ret
[string index
$str $used]
1852 return [list
$used $ret]
1855 proc shellsplit
{str
} {
1858 set str
[string trimleft
$str]
1859 if {$str eq
{}} break
1860 set dq
[shelldequote
$str]
1861 set n
[lindex
$dq 0]
1862 set word
[lindex
$dq 1]
1863 set str
[string range
$str $n end
]
1869 # Code to implement multiple views
1871 proc newview
{ishighlight
} {
1872 global nextviewnum newviewname newviewperm newishighlight
1873 global newviewargs revtreeargs viewargscmd newviewargscmd curview
1875 set newishighlight
$ishighlight
1877 if {[winfo exists
$top]} {
1881 set newviewname
($nextviewnum) "[mc "View
"] $nextviewnum"
1882 set newviewperm
($nextviewnum) 0
1883 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
1884 set newviewargscmd
($nextviewnum) $viewargscmd($curview)
1885 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
1890 global viewname viewperm newviewname newviewperm
1891 global viewargs newviewargs viewargscmd newviewargscmd
1893 set top .gitkvedit-
$curview
1894 if {[winfo exists
$top]} {
1898 set newviewname
($curview) $viewname($curview)
1899 set newviewperm
($curview) $viewperm($curview)
1900 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
1901 set newviewargscmd
($curview) $viewargscmd($curview)
1902 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
1905 proc vieweditor
{top n title
} {
1906 global newviewname newviewperm viewfiles bgcolor
1909 wm title
$top $title
1910 label
$top.
nl -text [mc
"Name"]
1911 entry
$top.name
-width 20 -textvariable newviewname
($n)
1912 grid
$top.
nl $top.name
-sticky w
-pady 5
1913 checkbutton
$top.perm
-text [mc
"Remember this view"] \
1914 -variable newviewperm
($n)
1915 grid
$top.perm
- -pady 5 -sticky w
1916 message
$top.al
-aspect 1000 \
1917 -text [mc
"Commits to include (arguments to git rev-list):"]
1918 grid
$top.al
- -sticky w
-pady 5
1919 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
1920 -background $bgcolor
1921 grid
$top.args
- -sticky ew
-padx 5
1923 message
$top.ac
-aspect 1000 \
1924 -text [mc
"Command to generate more commits to include:"]
1925 grid
$top.ac
- -sticky w
-pady 5
1926 entry
$top.argscmd
-width 50 -textvariable newviewargscmd
($n) \
1928 grid
$top.argscmd
- -sticky ew
-padx 5
1930 message
$top.l
-aspect 1000 \
1931 -text [mc
"Enter files and directories to include, one per line:"]
1932 grid
$top.l
- -sticky w
1933 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
1934 if {[info exists viewfiles
($n)]} {
1935 foreach f
$viewfiles($n) {
1936 $top.t insert end
$f
1937 $top.t insert end
"\n"
1939 $top.t delete
{end
- 1c
} end
1940 $top.t mark
set insert
0.0
1942 grid
$top.t
- -sticky ew
-padx 5
1944 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
1945 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
1946 grid
$top.buts.ok
$top.buts.can
1947 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
1948 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
1949 grid
$top.buts
- -pady 10 -sticky ew
1953 proc doviewmenu
{m first cmd op argv
} {
1954 set nmenu
[$m index end
]
1955 for {set i
$first} {$i <= $nmenu} {incr i
} {
1956 if {[$m entrycget
$i -command] eq
$cmd} {
1957 eval $m $op $i $argv
1963 proc allviewmenus
{n op args
} {
1966 doviewmenu .bar.view
5 [list showview
$n] $op $args
1967 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1970 proc newviewok
{top n
} {
1971 global nextviewnum newviewperm newviewname newishighlight
1972 global viewname viewfiles viewperm selectedview curview
1973 global viewargs newviewargs viewargscmd newviewargscmd viewhlmenu
1976 set newargs
[shellsplit
$newviewargs($n)]
1978 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
1984 foreach f
[split [$top.t get
0.0 end
] "\n"] {
1985 set ft
[string trim
$f]
1990 if {![info exists viewfiles
($n)]} {
1991 # creating a new view
1993 set viewname
($n) $newviewname($n)
1994 set viewperm
($n) $newviewperm($n)
1995 set viewfiles
($n) $files
1996 set viewargs
($n) $newargs
1997 set viewargscmd
($n) $newviewargscmd($n)
1999 if {!$newishighlight} {
2002 run addvhighlight
$n
2005 # editing an existing view
2006 set viewperm
($n) $newviewperm($n)
2007 if {$newviewname($n) ne
$viewname($n)} {
2008 set viewname
($n) $newviewname($n)
2009 doviewmenu .bar.view
5 [list showview
$n] \
2010 entryconf
[list
-label $viewname($n)]
2011 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
2012 # entryconf [list -label $viewname($n) -value $viewname($n)]
2014 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n) || \
2015 $newviewargscmd($n) ne
$viewargscmd($n)} {
2016 set viewfiles
($n) $files
2017 set viewargs
($n) $newargs
2018 set viewargscmd
($n) $newviewargscmd($n)
2019 if {$curview == $n} {
2024 catch
{destroy
$top}
2028 global curview viewdata viewperm hlview selectedhlview
2030 if {$curview == 0} return
2031 if {[info exists hlview
] && $hlview == $curview} {
2032 set selectedhlview
[mc
"None"]
2035 allviewmenus
$curview delete
2036 set viewdata
($curview) {}
2037 set viewperm
($curview) 0
2041 proc addviewmenu
{n
} {
2042 global viewname viewhlmenu
2044 .bar.view add radiobutton
-label $viewname($n) \
2045 -command [list showview
$n] -variable selectedview
-value $n
2046 #$viewhlmenu add radiobutton -label $viewname($n) \
2047 # -command [list addvhighlight $n] -variable selectedhlview
2050 proc flatten
{var
} {
2054 foreach i
[array names
$var] {
2055 lappend ret
$i [set $var\
($i\
)]
2060 proc unflatten
{var l
} {
2070 global curview viewdata viewfiles
2071 global displayorder parentlist rowidlist rowisopt rowfinal
2072 global colormap rowtextx commitrow nextcolor canvxmax
2073 global numcommits commitlisted
2074 global selectedline currentid canv canvy0
2076 global pending_select phase
2079 global selectedview selectfirst
2080 global vparentlist vdisporder vcmitlisted
2081 global hlview selectedhlview commitinterest
2083 if {$n == $curview} return
2085 if {[info exists selectedline
]} {
2086 set selid
$currentid
2087 set y
[yc
$selectedline]
2088 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2089 set span
[$canv yview
]
2090 set ytop
[expr {[lindex
$span 0] * $ymax}]
2091 set ybot
[expr {[lindex
$span 1] * $ymax}]
2092 if {$ytop < $y && $y < $ybot} {
2093 set yscreen
[expr {$y - $ytop}]
2095 set yscreen
[expr {($ybot - $ytop) / 2}]
2097 } elseif
{[info exists pending_select
]} {
2098 set selid
$pending_select
2099 unset pending_select
2103 if {$curview >= 0} {
2104 set vparentlist
($curview) $parentlist
2105 set vdisporder
($curview) $displayorder
2106 set vcmitlisted
($curview) $commitlisted
2108 ![info exists viewdata
($curview)] ||
2109 [lindex
$viewdata($curview) 0] ne
{}} {
2110 set viewdata
($curview) \
2111 [list
$phase $rowidlist $rowisopt $rowfinal]
2114 catch
{unset treediffs
}
2116 if {[info exists hlview
] && $hlview == $n} {
2118 set selectedhlview
[mc
"None"]
2120 catch
{unset commitinterest
}
2124 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2125 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2128 if {![info exists viewdata
($n)]} {
2130 set pending_select
$selid
2137 set phase
[lindex
$v 0]
2138 set displayorder
$vdisporder($n)
2139 set parentlist
$vparentlist($n)
2140 set commitlisted
$vcmitlisted($n)
2141 set rowidlist
[lindex
$v 1]
2142 set rowisopt
[lindex
$v 2]
2143 set rowfinal
[lindex
$v 3]
2144 set numcommits
$commitidx($n)
2146 catch
{unset colormap
}
2147 catch
{unset rowtextx
}
2149 set canvxmax
[$canv cget
-width]
2156 if {$selid ne
{} && [info exists commitrow
($n,$selid)]} {
2157 set row
$commitrow($n,$selid)
2158 # try to get the selected row in the same position on the screen
2159 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2160 set ytop
[expr {[yc
$row] - $yscreen}]
2164 set yf
[expr {$ytop * 1.0 / $ymax}]
2166 allcanvs yview moveto
$yf
2170 } elseif
{$selid ne
{}} {
2171 set pending_select
$selid
2173 set row
[first_real_row
]
2174 if {$row < $numcommits} {
2181 if {$phase eq
"getcommits"} {
2182 show_status
[mc
"Reading commits..."]
2185 } elseif
{$numcommits == 0} {
2186 show_status
[mc
"No commits selected"]
2190 # Stuff relating to the highlighting facility
2192 proc ishighlighted
{row
} {
2193 global vhighlights fhighlights nhighlights rhighlights
2195 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2196 return $nhighlights($row)
2198 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2199 return $vhighlights($row)
2201 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2202 return $fhighlights($row)
2204 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2205 return $rhighlights($row)
2210 proc bolden
{row font
} {
2211 global canv linehtag selectedline boldrows
2213 lappend boldrows
$row
2214 $canv itemconf
$linehtag($row) -font $font
2215 if {[info exists selectedline
] && $row == $selectedline} {
2217 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2218 -outline {{}} -tags secsel \
2219 -fill [$canv cget
-selectbackground]]
2224 proc bolden_name
{row font
} {
2225 global canv2 linentag selectedline boldnamerows
2227 lappend boldnamerows
$row
2228 $canv2 itemconf
$linentag($row) -font $font
2229 if {[info exists selectedline
] && $row == $selectedline} {
2230 $canv2 delete secsel
2231 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2232 -outline {{}} -tags secsel \
2233 -fill [$canv2 cget
-selectbackground]]
2242 foreach row
$boldrows {
2243 if {![ishighlighted
$row]} {
2244 bolden
$row mainfont
2246 lappend stillbold
$row
2249 set boldrows
$stillbold
2252 proc addvhighlight
{n
} {
2253 global hlview curview viewdata vhl_done vhighlights commitidx
2255 if {[info exists hlview
]} {
2259 if {$n != $curview && ![info exists viewdata
($n)]} {
2260 set viewdata
($n) [list getcommits
{{}} 0 0 0]
2261 set vparentlist
($n) {}
2262 set vdisporder
($n) {}
2263 set vcmitlisted
($n) {}
2266 set vhl_done
$commitidx($hlview)
2267 if {$vhl_done > 0} {
2272 proc delvhighlight
{} {
2273 global hlview vhighlights
2275 if {![info exists hlview
]} return
2277 catch
{unset vhighlights
}
2281 proc vhighlightmore
{} {
2282 global hlview vhl_done commitidx vhighlights
2283 global displayorder vdisporder curview
2285 set max
$commitidx($hlview)
2286 if {$hlview == $curview} {
2287 set disp
$displayorder
2289 set disp
$vdisporder($hlview)
2291 set vr
[visiblerows
]
2292 set r0
[lindex
$vr 0]
2293 set r1
[lindex
$vr 1]
2294 for {set i
$vhl_done} {$i < $max} {incr i
} {
2295 set id
[lindex
$disp $i]
2296 if {[info exists commitrow
($curview,$id)]} {
2297 set row
$commitrow($curview,$id)
2298 if {$r0 <= $row && $row <= $r1} {
2299 if {![highlighted
$row]} {
2300 bolden
$row mainfontbold
2302 set vhighlights
($row) 1
2309 proc askvhighlight
{row id
} {
2310 global hlview vhighlights commitrow iddrawn
2312 if {[info exists commitrow
($hlview,$id)]} {
2313 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2314 bolden
$row mainfontbold
2316 set vhighlights
($row) 1
2318 set vhighlights
($row) 0
2322 proc hfiles_change
{} {
2323 global highlight_files filehighlight fhighlights fh_serial
2324 global highlight_paths gdttype
2326 if {[info exists filehighlight
]} {
2327 # delete previous highlights
2328 catch
{close
$filehighlight}
2330 catch
{unset fhighlights
}
2332 unhighlight_filelist
2334 set highlight_paths
{}
2335 after cancel do_file_hl
$fh_serial
2337 if {$highlight_files ne
{}} {
2338 after
300 do_file_hl
$fh_serial
2342 proc gdttype_change
{name ix op
} {
2343 global gdttype highlight_files findstring findpattern
2346 if {$findstring ne
{}} {
2347 if {$gdttype eq
[mc
"containing:"]} {
2348 if {$highlight_files ne
{}} {
2349 set highlight_files
{}
2354 if {$findpattern ne
{}} {
2358 set highlight_files
$findstring
2363 # enable/disable findtype/findloc menus too
2366 proc find_change
{name ix op
} {
2367 global gdttype findstring highlight_files
2370 if {$gdttype eq
[mc
"containing:"]} {
2373 if {$highlight_files ne
$findstring} {
2374 set highlight_files
$findstring
2381 proc findcom_change args
{
2382 global nhighlights boldnamerows
2383 global findpattern findtype findstring gdttype
2386 # delete previous highlights, if any
2387 foreach row
$boldnamerows {
2388 bolden_name
$row mainfont
2391 catch
{unset nhighlights
}
2394 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
2396 } elseif
{$findtype eq
[mc
"Regexp"]} {
2397 set findpattern
$findstring
2399 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2401 set findpattern
"*$e*"
2405 proc makepatterns
{l
} {
2408 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2409 if {[string index
$ee end
] eq
"/"} {
2419 proc do_file_hl
{serial
} {
2420 global highlight_files filehighlight highlight_paths gdttype fhl_list
2422 if {$gdttype eq
[mc
"touching paths:"]} {
2423 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
2424 set highlight_paths
[makepatterns
$paths]
2426 set gdtargs
[concat
-- $paths]
2427 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
2428 set gdtargs
[list
"-S$highlight_files"]
2430 # must be "containing:", i.e. we're searching commit info
2433 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
2434 set filehighlight
[open
$cmd r
+]
2435 fconfigure
$filehighlight -blocking 0
2436 filerun
$filehighlight readfhighlight
2442 proc flushhighlights
{} {
2443 global filehighlight fhl_list
2445 if {[info exists filehighlight
]} {
2447 puts
$filehighlight ""
2448 flush
$filehighlight
2452 proc askfilehighlight
{row id
} {
2453 global filehighlight fhighlights fhl_list
2455 lappend fhl_list
$id
2456 set fhighlights
($row) -1
2457 puts
$filehighlight $id
2460 proc readfhighlight
{} {
2461 global filehighlight fhighlights commitrow curview iddrawn
2462 global fhl_list find_dirn
2464 if {![info exists filehighlight
]} {
2468 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
2469 set line
[string trim
$line]
2470 set i
[lsearch
-exact $fhl_list $line]
2471 if {$i < 0} continue
2472 for {set j
0} {$j < $i} {incr j
} {
2473 set id
[lindex
$fhl_list $j]
2474 if {[info exists commitrow
($curview,$id)]} {
2475 set fhighlights
($commitrow($curview,$id)) 0
2478 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
2479 if {$line eq
{}} continue
2480 if {![info exists commitrow
($curview,$line)]} continue
2481 set row
$commitrow($curview,$line)
2482 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
2483 bolden
$row mainfontbold
2485 set fhighlights
($row) 1
2487 if {[eof
$filehighlight]} {
2489 puts
"oops, git diff-tree died"
2490 catch
{close
$filehighlight}
2494 if {[info exists find_dirn
]} {
2500 proc doesmatch
{f
} {
2501 global findtype findpattern
2503 if {$findtype eq
[mc
"Regexp"]} {
2504 return [regexp
$findpattern $f]
2505 } elseif
{$findtype eq
[mc
"IgnCase"]} {
2506 return [string match
-nocase $findpattern $f]
2508 return [string match
$findpattern $f]
2512 proc askfindhighlight
{row id
} {
2513 global nhighlights commitinfo iddrawn
2515 global markingmatches
2517 if {![info exists commitinfo
($id)]} {
2520 set info
$commitinfo($id)
2522 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
2523 foreach f
$info ty
$fldtypes {
2524 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
2526 if {$ty eq
[mc
"Author"]} {
2533 if {$isbold && [info exists iddrawn
($id)]} {
2534 if {![ishighlighted
$row]} {
2535 bolden
$row mainfontbold
2537 bolden_name
$row mainfontbold
2540 if {$markingmatches} {
2541 markrowmatches
$row $id
2544 set nhighlights
($row) $isbold
2547 proc markrowmatches
{row id
} {
2548 global canv canv2 linehtag linentag commitinfo findloc
2550 set headline
[lindex
$commitinfo($id) 0]
2551 set author
[lindex
$commitinfo($id) 1]
2552 $canv delete match
$row
2553 $canv2 delete match
$row
2554 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
2555 set m
[findmatches
$headline]
2557 markmatches
$canv $row $headline $linehtag($row) $m \
2558 [$canv itemcget
$linehtag($row) -font] $row
2561 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
2562 set m
[findmatches
$author]
2564 markmatches
$canv2 $row $author $linentag($row) $m \
2565 [$canv2 itemcget
$linentag($row) -font] $row
2570 proc vrel_change
{name ix op
} {
2571 global highlight_related
2574 if {$highlight_related ne
[mc
"None"]} {
2579 # prepare for testing whether commits are descendents or ancestors of a
2580 proc rhighlight_sel
{a
} {
2581 global descendent desc_todo ancestor anc_todo
2582 global highlight_related rhighlights
2584 catch
{unset descendent
}
2585 set desc_todo
[list
$a]
2586 catch
{unset ancestor
}
2587 set anc_todo
[list
$a]
2588 if {$highlight_related ne
[mc
"None"]} {
2594 proc rhighlight_none
{} {
2597 catch
{unset rhighlights
}
2601 proc is_descendent
{a
} {
2602 global curview children commitrow descendent desc_todo
2605 set la
$commitrow($v,$a)
2609 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2610 set do [lindex
$todo $i]
2611 if {$commitrow($v,$do) < $la} {
2612 lappend leftover
$do
2615 foreach nk
$children($v,$do) {
2616 if {![info exists descendent
($nk)]} {
2617 set descendent
($nk) 1
2625 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2629 set descendent
($a) 0
2630 set desc_todo
$leftover
2633 proc is_ancestor
{a
} {
2634 global curview parentlist commitrow ancestor anc_todo
2637 set la
$commitrow($v,$a)
2641 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2642 set do [lindex
$todo $i]
2643 if {![info exists commitrow
($v,$do)] ||
$commitrow($v,$do) > $la} {
2644 lappend leftover
$do
2647 foreach np
[lindex
$parentlist $commitrow($v,$do)] {
2648 if {![info exists ancestor
($np)]} {
2657 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2662 set anc_todo
$leftover
2665 proc askrelhighlight
{row id
} {
2666 global descendent highlight_related iddrawn rhighlights
2667 global selectedline ancestor
2669 if {![info exists selectedline
]} return
2671 if {$highlight_related eq
[mc
"Descendant"] ||
2672 $highlight_related eq
[mc
"Not descendant"]} {
2673 if {![info exists descendent
($id)]} {
2676 if {$descendent($id) == ($highlight_related eq
[mc
"Descendant"])} {
2679 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
2680 $highlight_related eq
[mc
"Not ancestor"]} {
2681 if {![info exists ancestor
($id)]} {
2684 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
2688 if {[info exists iddrawn
($id)]} {
2689 if {$isbold && ![ishighlighted
$row]} {
2690 bolden
$row mainfontbold
2693 set rhighlights
($row) $isbold
2696 # Graph layout functions
2698 proc shortids
{ids
} {
2701 if {[llength
$id] > 1} {
2702 lappend res
[shortids
$id]
2703 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
2704 lappend res
[string range
$id 0 7]
2715 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
2716 if {($n & $mask) != 0} {
2717 set ret
[concat
$ret $o]
2719 set o
[concat
$o $o]
2724 # Work out where id should go in idlist so that order-token
2725 # values increase from left to right
2726 proc idcol
{idlist id
{i
0}} {
2727 global ordertok curview
2729 set t
$ordertok($curview,$id)
2730 if {$i >= [llength
$idlist] ||
2731 $t < $ordertok($curview,[lindex
$idlist $i])} {
2732 if {$i > [llength
$idlist]} {
2733 set i
[llength
$idlist]
2735 while {[incr i
-1] >= 0 &&
2736 $t < $ordertok($curview,[lindex
$idlist $i])} {}
2739 if {$t > $ordertok($curview,[lindex
$idlist $i])} {
2740 while {[incr i
] < [llength
$idlist] &&
2741 $t >= $ordertok($curview,[lindex
$idlist $i])} {}
2747 proc initlayout
{} {
2748 global rowidlist rowisopt rowfinal displayorder commitlisted
2749 global numcommits canvxmax canv
2752 global colormap rowtextx
2763 set canvxmax
[$canv cget
-width]
2764 catch
{unset colormap
}
2765 catch
{unset rowtextx
}
2769 proc setcanvscroll
{} {
2770 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2772 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2773 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
2774 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
2775 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
2778 proc visiblerows
{} {
2779 global canv numcommits linespc
2781 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2782 if {$ymax eq
{} ||
$ymax == 0} return
2784 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
2785 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
2789 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
2790 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
2791 if {$r1 >= $numcommits} {
2792 set r1
[expr {$numcommits - 1}]
2794 return [list
$r0 $r1]
2797 proc layoutmore
{} {
2798 global commitidx viewcomplete numcommits
2799 global uparrowlen downarrowlen mingaplen curview
2801 set show
$commitidx($curview)
2802 if {$show > $numcommits ||
$viewcomplete($curview)} {
2803 showstuff
$show $viewcomplete($curview)
2807 proc showstuff
{canshow last
} {
2808 global numcommits commitrow pending_select selectedline curview
2809 global mainheadid displayorder selectfirst
2810 global lastscrollset commitinterest
2812 if {$numcommits == 0} {
2814 set phase
"incrdraw"
2818 set prev
$numcommits
2819 set numcommits
$canshow
2820 set t
[clock clicks
-milliseconds]
2821 if {$prev < 100 ||
$last ||
$t - $lastscrollset > 500} {
2822 set lastscrollset
$t
2825 set rows
[visiblerows
]
2826 set r1
[lindex
$rows 1]
2827 if {$r1 >= $canshow} {
2828 set r1
[expr {$canshow - 1}]
2833 if {[info exists pending_select
] &&
2834 [info exists commitrow
($curview,$pending_select)] &&
2835 $commitrow($curview,$pending_select) < $numcommits} {
2836 selectline
$commitrow($curview,$pending_select) 1
2839 if {[info exists selectedline
] ||
[info exists pending_select
]} {
2842 set l
[first_real_row
]
2849 proc doshowlocalchanges
{} {
2850 global curview mainheadid phase commitrow
2852 if {[info exists commitrow
($curview,$mainheadid)] &&
2853 ($phase eq
{} ||
$commitrow($curview,$mainheadid) < $numcommits - 1)} {
2855 } elseif
{$phase ne
{}} {
2856 lappend commitinterest
($mainheadid) {}
2860 proc dohidelocalchanges
{} {
2861 global localfrow localirow lserial
2863 if {$localfrow >= 0} {
2864 removerow
$localfrow
2866 if {$localirow > 0} {
2870 if {$localirow >= 0} {
2871 removerow
$localirow
2877 # spawn off a process to do git diff-index --cached HEAD
2878 proc dodiffindex
{} {
2879 global localirow localfrow lserial showlocalchanges
2881 if {!$showlocalchanges} return
2885 set fd
[open
"|git diff-index --cached HEAD" r
]
2886 fconfigure
$fd -blocking 0
2887 filerun
$fd [list readdiffindex
$fd $lserial]
2890 proc readdiffindex
{fd serial
} {
2891 global localirow commitrow mainheadid nullid2 curview
2892 global commitinfo commitdata lserial
2895 if {[gets
$fd line
] < 0} {
2901 # we only need to see one line and we don't really care what it says...
2904 # now see if there are any local changes not checked in to the index
2905 if {$serial == $lserial} {
2906 set fd
[open
"|git diff-files" r
]
2907 fconfigure
$fd -blocking 0
2908 filerun
$fd [list readdifffiles
$fd $serial]
2911 if {$isdiff && $serial == $lserial && $localirow == -1} {
2912 # add the line for the changes in the index to the graph
2913 set localirow
$commitrow($curview,$mainheadid)
2914 set hl
[mc
"Local changes checked in to index but not committed"]
2915 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
2916 set commitdata
($nullid2) "\n $hl\n"
2917 insertrow
$localirow $nullid2
2922 proc readdifffiles
{fd serial
} {
2923 global localirow localfrow commitrow mainheadid nullid curview
2924 global commitinfo commitdata lserial
2927 if {[gets
$fd line
] < 0} {
2933 # we only need to see one line and we don't really care what it says...
2936 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2937 # add the line for the local diff to the graph
2938 if {$localirow >= 0} {
2939 set localfrow
$localirow
2942 set localfrow
$commitrow($curview,$mainheadid)
2944 set hl
[mc
"Local uncommitted changes, not checked in to index"]
2945 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
2946 set commitdata
($nullid) "\n $hl\n"
2947 insertrow
$localfrow $nullid
2952 proc nextuse
{id row
} {
2953 global commitrow curview children
2955 if {[info exists children
($curview,$id)]} {
2956 foreach kid
$children($curview,$id) {
2957 if {![info exists commitrow
($curview,$kid)]} {
2960 if {$commitrow($curview,$kid) > $row} {
2961 return $commitrow($curview,$kid)
2965 if {[info exists commitrow
($curview,$id)]} {
2966 return $commitrow($curview,$id)
2971 proc prevuse
{id row
} {
2972 global commitrow curview children
2975 if {[info exists children
($curview,$id)]} {
2976 foreach kid
$children($curview,$id) {
2977 if {![info exists commitrow
($curview,$kid)]} break
2978 if {$commitrow($curview,$kid) < $row} {
2979 set ret
$commitrow($curview,$kid)
2986 proc make_idlist
{row
} {
2987 global displayorder parentlist uparrowlen downarrowlen mingaplen
2988 global commitidx curview ordertok children commitrow
2990 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
2994 set ra
[expr {$row - $downarrowlen}]
2998 set rb
[expr {$row + $uparrowlen}]
2999 if {$rb > $commitidx($curview)} {
3000 set rb
$commitidx($curview)
3003 for {} {$r < $ra} {incr r
} {
3004 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3005 foreach p
[lindex
$parentlist $r] {
3006 if {$p eq
$nextid} continue
3007 set rn
[nextuse
$p $r]
3009 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
3010 lappend ids
[list
$ordertok($curview,$p) $p]
3014 for {} {$r < $row} {incr r
} {
3015 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3016 foreach p
[lindex
$parentlist $r] {
3017 if {$p eq
$nextid} continue
3018 set rn
[nextuse
$p $r]
3019 if {$rn < 0 ||
$rn >= $row} {
3020 lappend ids
[list
$ordertok($curview,$p) $p]
3024 set id
[lindex
$displayorder $row]
3025 lappend ids
[list
$ordertok($curview,$id) $id]
3027 foreach p
[lindex
$parentlist $r] {
3028 set firstkid
[lindex
$children($curview,$p) 0]
3029 if {$commitrow($curview,$firstkid) < $row} {
3030 lappend ids
[list
$ordertok($curview,$p) $p]
3034 set id
[lindex
$displayorder $r]
3036 set firstkid
[lindex
$children($curview,$id) 0]
3037 if {$firstkid ne
{} && $commitrow($curview,$firstkid) < $row} {
3038 lappend ids
[list
$ordertok($curview,$id) $id]
3043 foreach idx
[lsort
-unique $ids] {
3044 lappend idlist
[lindex
$idx 1]
3049 proc rowsequal
{a b
} {
3050 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3051 set a
[lreplace
$a $i $i]
3053 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3054 set b
[lreplace
$b $i $i]
3056 return [expr {$a eq
$b}]
3059 proc makeupline
{id row rend
col} {
3060 global rowidlist uparrowlen downarrowlen mingaplen
3062 for {set r
$rend} {1} {set r
$rstart} {
3063 set rstart
[prevuse
$id $r]
3064 if {$rstart < 0} return
3065 if {$rstart < $row} break
3067 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3068 set rstart
[expr {$rend - $uparrowlen - 1}]
3070 for {set r
$rstart} {[incr r
] <= $row} {} {
3071 set idlist
[lindex
$rowidlist $r]
3072 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3073 set col [idcol
$idlist $id $col]
3074 lset rowidlist
$r [linsert
$idlist $col $id]
3080 proc layoutrows
{row endrow
} {
3081 global rowidlist rowisopt rowfinal displayorder
3082 global uparrowlen downarrowlen maxwidth mingaplen
3083 global children parentlist
3084 global commitidx viewcomplete curview commitrow
3088 set rm1
[expr {$row - 1}]
3089 foreach id
[lindex
$rowidlist $rm1] {
3094 set final
[lindex
$rowfinal $rm1]
3096 for {} {$row < $endrow} {incr row
} {
3097 set rm1
[expr {$row - 1}]
3098 if {$rm1 < 0 ||
$idlist eq
{}} {
3099 set idlist
[make_idlist
$row]
3102 set id
[lindex
$displayorder $rm1]
3103 set col [lsearch
-exact $idlist $id]
3104 set idlist
[lreplace
$idlist $col $col]
3105 foreach p
[lindex
$parentlist $rm1] {
3106 if {[lsearch
-exact $idlist $p] < 0} {
3107 set col [idcol
$idlist $p $col]
3108 set idlist
[linsert
$idlist $col $p]
3109 # if not the first child, we have to insert a line going up
3110 if {$id ne
[lindex
$children($curview,$p) 0]} {
3111 makeupline
$p $rm1 $row $col
3115 set id
[lindex
$displayorder $row]
3116 if {$row > $downarrowlen} {
3117 set termrow
[expr {$row - $downarrowlen - 1}]
3118 foreach p
[lindex
$parentlist $termrow] {
3119 set i
[lsearch
-exact $idlist $p]
3120 if {$i < 0} continue
3121 set nr
[nextuse
$p $termrow]
3122 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3123 set idlist
[lreplace
$idlist $i $i]
3127 set col [lsearch
-exact $idlist $id]
3129 set col [idcol
$idlist $id]
3130 set idlist
[linsert
$idlist $col $id]
3131 if {$children($curview,$id) ne
{}} {
3132 makeupline
$id $rm1 $row $col
3135 set r
[expr {$row + $uparrowlen - 1}]
3136 if {$r < $commitidx($curview)} {
3138 foreach p
[lindex
$parentlist $r] {
3139 if {[lsearch
-exact $idlist $p] >= 0} continue
3140 set fk
[lindex
$children($curview,$p) 0]
3141 if {$commitrow($curview,$fk) < $row} {
3142 set x
[idcol
$idlist $p $x]
3143 set idlist
[linsert
$idlist $x $p]
3146 if {[incr r
] < $commitidx($curview)} {
3147 set p
[lindex
$displayorder $r]
3148 if {[lsearch
-exact $idlist $p] < 0} {
3149 set fk
[lindex
$children($curview,$p) 0]
3150 if {$fk ne
{} && $commitrow($curview,$fk) < $row} {
3151 set x
[idcol
$idlist $p $x]
3152 set idlist
[linsert
$idlist $x $p]
3158 if {$final && !$viewcomplete($curview) &&
3159 $row + $uparrowlen + $mingaplen + $downarrowlen
3160 >= $commitidx($curview)} {
3163 set l
[llength
$rowidlist]
3165 lappend rowidlist
$idlist
3167 lappend rowfinal
$final
3168 } elseif
{$row < $l} {
3169 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3170 lset rowidlist
$row $idlist
3173 lset rowfinal
$row $final
3175 set pad
[ntimes
[expr {$row - $l}] {}]
3176 set rowidlist
[concat
$rowidlist $pad]
3177 lappend rowidlist
$idlist
3178 set rowfinal
[concat
$rowfinal $pad]
3179 lappend rowfinal
$final
3180 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3186 proc changedrow
{row
} {
3187 global displayorder iddrawn rowisopt need_redisplay
3189 set l
[llength
$rowisopt]
3191 lset rowisopt
$row 0
3192 if {$row + 1 < $l} {
3193 lset rowisopt
[expr {$row + 1}] 0
3194 if {$row + 2 < $l} {
3195 lset rowisopt
[expr {$row + 2}] 0
3199 set id
[lindex
$displayorder $row]
3200 if {[info exists iddrawn
($id)]} {
3201 set need_redisplay
1
3205 proc insert_pad
{row
col npad
} {
3208 set pad
[ntimes
$npad {}]
3209 set idlist
[lindex
$rowidlist $row]
3210 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3211 set aft
[lrange
$idlist $col end
]
3212 set i
[lsearch
-exact $aft {}]
3214 set aft
[lreplace
$aft $i $i]
3216 lset rowidlist
$row [concat
$bef $pad $aft]
3220 proc optimize_rows
{row
col endrow
} {
3221 global rowidlist rowisopt displayorder curview children
3226 for {} {$row < $endrow} {incr row
; set col 0} {
3227 if {[lindex
$rowisopt $row]} continue
3229 set y0
[expr {$row - 1}]
3230 set ym
[expr {$row - 2}]
3231 set idlist
[lindex
$rowidlist $row]
3232 set previdlist
[lindex
$rowidlist $y0]
3233 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3235 set pprevidlist
[lindex
$rowidlist $ym]
3236 if {$pprevidlist eq
{}} continue
3242 for {} {$col < [llength
$idlist]} {incr
col} {
3243 set id
[lindex
$idlist $col]
3244 if {[lindex
$previdlist $col] eq
$id} continue
3249 set x0
[lsearch
-exact $previdlist $id]
3250 if {$x0 < 0} continue
3251 set z
[expr {$x0 - $col}]
3255 set xm
[lsearch
-exact $pprevidlist $id]
3257 set z0
[expr {$xm - $x0}]
3261 # if row y0 is the first child of $id then it's not an arrow
3262 if {[lindex
$children($curview,$id) 0] ne
3263 [lindex
$displayorder $y0]} {
3267 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3268 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3271 # Looking at lines from this row to the previous row,
3272 # make them go straight up if they end in an arrow on
3273 # the previous row; otherwise make them go straight up
3275 if {$z < -1 ||
($z < 0 && $isarrow)} {
3276 # Line currently goes left too much;
3277 # insert pads in the previous row, then optimize it
3278 set npad
[expr {-1 - $z + $isarrow}]
3279 insert_pad
$y0 $x0 $npad
3281 optimize_rows
$y0 $x0 $row
3283 set previdlist
[lindex
$rowidlist $y0]
3284 set x0
[lsearch
-exact $previdlist $id]
3285 set z
[expr {$x0 - $col}]
3287 set pprevidlist
[lindex
$rowidlist $ym]
3288 set xm
[lsearch
-exact $pprevidlist $id]
3289 set z0
[expr {$xm - $x0}]
3291 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3292 # Line currently goes right too much;
3293 # insert pads in this line
3294 set npad
[expr {$z - 1 + $isarrow}]
3295 insert_pad
$row $col $npad
3296 set idlist
[lindex
$rowidlist $row]
3298 set z
[expr {$x0 - $col}]
3301 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3302 # this line links to its first child on row $row-2
3303 set id
[lindex
$displayorder $ym]
3304 set xc
[lsearch
-exact $pprevidlist $id]
3306 set z0
[expr {$xc - $x0}]
3309 # avoid lines jigging left then immediately right
3310 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3311 insert_pad
$y0 $x0 1
3313 optimize_rows
$y0 $x0 $row
3314 set previdlist
[lindex
$rowidlist $y0]
3318 # Find the first column that doesn't have a line going right
3319 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3320 set id
[lindex
$idlist $col]
3321 if {$id eq
{}} break
3322 set x0
[lsearch
-exact $previdlist $id]
3324 # check if this is the link to the first child
3325 set kid
[lindex
$displayorder $y0]
3326 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3327 # it is, work out offset to child
3328 set x0
[lsearch
-exact $previdlist $kid]
3331 if {$x0 <= $col} break
3333 # Insert a pad at that column as long as it has a line and
3334 # isn't the last column
3335 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3336 set idlist
[linsert
$idlist $col {}]
3337 lset rowidlist
$row $idlist
3345 global canvx0 linespc
3346 return [expr {$canvx0 + $col * $linespc}]
3350 global canvy0 linespc
3351 return [expr {$canvy0 + $row * $linespc}]
3354 proc linewidth
{id
} {
3355 global thickerline lthickness
3358 if {[info exists thickerline
] && $id eq
$thickerline} {
3359 set wid
[expr {2 * $lthickness}]
3364 proc rowranges
{id
} {
3365 global commitrow curview children uparrowlen downarrowlen
3368 set kids
$children($curview,$id)
3374 foreach child
$kids {
3375 if {![info exists commitrow
($curview,$child)]} break
3376 set row
$commitrow($curview,$child)
3377 if {![info exists prev
]} {
3378 lappend ret
[expr {$row + 1}]
3380 if {$row <= $prevrow} {
3381 puts
"oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3383 # see if the line extends the whole way from prevrow to row
3384 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3385 [lsearch
-exact [lindex
$rowidlist \
3386 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
3387 # it doesn't, see where it ends
3388 set r
[expr {$prevrow + $downarrowlen}]
3389 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3390 while {[incr r
-1] > $prevrow &&
3391 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3393 while {[incr r
] <= $row &&
3394 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3398 # see where it starts up again
3399 set r
[expr {$row - $uparrowlen}]
3400 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3401 while {[incr r
] < $row &&
3402 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3404 while {[incr r
-1] >= $prevrow &&
3405 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3411 if {$child eq
$id} {
3420 proc drawlineseg
{id row endrow arrowlow
} {
3421 global rowidlist displayorder iddrawn linesegs
3422 global canv colormap linespc curview maxlinelen parentlist
3424 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
3425 set le
[expr {$row + 1}]
3428 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
3434 set x
[lindex
$displayorder $le]
3439 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
3440 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
3456 if {[info exists linesegs
($id)]} {
3457 set lines
$linesegs($id)
3459 set r0
[lindex
$li 0]
3461 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
3471 set li
[lindex
$lines [expr {$i-1}]]
3472 set r1
[lindex
$li 1]
3473 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
3478 set x
[lindex
$cols [expr {$le - $row}]]
3479 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
3480 set dir
[expr {$xp - $x}]
3482 set ith
[lindex
$lines $i 2]
3483 set coords
[$canv coords
$ith]
3484 set ah
[$canv itemcget
$ith -arrow]
3485 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
3486 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
3487 if {$x2 ne
{} && $x - $x2 == $dir} {
3488 set coords
[lrange
$coords 0 end-2
]
3491 set coords
[list
[xc
$le $x] [yc
$le]]
3494 set itl
[lindex
$lines [expr {$i-1}] 2]
3495 set al
[$canv itemcget
$itl -arrow]
3496 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
3497 } elseif
{$arrowlow} {
3498 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
3499 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
3503 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
3504 for {set y
$le} {[incr y
-1] > $row} {} {
3506 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
3507 set ndir
[expr {$xp - $x}]
3508 if {$dir != $ndir ||
$xp < 0} {
3509 lappend coords
[xc
$y $x] [yc
$y]
3515 # join parent line to first child
3516 set ch
[lindex
$displayorder $row]
3517 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
3519 puts
"oops: drawlineseg: child $ch not on row $row"
3520 } elseif
{$xc != $x} {
3521 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
3522 set d
[expr {int
(0.5 * $linespc)}]
3525 set x2
[expr {$x1 - $d}]
3527 set x2
[expr {$x1 + $d}]
3530 set y1
[expr {$y2 + $d}]
3531 lappend coords
$x1 $y1 $x2 $y2
3532 } elseif
{$xc < $x - 1} {
3533 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
3534 } elseif
{$xc > $x + 1} {
3535 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
3539 lappend coords
[xc
$row $x] [yc
$row]
3541 set xn
[xc
$row $xp]
3543 lappend coords
$xn $yn
3547 set t
[$canv create line
$coords -width [linewidth
$id] \
3548 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
3551 set lines
[linsert
$lines $i [list
$row $le $t]]
3553 $canv coords
$ith $coords
3554 if {$arrow ne
$ah} {
3555 $canv itemconf
$ith -arrow $arrow
3557 lset lines
$i 0 $row
3560 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
3561 set ndir
[expr {$xo - $xp}]
3562 set clow
[$canv coords
$itl]
3563 if {$dir == $ndir} {
3564 set clow
[lrange
$clow 2 end
]
3566 set coords
[concat
$coords $clow]
3568 lset lines
[expr {$i-1}] 1 $le
3570 # coalesce two pieces
3572 set b
[lindex
$lines [expr {$i-1}] 0]
3573 set e
[lindex
$lines $i 1]
3574 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
3576 $canv coords
$itl $coords
3577 if {$arrow ne
$al} {
3578 $canv itemconf
$itl -arrow $arrow
3582 set linesegs
($id) $lines
3586 proc drawparentlinks
{id row
} {
3587 global rowidlist canv colormap curview parentlist
3588 global idpos linespc
3590 set rowids
[lindex
$rowidlist $row]
3591 set col [lsearch
-exact $rowids $id]
3592 if {$col < 0} return
3593 set olds
[lindex
$parentlist $row]
3594 set row2
[expr {$row + 1}]
3595 set x
[xc
$row $col]
3598 set d
[expr {int
(0.5 * $linespc)}]
3599 set ymid
[expr {$y + $d}]
3600 set ids
[lindex
$rowidlist $row2]
3601 # rmx = right-most X coord used
3604 set i
[lsearch
-exact $ids $p]
3606 puts
"oops, parent $p of $id not in list"
3609 set x2
[xc
$row2 $i]
3613 set j
[lsearch
-exact $rowids $p]
3615 # drawlineseg will do this one for us
3619 # should handle duplicated parents here...
3620 set coords
[list
$x $y]
3622 # if attaching to a vertical segment, draw a smaller
3623 # slant for visual distinctness
3626 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
3628 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
3630 } elseif
{$i < $col && $i < $j} {
3631 # segment slants towards us already
3632 lappend coords
[xc
$row $j] $y
3634 if {$i < $col - 1} {
3635 lappend coords
[expr {$x2 + $linespc}] $y
3636 } elseif
{$i > $col + 1} {
3637 lappend coords
[expr {$x2 - $linespc}] $y
3639 lappend coords
$x2 $y2
3642 lappend coords
$x2 $y2
3644 set t
[$canv create line
$coords -width [linewidth
$p] \
3645 -fill $colormap($p) -tags lines.
$p]
3649 if {$rmx > [lindex
$idpos($id) 1]} {
3650 lset idpos
($id) 1 $rmx
3655 proc drawlines
{id
} {
3658 $canv itemconf lines.
$id -width [linewidth
$id]
3661 proc drawcmittext
{id row
col} {
3662 global linespc canv canv2 canv3 canvy0 fgcolor curview
3663 global commitlisted commitinfo rowidlist parentlist
3664 global rowtextx idpos idtags idheads idotherrefs
3665 global linehtag linentag linedtag selectedline
3666 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3668 # listed is 0 for boundary, 1 for normal, 2 for negative, 3 for left, 4 for right
3669 set listed
[lindex
$commitlisted $row]
3670 if {$id eq
$nullid} {
3672 } elseif
{$id eq
$nullid2} {
3675 set ofill
[expr {$listed != 0 ?
$listed == 2 ?
"gray" : "blue" : "white"}]
3677 set x
[xc
$row $col]
3679 set orad
[expr {$linespc / 3}]
3681 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
3682 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3683 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3684 } elseif
{$listed == 3} {
3685 # triangle pointing left for left-side commits
3686 set t
[$canv create polygon \
3687 [expr {$x - $orad}] $y \
3688 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3689 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3690 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3692 # triangle pointing right for right-side commits
3693 set t
[$canv create polygon \
3694 [expr {$x + $orad - 1}] $y \
3695 [expr {$x - $orad}] [expr {$y - $orad}] \
3696 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3697 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3700 $canv bind $t <1> {selcanvline
{} %x
%y
}
3701 set rmx
[llength
[lindex
$rowidlist $row]]
3702 set olds
[lindex
$parentlist $row]
3704 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
3706 set i
[lsearch
-exact $nextids $p]
3712 set xt
[xc
$row $rmx]
3713 set rowtextx
($row) $xt
3714 set idpos
($id) [list
$x $xt $y]
3715 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
3716 ||
[info exists idotherrefs
($id)]} {
3717 set xt
[drawtags
$id $x $xt $y]
3719 set headline
[lindex
$commitinfo($id) 0]
3720 set name
[lindex
$commitinfo($id) 1]
3721 set date [lindex
$commitinfo($id) 2]
3722 set date [formatdate
$date]
3725 set isbold
[ishighlighted
$row]
3727 lappend boldrows
$row
3728 set font mainfontbold
3730 lappend boldnamerows
$row
3731 set nfont mainfontbold
3734 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
3735 -text $headline -font $font -tags text
]
3736 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
3737 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
3738 -text $name -font $nfont -tags text
]
3739 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
3740 -text $date -font mainfont
-tags text
]
3741 if {[info exists selectedline
] && $selectedline == $row} {
3744 set xr
[expr {$xt + [font measure
$font $headline]}]
3745 if {$xr > $canvxmax} {
3751 proc drawcmitrow
{row
} {
3752 global displayorder rowidlist nrows_drawn
3753 global iddrawn markingmatches
3754 global commitinfo parentlist numcommits
3755 global filehighlight fhighlights findpattern nhighlights
3756 global hlview vhighlights
3757 global highlight_related rhighlights
3759 if {$row >= $numcommits} return
3761 set id
[lindex
$displayorder $row]
3762 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
3763 askvhighlight
$row $id
3765 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
3766 askfilehighlight
$row $id
3768 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
3769 askfindhighlight
$row $id
3771 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
3772 askrelhighlight
$row $id
3774 if {![info exists iddrawn
($id)]} {
3775 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
3777 puts
"oops, row $row id $id not in list"
3780 if {![info exists commitinfo
($id)]} {
3784 drawcmittext
$id $row $col
3788 if {$markingmatches} {
3789 markrowmatches
$row $id
3793 proc drawcommits
{row
{endrow
{}}} {
3794 global numcommits iddrawn displayorder curview need_redisplay
3795 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3800 if {$endrow eq
{}} {
3803 if {$endrow >= $numcommits} {
3804 set endrow
[expr {$numcommits - 1}]
3807 set rl1
[expr {$row - $downarrowlen - 3}]
3811 set ro1
[expr {$row - 3}]
3815 set r2
[expr {$endrow + $uparrowlen + 3}]
3816 if {$r2 > $numcommits} {
3819 for {set r
$rl1} {$r < $r2} {incr r
} {
3820 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
3824 set rl1
[expr {$r + 1}]
3830 optimize_rows
$ro1 0 $r2
3831 if {$need_redisplay ||
$nrows_drawn > 2000} {
3836 # make the lines join to already-drawn rows either side
3837 set r
[expr {$row - 1}]
3838 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
3841 set er
[expr {$endrow + 1}]
3842 if {$er >= $numcommits ||
3843 ![info exists iddrawn
([lindex
$displayorder $er])]} {
3846 for {} {$r <= $er} {incr r
} {
3847 set id
[lindex
$displayorder $r]
3848 set wasdrawn
[info exists iddrawn
($id)]
3850 if {$r == $er} break
3851 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3852 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
3853 drawparentlinks
$id $r
3855 set rowids
[lindex
$rowidlist $r]
3856 foreach lid
$rowids {
3857 if {$lid eq
{}} continue
3858 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
3860 # see if this is the first child of any of its parents
3861 foreach p
[lindex
$parentlist $r] {
3862 if {[lsearch
-exact $rowids $p] < 0} {
3863 # make this line extend up to the child
3864 set lineend
($p) [drawlineseg
$p $r $er 0]
3868 set lineend
($lid) [drawlineseg
$lid $r $er 1]
3874 proc drawfrac
{f0 f1
} {
3877 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3878 if {$ymax eq
{} ||
$ymax == 0} return
3879 set y0
[expr {int
($f0 * $ymax)}]
3880 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
3881 set y1
[expr {int
($f1 * $ymax)}]
3882 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
3883 drawcommits
$row $endrow
3886 proc drawvisible
{} {
3888 eval drawfrac
[$canv yview
]
3891 proc clear_display
{} {
3892 global iddrawn linesegs need_redisplay nrows_drawn
3893 global vhighlights fhighlights nhighlights rhighlights
3896 catch
{unset iddrawn
}
3897 catch
{unset linesegs
}
3898 catch
{unset vhighlights
}
3899 catch
{unset fhighlights
}
3900 catch
{unset nhighlights
}
3901 catch
{unset rhighlights
}
3902 set need_redisplay
0
3906 proc findcrossings
{id
} {
3907 global rowidlist parentlist numcommits displayorder
3911 foreach
{s e
} [rowranges
$id] {
3912 if {$e >= $numcommits} {
3913 set e
[expr {$numcommits - 1}]
3915 if {$e <= $s} continue
3916 for {set row
$e} {[incr row
-1] >= $s} {} {
3917 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
3919 set olds
[lindex
$parentlist $row]
3920 set kid
[lindex
$displayorder $row]
3921 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
3922 if {$kidx < 0} continue
3923 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
3925 set px
[lsearch
-exact $nextrow $p]
3926 if {$px < 0} continue
3927 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
3928 if {[lsearch
-exact $ccross $p] >= 0} continue
3929 if {$x == $px + ($kidx < $px?
-1: 1)} {
3931 } elseif
{[lsearch
-exact $cross $p] < 0} {
3938 return [concat
$ccross {{}} $cross]
3941 proc assigncolor
{id
} {
3942 global colormap colors nextcolor
3943 global commitrow parentlist children children curview
3945 if {[info exists colormap
($id)]} return
3946 set ncolors
[llength
$colors]
3947 if {[info exists children
($curview,$id)]} {
3948 set kids
$children($curview,$id)
3952 if {[llength
$kids] == 1} {
3953 set child
[lindex
$kids 0]
3954 if {[info exists colormap
($child)]
3955 && [llength
[lindex
$parentlist $commitrow($curview,$child)]] == 1} {
3956 set colormap
($id) $colormap($child)
3962 foreach x
[findcrossings
$id] {
3964 # delimiter between corner crossings and other crossings
3965 if {[llength
$badcolors] >= $ncolors - 1} break
3966 set origbad
$badcolors
3968 if {[info exists colormap
($x)]
3969 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
3970 lappend badcolors
$colormap($x)
3973 if {[llength
$badcolors] >= $ncolors} {
3974 set badcolors
$origbad
3976 set origbad
$badcolors
3977 if {[llength
$badcolors] < $ncolors - 1} {
3978 foreach child
$kids {
3979 if {[info exists colormap
($child)]
3980 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
3981 lappend badcolors
$colormap($child)
3983 foreach p
[lindex
$parentlist $commitrow($curview,$child)] {
3984 if {[info exists colormap
($p)]
3985 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
3986 lappend badcolors
$colormap($p)
3990 if {[llength
$badcolors] >= $ncolors} {
3991 set badcolors
$origbad
3994 for {set i
0} {$i <= $ncolors} {incr i
} {
3995 set c
[lindex
$colors $nextcolor]
3996 if {[incr nextcolor
] >= $ncolors} {
3999 if {[lsearch
-exact $badcolors $c]} break
4001 set colormap
($id) $c
4004 proc bindline
{t id
} {
4007 $canv bind $t <Enter
> "lineenter %x %y $id"
4008 $canv bind $t <Motion
> "linemotion %x %y $id"
4009 $canv bind $t <Leave
> "lineleave $id"
4010 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
4013 proc drawtags
{id x xt y1
} {
4014 global idtags idheads idotherrefs mainhead
4015 global linespc lthickness
4016 global canv commitrow rowtextx curview fgcolor bgcolor
4021 if {[info exists idtags
($id)]} {
4022 set marks
$idtags($id)
4023 set ntags
[llength
$marks]
4025 if {[info exists idheads
($id)]} {
4026 set marks
[concat
$marks $idheads($id)]
4027 set nheads
[llength
$idheads($id)]
4029 if {[info exists idotherrefs
($id)]} {
4030 set marks
[concat
$marks $idotherrefs($id)]
4036 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
4037 set yt
[expr {$y1 - 0.5 * $linespc}]
4038 set yb
[expr {$yt + $linespc - 1}]
4042 foreach tag
$marks {
4044 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4045 set wid
[font measure mainfontbold
$tag]
4047 set wid
[font measure mainfont
$tag]
4051 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4053 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4054 -width $lthickness -fill black
-tags tag.
$id]
4056 foreach tag
$marks x
$xvals wid
$wvals {
4057 set xl
[expr {$x + $delta}]
4058 set xr
[expr {$x + $delta + $wid + $lthickness}]
4060 if {[incr ntags
-1] >= 0} {
4062 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4063 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4064 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4065 $canv bind $t <1> [list showtag
$tag 1]
4066 set rowtextx
($commitrow($curview,$id)) [expr {$xr + $linespc}]
4068 # draw a head or other ref
4069 if {[incr nheads
-1] >= 0} {
4071 if {$tag eq
$mainhead} {
4072 set font mainfontbold
4077 set xl
[expr {$xl - $delta/2}]
4078 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4079 -width 1 -outline black
-fill $col -tags tag.
$id
4080 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4081 set rwid
[font measure mainfont
$remoteprefix]
4082 set xi
[expr {$x + 1}]
4083 set yti
[expr {$yt + 1}]
4084 set xri
[expr {$x + $rwid}]
4085 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4086 -width 0 -fill "#ffddaa" -tags tag.
$id
4089 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4090 -font $font -tags [list tag.
$id text
]]
4092 $canv bind $t <1> [list showtag
$tag 1]
4093 } elseif
{$nheads >= 0} {
4094 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4100 proc xcoord
{i level
ln} {
4101 global canvx0 xspc1 xspc2
4103 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4104 if {$i > 0 && $i == $level} {
4105 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4106 } elseif
{$i > $level} {
4107 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4112 proc show_status
{msg
} {
4116 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4117 -tags text
-fill $fgcolor
4120 # Insert a new commit as the child of the commit on row $row.
4121 # The new commit will be displayed on row $row and the commits
4122 # on that row and below will move down one row.
4123 proc insertrow
{row newcmit
} {
4124 global displayorder parentlist commitlisted children
4125 global commitrow curview rowidlist rowisopt rowfinal numcommits
4127 global selectedline commitidx ordertok
4129 if {$row >= $numcommits} {
4130 puts
"oops, inserting new row $row but only have $numcommits rows"
4133 set p
[lindex
$displayorder $row]
4134 set displayorder
[linsert
$displayorder $row $newcmit]
4135 set parentlist
[linsert
$parentlist $row $p]
4136 set kids
$children($curview,$p)
4137 lappend kids
$newcmit
4138 set children
($curview,$p) $kids
4139 set children
($curview,$newcmit) {}
4140 set commitlisted
[linsert
$commitlisted $row 1]
4141 set l
[llength
$displayorder]
4142 for {set r
$row} {$r < $l} {incr r
} {
4143 set id
[lindex
$displayorder $r]
4144 set commitrow
($curview,$id) $r
4146 incr commitidx
($curview)
4147 set ordertok
($curview,$newcmit) $ordertok($curview,$p)
4149 if {$row < [llength
$rowidlist]} {
4150 set idlist
[lindex
$rowidlist $row]
4151 if {$idlist ne
{}} {
4152 if {[llength
$kids] == 1} {
4153 set col [lsearch
-exact $idlist $p]
4154 lset idlist
$col $newcmit
4156 set col [llength
$idlist]
4157 lappend idlist
$newcmit
4160 set rowidlist
[linsert
$rowidlist $row $idlist]
4161 set rowisopt
[linsert
$rowisopt $row 0]
4162 set rowfinal
[linsert
$rowfinal $row [lindex
$rowfinal $row]]
4167 if {[info exists selectedline
] && $selectedline >= $row} {
4173 # Remove a commit that was inserted with insertrow on row $row.
4174 proc removerow
{row
} {
4175 global displayorder parentlist commitlisted children
4176 global commitrow curview rowidlist rowisopt rowfinal numcommits
4178 global linesegends selectedline commitidx
4180 if {$row >= $numcommits} {
4181 puts
"oops, removing row $row but only have $numcommits rows"
4184 set rp1
[expr {$row + 1}]
4185 set id
[lindex
$displayorder $row]
4186 set p
[lindex
$parentlist $row]
4187 set displayorder
[lreplace
$displayorder $row $row]
4188 set parentlist
[lreplace
$parentlist $row $row]
4189 set commitlisted
[lreplace
$commitlisted $row $row]
4190 set kids
$children($curview,$p)
4191 set i
[lsearch
-exact $kids $id]
4193 set kids
[lreplace
$kids $i $i]
4194 set children
($curview,$p) $kids
4196 set l
[llength
$displayorder]
4197 for {set r
$row} {$r < $l} {incr r
} {
4198 set id
[lindex
$displayorder $r]
4199 set commitrow
($curview,$id) $r
4201 incr commitidx
($curview) -1
4203 if {$row < [llength
$rowidlist]} {
4204 set rowidlist
[lreplace
$rowidlist $row $row]
4205 set rowisopt
[lreplace
$rowisopt $row $row]
4206 set rowfinal
[lreplace
$rowfinal $row $row]
4211 if {[info exists selectedline
] && $selectedline > $row} {
4212 incr selectedline
-1
4217 # Don't change the text pane cursor if it is currently the hand cursor,
4218 # showing that we are over a sha1 ID link.
4219 proc settextcursor
{c
} {
4220 global ctext curtextcursor
4222 if {[$ctext cget
-cursor] == $curtextcursor} {
4223 $ctext config
-cursor $c
4225 set curtextcursor
$c
4228 proc nowbusy
{what
{name
{}}} {
4229 global isbusy busyname statusw
4231 if {[array names isbusy
] eq
{}} {
4232 . config
-cursor watch
4236 set busyname
($what) $name
4238 $statusw conf
-text $name
4242 proc notbusy
{what
} {
4243 global isbusy maincursor textcursor busyname statusw
4247 if {$busyname($what) ne
{} &&
4248 [$statusw cget
-text] eq
$busyname($what)} {
4249 $statusw conf
-text {}
4252 if {[array names isbusy
] eq
{}} {
4253 . config
-cursor $maincursor
4254 settextcursor
$textcursor
4258 proc findmatches
{f
} {
4259 global findtype findstring
4260 if {$findtype == [mc
"Regexp"]} {
4261 set matches
[regexp
-indices -all -inline $findstring $f]
4264 if {$findtype == [mc
"IgnCase"]} {
4265 set f
[string tolower
$f]
4266 set fs
[string tolower
$fs]
4270 set l
[string length
$fs]
4271 while {[set j
[string first
$fs $f $i]] >= 0} {
4272 lappend matches
[list
$j [expr {$j+$l-1}]]
4273 set i
[expr {$j + $l}]
4279 proc dofind
{{dirn
1} {wrap
1}} {
4280 global findstring findstartline findcurline selectedline numcommits
4281 global gdttype filehighlight fh_serial find_dirn findallowwrap
4283 if {[info exists find_dirn
]} {
4284 if {$find_dirn == $dirn} return
4288 if {$findstring eq
{} ||
$numcommits == 0} return
4289 if {![info exists selectedline
]} {
4290 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4292 set findstartline
$selectedline
4294 set findcurline
$findstartline
4295 nowbusy finding
[mc
"Searching"]
4296 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4297 after cancel do_file_hl
$fh_serial
4298 do_file_hl
$fh_serial
4301 set findallowwrap
$wrap
4305 proc stopfinding
{} {
4306 global find_dirn findcurline fprogcoord
4308 if {[info exists find_dirn
]} {
4318 global commitdata commitinfo numcommits findpattern findloc
4319 global findstartline findcurline displayorder
4320 global find_dirn gdttype fhighlights fprogcoord
4321 global findallowwrap
4323 if {![info exists find_dirn
]} {
4326 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4329 if {$find_dirn > 0} {
4331 if {$l >= $numcommits} {
4334 if {$l <= $findstartline} {
4335 set lim
[expr {$findstartline + 1}]
4338 set moretodo
$findallowwrap
4345 if {$l >= $findstartline} {
4346 set lim
[expr {$findstartline - 1}]
4349 set moretodo
$findallowwrap
4352 set n
[expr {($lim - $l) * $find_dirn}]
4359 if {$gdttype eq
[mc
"containing:"]} {
4360 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4361 set id
[lindex
$displayorder $l]
4362 # shouldn't happen unless git log doesn't give all the commits...
4363 if {![info exists commitdata
($id)]} continue
4364 if {![doesmatch
$commitdata($id)]} continue
4365 if {![info exists commitinfo
($id)]} {
4368 set info
$commitinfo($id)
4369 foreach f
$info ty
$fldtypes {
4370 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4379 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4380 set id
[lindex
$displayorder $l]
4381 if {![info exists fhighlights
($l)]} {
4382 askfilehighlight
$l $id
4385 set findcurline
[expr {$l - $find_dirn}]
4387 } elseif
{$fhighlights($l)} {
4393 if {$found ||
($domore && !$moretodo)} {
4409 set findcurline
[expr {$l - $find_dirn}]
4411 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
4415 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
4420 proc findselectline
{l
} {
4421 global findloc commentend ctext findcurline markingmatches gdttype
4423 set markingmatches
1
4426 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
4427 # highlight the matches in the comments
4428 set f
[$ctext get
1.0 $commentend]
4429 set matches
[findmatches
$f]
4430 foreach match
$matches {
4431 set start
[lindex
$match 0]
4432 set end
[expr {[lindex
$match 1] + 1}]
4433 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
4439 # mark the bits of a headline or author that match a find string
4440 proc markmatches
{canv l str tag matches font row
} {
4443 set bbox
[$canv bbox
$tag]
4444 set x0
[lindex
$bbox 0]
4445 set y0
[lindex
$bbox 1]
4446 set y1
[lindex
$bbox 3]
4447 foreach match
$matches {
4448 set start
[lindex
$match 0]
4449 set end
[lindex
$match 1]
4450 if {$start > $end} continue
4451 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
4452 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
4453 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
4454 [expr {$x0+$xlen+2}] $y1 \
4455 -outline {} -tags [list match
$l matches
] -fill yellow
]
4457 if {[info exists selectedline
] && $row == $selectedline} {
4458 $canv raise
$t secsel
4463 proc unmarkmatches
{} {
4464 global markingmatches
4466 allcanvs delete matches
4467 set markingmatches
0
4471 proc selcanvline
{w x y
} {
4472 global canv canvy0 ctext linespc
4474 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4475 if {$ymax == {}} return
4476 set yfrac
[lindex
[$canv yview
] 0]
4477 set y
[expr {$y + $yfrac * $ymax}]
4478 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
4483 if {![info exists rowtextx
($l)] ||
$x < $rowtextx($l)} return
4489 proc commit_descriptor
{p
} {
4491 if {![info exists commitinfo
($p)]} {
4495 if {[llength
$commitinfo($p)] > 1} {
4496 set l
[lindex
$commitinfo($p) 0]
4501 # append some text to the ctext widget, and make any SHA1 ID
4502 # that we know about be a clickable link.
4503 proc appendwithlinks
{text tags
} {
4504 global ctext commitrow linknum curview pendinglinks
4506 set start
[$ctext index
"end - 1c"]
4507 $ctext insert end
$text $tags
4508 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
4512 set linkid
[string range
$text $s $e]
4514 $ctext tag delete link
$linknum
4515 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
4516 setlink
$linkid link
$linknum
4521 proc setlink
{id lk
} {
4522 global curview commitrow ctext pendinglinks commitinterest
4524 if {[info exists commitrow
($curview,$id)]} {
4525 $ctext tag conf
$lk -foreground blue
-underline 1
4526 $ctext tag
bind $lk <1> [list selectline
$commitrow($curview,$id) 1]
4527 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
4528 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
4530 lappend pendinglinks
($id) $lk
4531 lappend commitinterest
($id) {makelink
%I
}
4535 proc makelink
{id
} {
4538 if {![info exists pendinglinks
($id)]} return
4539 foreach lk
$pendinglinks($id) {
4542 unset pendinglinks
($id)
4545 proc linkcursor
{w inc
} {
4546 global linkentercount curtextcursor
4548 if {[incr linkentercount
$inc] > 0} {
4549 $w configure
-cursor hand2
4551 $w configure
-cursor $curtextcursor
4552 if {$linkentercount < 0} {
4553 set linkentercount
0
4558 proc viewnextline
{dir
} {
4562 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4563 set wnow
[$canv yview
]
4564 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4565 set newtop
[expr {$wtop + $dir * $linespc}]
4568 } elseif
{$newtop > $ymax} {
4571 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4574 # add a list of tag or branch names at position pos
4575 # returns the number of names inserted
4576 proc appendrefs
{pos ids var
} {
4577 global ctext commitrow linknum curview
$var maxrefs
4579 if {[catch
{$ctext index
$pos}]} {
4582 $ctext conf
-state normal
4583 $ctext delete
$pos "$pos lineend"
4586 foreach tag
[set $var\
($id\
)] {
4587 lappend tags
[list
$tag $id]
4590 if {[llength
$tags] > $maxrefs} {
4591 $ctext insert
$pos "many ([llength $tags])"
4593 set tags
[lsort
-index 0 -decreasing $tags]
4596 set id
[lindex
$ti 1]
4599 $ctext tag delete
$lk
4600 $ctext insert
$pos $sep
4601 $ctext insert
$pos [lindex
$ti 0] $lk
4606 $ctext conf
-state disabled
4607 return [llength
$tags]
4610 # called when we have finished computing the nearby tags
4611 proc dispneartags
{delay
} {
4612 global selectedline currentid showneartags tagphase
4614 if {![info exists selectedline
] ||
!$showneartags} return
4615 after cancel dispnexttag
4617 after
200 dispnexttag
4620 after idle dispnexttag
4625 proc dispnexttag
{} {
4626 global selectedline currentid showneartags tagphase ctext
4628 if {![info exists selectedline
] ||
!$showneartags} return
4629 switch
-- $tagphase {
4631 set dtags
[desctags
$currentid]
4633 appendrefs precedes
$dtags idtags
4637 set atags
[anctags
$currentid]
4639 appendrefs follows
$atags idtags
4643 set dheads
[descheads
$currentid]
4644 if {$dheads ne
{}} {
4645 if {[appendrefs branch
$dheads idheads
] > 1
4646 && [$ctext get
"branch -3c"] eq
"h"} {
4647 # turn "Branch" into "Branches"
4648 $ctext conf
-state normal
4649 $ctext insert
"branch -2c" "es"
4650 $ctext conf
-state disabled
4655 if {[incr tagphase
] <= 2} {
4656 after idle dispnexttag
4660 proc make_secsel
{l
} {
4661 global linehtag linentag linedtag canv canv2 canv3
4663 if {![info exists linehtag
($l)]} return
4665 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
4666 -tags secsel
-fill [$canv cget
-selectbackground]]
4668 $canv2 delete secsel
4669 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
4670 -tags secsel
-fill [$canv2 cget
-selectbackground]]
4672 $canv3 delete secsel
4673 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
4674 -tags secsel
-fill [$canv3 cget
-selectbackground]]
4678 proc selectline
{l isnew
} {
4679 global canv ctext commitinfo selectedline
4681 global canvy0 linespc parentlist children curview
4682 global currentid sha1entry
4683 global commentend idtags linknum
4684 global mergemax numcommits pending_select
4685 global cmitmode showneartags allcommits
4688 catch
{unset pending_select
}
4693 if {$l < 0 ||
$l >= $numcommits} return
4694 set y
[expr {$canvy0 + $l * $linespc}]
4695 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4696 set ytop
[expr {$y - $linespc - 1}]
4697 set ybot
[expr {$y + $linespc + 1}]
4698 set wnow
[$canv yview
]
4699 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4700 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
4701 set wh
[expr {$wbot - $wtop}]
4703 if {$ytop < $wtop} {
4704 if {$ybot < $wtop} {
4705 set newtop
[expr {$y - $wh / 2.0}]
4708 if {$newtop > $wtop - $linespc} {
4709 set newtop
[expr {$wtop - $linespc}]
4712 } elseif
{$ybot > $wbot} {
4713 if {$ytop > $wbot} {
4714 set newtop
[expr {$y - $wh / 2.0}]
4716 set newtop
[expr {$ybot - $wh}]
4717 if {$newtop < $wtop + $linespc} {
4718 set newtop
[expr {$wtop + $linespc}]
4722 if {$newtop != $wtop} {
4726 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4733 addtohistory
[list selectline
$l 0]
4738 set id
[lindex
$displayorder $l]
4740 $sha1entry delete
0 end
4741 $sha1entry insert
0 $id
4743 $sha1entry selection from
0
4744 $sha1entry selection to end
4748 $ctext conf
-state normal
4751 set info
$commitinfo($id)
4752 set date [formatdate
[lindex
$info 2]]
4753 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
4754 set date [formatdate
[lindex
$info 4]]
4755 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
4756 if {[info exists idtags
($id)]} {
4757 $ctext insert end
[mc
"Tags:"]
4758 foreach tag
$idtags($id) {
4759 $ctext insert end
" $tag"
4761 $ctext insert end
"\n"
4765 set olds
[lindex
$parentlist $l]
4766 if {[llength
$olds] > 1} {
4769 if {$np >= $mergemax} {
4774 $ctext insert end
"[mc "Parent
"]: " $tag
4775 appendwithlinks
[commit_descriptor
$p] {}
4780 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
4784 foreach c
$children($curview,$id) {
4785 append headers
"[mc "Child
"]: [commit_descriptor $c]"
4788 # make anything that looks like a SHA1 ID be a clickable link
4789 appendwithlinks
$headers {}
4790 if {$showneartags} {
4791 if {![info exists allcommits
]} {
4794 $ctext insert end
"[mc "Branch
"]: "
4795 $ctext mark
set branch
"end -1c"
4796 $ctext mark gravity branch left
4797 $ctext insert end
"\n[mc "Follows
"]: "
4798 $ctext mark
set follows
"end -1c"
4799 $ctext mark gravity follows left
4800 $ctext insert end
"\n[mc "Precedes
"]: "
4801 $ctext mark
set precedes
"end -1c"
4802 $ctext mark gravity precedes left
4803 $ctext insert end
"\n"
4806 $ctext insert end
"\n"
4807 set comment
[lindex
$info 5]
4808 if {[string first
"\r" $comment] >= 0} {
4809 set comment
[string map
{"\r" "\n "} $comment]
4811 appendwithlinks
$comment {comment
}
4813 $ctext tag remove found
1.0 end
4814 $ctext conf
-state disabled
4815 set commentend
[$ctext index
"end - 1c"]
4817 init_flist
[mc
"Comments"]
4818 if {$cmitmode eq
"tree"} {
4820 } elseif
{[llength
$olds] <= 1} {
4827 proc selfirstline
{} {
4832 proc sellastline
{} {
4835 set l
[expr {$numcommits - 1}]
4839 proc selnextline
{dir
} {
4842 if {![info exists selectedline
]} return
4843 set l
[expr {$selectedline + $dir}]
4848 proc selnextpage
{dir
} {
4849 global canv linespc selectedline numcommits
4851 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
4855 allcanvs yview scroll
[expr {$dir * $lpp}] units
4857 if {![info exists selectedline
]} return
4858 set l
[expr {$selectedline + $dir * $lpp}]
4861 } elseif
{$l >= $numcommits} {
4862 set l
[expr $numcommits - 1]
4868 proc unselectline
{} {
4869 global selectedline currentid
4871 catch
{unset selectedline
}
4872 catch
{unset currentid
}
4873 allcanvs delete secsel
4877 proc reselectline
{} {
4880 if {[info exists selectedline
]} {
4881 selectline
$selectedline 0
4885 proc addtohistory
{cmd
} {
4886 global
history historyindex curview
4888 set elt
[list
$curview $cmd]
4889 if {$historyindex > 0
4890 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
4894 if {$historyindex < [llength
$history]} {
4895 set history [lreplace
$history $historyindex end
$elt]
4897 lappend
history $elt
4900 if {$historyindex > 1} {
4901 .tf.bar.leftbut conf
-state normal
4903 .tf.bar.leftbut conf
-state disabled
4905 .tf.bar.rightbut conf
-state disabled
4911 set view
[lindex
$elt 0]
4912 set cmd
[lindex
$elt 1]
4913 if {$curview != $view} {
4920 global
history historyindex
4923 if {$historyindex > 1} {
4924 incr historyindex
-1
4925 godo
[lindex
$history [expr {$historyindex - 1}]]
4926 .tf.bar.rightbut conf
-state normal
4928 if {$historyindex <= 1} {
4929 .tf.bar.leftbut conf
-state disabled
4934 global
history historyindex
4937 if {$historyindex < [llength
$history]} {
4938 set cmd
[lindex
$history $historyindex]
4941 .tf.bar.leftbut conf
-state normal
4943 if {$historyindex >= [llength
$history]} {
4944 .tf.bar.rightbut conf
-state disabled
4949 global treefilelist treeidlist diffids diffmergeid treepending
4950 global nullid nullid2
4953 catch
{unset diffmergeid
}
4954 if {![info exists treefilelist
($id)]} {
4955 if {![info exists treepending
]} {
4956 if {$id eq
$nullid} {
4957 set cmd
[list | git ls-files
]
4958 } elseif
{$id eq
$nullid2} {
4959 set cmd
[list | git ls-files
--stage -t]
4961 set cmd
[list | git ls-tree
-r $id]
4963 if {[catch
{set gtf
[open
$cmd r
]}]} {
4967 set treefilelist
($id) {}
4968 set treeidlist
($id) {}
4969 fconfigure
$gtf -blocking 0
4970 filerun
$gtf [list gettreeline
$gtf $id]
4977 proc gettreeline
{gtf id
} {
4978 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4981 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
4982 if {$diffids eq
$nullid} {
4985 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
4986 set i
[string first
"\t" $line]
4987 if {$i < 0} continue
4988 set sha1
[lindex
$line 2]
4989 set fname
[string range
$line [expr {$i+1}] end
]
4990 if {[string index
$fname 0] eq
"\""} {
4991 set fname
[lindex
$fname 0]
4993 lappend treeidlist
($id) $sha1
4995 lappend treefilelist
($id) $fname
4998 return [expr {$nl >= 1000?
2: 1}]
5002 if {$cmitmode ne
"tree"} {
5003 if {![info exists diffmergeid
]} {
5004 gettreediffs
$diffids
5006 } elseif
{$id ne
$diffids} {
5015 global treefilelist treeidlist diffids nullid nullid2
5016 global ctext commentend
5018 set i
[lsearch
-exact $treefilelist($diffids) $f]
5020 puts
"oops, $f not in list for id $diffids"
5023 if {$diffids eq
$nullid} {
5024 if {[catch
{set bf
[open
$f r
]} err
]} {
5025 puts
"oops, can't read $f: $err"
5029 set blob
[lindex
$treeidlist($diffids) $i]
5030 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
5031 puts
"oops, error reading blob $blob: $err"
5035 fconfigure
$bf -blocking 0
5036 filerun
$bf [list getblobline
$bf $diffids]
5037 $ctext config
-state normal
5038 clear_ctext
$commentend
5039 $ctext insert end
"\n"
5040 $ctext insert end
"$f\n" filesep
5041 $ctext config
-state disabled
5042 $ctext yview
$commentend
5046 proc getblobline
{bf id
} {
5047 global diffids cmitmode ctext
5049 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5053 $ctext config
-state normal
5055 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5056 $ctext insert end
"$line\n"
5059 # delete last newline
5060 $ctext delete
"end - 2c" "end - 1c"
5064 $ctext config
-state disabled
5065 return [expr {$nl >= 1000?
2: 1}]
5068 proc mergediff
{id l
} {
5069 global diffmergeid mdifffd
5073 global limitdiffs viewfiles curview
5077 # this doesn't seem to actually affect anything...
5078 set cmd
[concat | git diff-tree
--no-commit-id --cc -U$diffcontext $id]
5079 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5080 set cmd
[concat
$cmd -- $viewfiles($curview)]
5082 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5083 error_popup
"[mc "Error getting merge diffs
:"] $err"
5086 fconfigure
$mdf -blocking 0
5087 set mdifffd
($id) $mdf
5088 set np
[llength
[lindex
$parentlist $l]]
5090 filerun
$mdf [list getmergediffline
$mdf $id $np]
5093 proc getmergediffline
{mdf id np
} {
5094 global diffmergeid ctext cflist mergemax
5095 global difffilestart mdifffd
5097 $ctext conf
-state normal
5099 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5100 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5101 ||
$mdf != $mdifffd($id)} {
5105 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5106 # start of a new file
5107 $ctext insert end
"\n"
5108 set here
[$ctext index
"end - 1c"]
5109 lappend difffilestart
$here
5110 add_flist
[list
$fname]
5111 set l
[expr {(78 - [string length
$fname]) / 2}]
5112 set pad
[string range
"----------------------------------------" 1 $l]
5113 $ctext insert end
"$pad $fname $pad\n" filesep
5114 } elseif
{[regexp
{^@@
} $line]} {
5115 $ctext insert end
"$line\n" hunksep
5116 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5119 # parse the prefix - one ' ', '-' or '+' for each parent
5124 for {set j
0} {$j < $np} {incr j
} {
5125 set c
[string range
$line $j $j]
5128 } elseif
{$c == "-"} {
5130 } elseif
{$c == "+"} {
5139 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5140 # line doesn't appear in result, parents in $minuses have the line
5141 set num
[lindex
$minuses 0]
5142 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5143 # line appears in result, parents in $pluses don't have the line
5144 lappend tags mresult
5145 set num
[lindex
$spaces 0]
5148 if {$num >= $mergemax} {
5153 $ctext insert end
"$line\n" $tags
5156 $ctext conf
-state disabled
5161 return [expr {$nr >= 1000?
2: 1}]
5164 proc startdiff
{ids
} {
5165 global treediffs diffids treepending diffmergeid nullid nullid2
5169 catch
{unset diffmergeid
}
5170 if {![info exists treediffs
($ids)] ||
5171 [lsearch
-exact $ids $nullid] >= 0 ||
5172 [lsearch
-exact $ids $nullid2] >= 0} {
5173 if {![info exists treepending
]} {
5181 proc path_filter
{filter name
} {
5183 set l
[string length
$p]
5184 if {[string index
$p end
] eq
"/"} {
5185 if {[string compare
-length $l $p $name] == 0} {
5189 if {[string compare
-length $l $p $name] == 0 &&
5190 ([string length
$name] == $l ||
5191 [string index
$name $l] eq
"/")} {
5199 proc addtocflist
{ids
} {
5202 add_flist
$treediffs($ids)
5206 proc diffcmd
{ids flags
} {
5207 global nullid nullid2
5209 set i
[lsearch
-exact $ids $nullid]
5210 set j
[lsearch
-exact $ids $nullid2]
5212 if {[llength
$ids] > 1 && $j < 0} {
5213 # comparing working directory with some specific revision
5214 set cmd
[concat | git diff-index
$flags]
5216 lappend cmd
-R [lindex
$ids 1]
5218 lappend cmd
[lindex
$ids 0]
5221 # comparing working directory with index
5222 set cmd
[concat | git diff-files
$flags]
5227 } elseif
{$j >= 0} {
5228 set cmd
[concat | git diff-index
--cached $flags]
5229 if {[llength
$ids] > 1} {
5230 # comparing index with specific revision
5232 lappend cmd
-R [lindex
$ids 1]
5234 lappend cmd
[lindex
$ids 0]
5237 # comparing index with HEAD
5241 set cmd
[concat | git diff-tree
-r $flags $ids]
5246 proc gettreediffs
{ids
} {
5247 global treediff treepending
5249 set treepending
$ids
5251 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5252 fconfigure
$gdtf -blocking 0
5253 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5256 proc gettreediffline
{gdtf ids
} {
5257 global treediff treediffs treepending diffids diffmergeid
5258 global cmitmode viewfiles curview limitdiffs
5261 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5262 set i
[string first
"\t" $line]
5264 set file [string range
$line [expr {$i+1}] end
]
5265 if {[string index
$file 0] eq
"\""} {
5266 set file [lindex
$file 0]
5268 lappend treediff
$file
5272 return [expr {$nr >= 1000?
2: 1}]
5275 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5277 foreach f
$treediff {
5278 if {[path_filter
$viewfiles($curview) $f]} {
5282 set treediffs
($ids) $flist
5284 set treediffs
($ids) $treediff
5287 if {$cmitmode eq
"tree"} {
5289 } elseif
{$ids != $diffids} {
5290 if {![info exists diffmergeid
]} {
5291 gettreediffs
$diffids
5299 # empty string or positive integer
5300 proc diffcontextvalidate
{v
} {
5301 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5304 proc diffcontextchange
{n1 n2 op
} {
5305 global diffcontextstring diffcontext
5307 if {[string is integer
-strict $diffcontextstring]} {
5308 if {$diffcontextstring > 0} {
5309 set diffcontext
$diffcontextstring
5315 proc changeignorespace
{} {
5319 proc getblobdiffs
{ids
} {
5320 global blobdifffd diffids env
5321 global diffinhdr treediffs
5324 global limitdiffs viewfiles curview
5326 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5330 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5331 set cmd
[concat
$cmd -- $viewfiles($curview)]
5333 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5334 puts
"error getting diffs: $err"
5338 fconfigure
$bdf -blocking 0
5339 set blobdifffd
($ids) $bdf
5340 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5343 proc setinlist
{var i val
} {
5346 while {[llength
[set $var]] < $i} {
5349 if {[llength
[set $var]] == $i} {
5356 proc makediffhdr
{fname ids
} {
5357 global ctext curdiffstart treediffs
5359 set i
[lsearch
-exact $treediffs($ids) $fname]
5361 setinlist difffilestart
$i $curdiffstart
5363 set l
[expr {(78 - [string length
$fname]) / 2}]
5364 set pad
[string range
"----------------------------------------" 1 $l]
5365 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5368 proc getblobdiffline
{bdf ids
} {
5369 global diffids blobdifffd ctext curdiffstart
5370 global diffnexthead diffnextnote difffilestart
5371 global diffinhdr treediffs
5374 $ctext conf
-state normal
5375 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5376 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5380 if {![string compare
-length 11 "diff --git " $line]} {
5381 # trim off "diff --git "
5382 set line
[string range
$line 11 end
]
5384 # start of a new file
5385 $ctext insert end
"\n"
5386 set curdiffstart
[$ctext index
"end - 1c"]
5387 $ctext insert end
"\n" filesep
5388 # If the name hasn't changed the length will be odd,
5389 # the middle char will be a space, and the two bits either
5390 # side will be a/name and b/name, or "a/name" and "b/name".
5391 # If the name has changed we'll get "rename from" and
5392 # "rename to" or "copy from" and "copy to" lines following this,
5393 # and we'll use them to get the filenames.
5394 # This complexity is necessary because spaces in the filename(s)
5395 # don't get escaped.
5396 set l
[string length
$line]
5397 set i
[expr {$l / 2}]
5398 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5399 [string range
$line 2 [expr {$i - 1}]] eq \
5400 [string range
$line [expr {$i + 3}] end
])} {
5403 # unescape if quoted and chop off the a/ from the front
5404 if {[string index
$line 0] eq
"\""} {
5405 set fname
[string range
[lindex
$line 0] 2 end
]
5407 set fname
[string range
$line 2 [expr {$i - 1}]]
5409 makediffhdr
$fname $ids
5411 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5412 $line match f1l f1c f2l f2c rest
]} {
5413 $ctext insert end
"$line\n" hunksep
5416 } elseif
{$diffinhdr} {
5417 if {![string compare
-length 12 "rename from " $line]} {
5418 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5419 if {[string index
$fname 0] eq
"\""} {
5420 set fname
[lindex
$fname 0]
5422 set i
[lsearch
-exact $treediffs($ids) $fname]
5424 setinlist difffilestart
$i $curdiffstart
5426 } elseif
{![string compare
-length 10 $line "rename to "] ||
5427 ![string compare
-length 8 $line "copy to "]} {
5428 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
5429 if {[string index
$fname 0] eq
"\""} {
5430 set fname
[lindex
$fname 0]
5432 makediffhdr
$fname $ids
5433 } elseif
{[string compare
-length 3 $line "---"] == 0} {
5436 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
5440 $ctext insert end
"$line\n" filesep
5443 set x
[string range
$line 0 0]
5444 if {$x == "-" ||
$x == "+"} {
5445 set tag
[expr {$x == "+"}]
5446 $ctext insert end
"$line\n" d
$tag
5447 } elseif
{$x == " "} {
5448 $ctext insert end
"$line\n"
5450 # "\ No newline at end of file",
5451 # or something else we don't recognize
5452 $ctext insert end
"$line\n" hunksep
5456 $ctext conf
-state disabled
5461 return [expr {$nr >= 1000?
2: 1}]
5464 proc changediffdisp
{} {
5465 global ctext diffelide
5467 $ctext tag conf d0
-elide [lindex
$diffelide 0]
5468 $ctext tag conf d1
-elide [lindex
$diffelide 1]
5472 global difffilestart ctext
5473 set prev
[lindex
$difffilestart 0]
5474 set here
[$ctext index @
0,0]
5475 foreach loc
$difffilestart {
5476 if {[$ctext compare
$loc >= $here]} {
5486 global difffilestart ctext
5487 set here
[$ctext index @
0,0]
5488 foreach loc
$difffilestart {
5489 if {[$ctext compare
$loc > $here]} {
5496 proc clear_ctext
{{first
1.0}} {
5497 global ctext smarktop smarkbot
5500 set l
[lindex
[split $first .
] 0]
5501 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
5504 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
5507 $ctext delete
$first end
5508 if {$first eq
"1.0"} {
5509 catch
{unset pendinglinks
}
5513 proc settabs
{{firstab
{}}} {
5514 global firsttabstop tabstop ctext have_tk85
5516 if {$firstab ne
{} && $have_tk85} {
5517 set firsttabstop
$firstab
5519 set w
[font measure textfont
"0"]
5520 if {$firsttabstop != 0} {
5521 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
5522 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5523 } elseif
{$have_tk85 ||
$tabstop != 8} {
5524 $ctext conf
-tabs [expr {$tabstop * $w}]
5526 $ctext conf
-tabs {}
5530 proc incrsearch
{name ix op
} {
5531 global ctext searchstring searchdirn
5533 $ctext tag remove found
1.0 end
5534 if {[catch
{$ctext index anchor
}]} {
5535 # no anchor set, use start of selection, or of visible area
5536 set sel
[$ctext tag ranges sel
]
5538 $ctext mark
set anchor
[lindex
$sel 0]
5539 } elseif
{$searchdirn eq
"-forwards"} {
5540 $ctext mark
set anchor @
0,0
5542 $ctext mark
set anchor @
0,[winfo height
$ctext]
5545 if {$searchstring ne
{}} {
5546 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
5555 global sstring ctext searchstring searchdirn
5558 $sstring icursor end
5559 set searchdirn
-forwards
5560 if {$searchstring ne
{}} {
5561 set sel
[$ctext tag ranges sel
]
5563 set start
"[lindex $sel 0] + 1c"
5564 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5567 set match
[$ctext search
-count mlen
-- $searchstring $start]
5568 $ctext tag remove sel
1.0 end
5574 set mend
"$match + $mlen c"
5575 $ctext tag add sel
$match $mend
5576 $ctext mark
unset anchor
5580 proc dosearchback
{} {
5581 global sstring ctext searchstring searchdirn
5584 $sstring icursor end
5585 set searchdirn
-backwards
5586 if {$searchstring ne
{}} {
5587 set sel
[$ctext tag ranges sel
]
5589 set start
[lindex
$sel 0]
5590 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5591 set start @
0,[winfo height
$ctext]
5593 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
5594 $ctext tag remove sel
1.0 end
5600 set mend
"$match + $ml c"
5601 $ctext tag add sel
$match $mend
5602 $ctext mark
unset anchor
5606 proc searchmark
{first last
} {
5607 global ctext searchstring
5611 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
5612 if {$match eq
{}} break
5613 set mend
"$match + $mlen c"
5614 $ctext tag add found
$match $mend
5618 proc searchmarkvisible
{doall
} {
5619 global ctext smarktop smarkbot
5621 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
5622 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
5623 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
5624 # no overlap with previous
5625 searchmark
$topline $botline
5626 set smarktop
$topline
5627 set smarkbot
$botline
5629 if {$topline < $smarktop} {
5630 searchmark
$topline [expr {$smarktop-1}]
5631 set smarktop
$topline
5633 if {$botline > $smarkbot} {
5634 searchmark
[expr {$smarkbot+1}] $botline
5635 set smarkbot
$botline
5640 proc scrolltext
{f0 f1
} {
5643 .bleft.sb
set $f0 $f1
5644 if {$searchstring ne
{}} {
5650 global linespc charspc canvx0 canvy0
5651 global xspc1 xspc2 lthickness
5653 set linespc
[font metrics mainfont
-linespace]
5654 set charspc
[font measure mainfont
"m"]
5655 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
5656 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
5657 set lthickness
[expr {int
($linespc / 9) + 1}]
5658 set xspc1
(0) $linespc
5666 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5667 if {$ymax eq
{} ||
$ymax == 0} return
5668 set span
[$canv yview
]
5671 allcanvs yview moveto
[lindex
$span 0]
5673 if {[info exists selectedline
]} {
5674 selectline
$selectedline 0
5675 allcanvs yview moveto
[lindex
$span 0]
5679 proc parsefont
{f n
} {
5682 set fontattr
($f,family
) [lindex
$n 0]
5684 if {$s eq
{} ||
$s == 0} {
5687 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
5689 set fontattr
($f,size
) $s
5690 set fontattr
($f,weight
) normal
5691 set fontattr
($f,slant
) roman
5692 foreach style
[lrange
$n 2 end
] {
5695 "bold" {set fontattr
($f,weight
) $style}
5697 "italic" {set fontattr
($f,slant
) $style}
5702 proc fontflags
{f
{isbold
0}} {
5705 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
5706 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
5707 -slant $fontattr($f,slant
)]
5713 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
5714 if {$fontattr($f,weight
) eq
"bold"} {
5717 if {$fontattr($f,slant
) eq
"italic"} {
5723 proc incrfont
{inc
} {
5724 global mainfont textfont ctext canv phase cflist showrefstop
5725 global stopped entries fontattr
5728 set s
$fontattr(mainfont
,size
)
5733 set fontattr
(mainfont
,size
) $s
5734 font config mainfont
-size $s
5735 font config mainfontbold
-size $s
5736 set mainfont
[fontname mainfont
]
5737 set s
$fontattr(textfont
,size
)
5742 set fontattr
(textfont
,size
) $s
5743 font config textfont
-size $s
5744 font config textfontbold
-size $s
5745 set textfont
[fontname textfont
]
5752 global sha1entry sha1string
5753 if {[string length
$sha1string] == 40} {
5754 $sha1entry delete
0 end
5758 proc sha1change
{n1 n2 op
} {
5759 global sha1string currentid sha1but
5760 if {$sha1string == {}
5761 ||
([info exists currentid
] && $sha1string == $currentid)} {
5766 if {[$sha1but cget
-state] == $state} return
5767 if {$state == "normal"} {
5768 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
5770 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
5774 proc gotocommit
{} {
5775 global sha1string currentid commitrow tagids headids
5776 global displayorder numcommits curview
5778 if {$sha1string == {}
5779 ||
([info exists currentid
] && $sha1string == $currentid)} return
5780 if {[info exists tagids
($sha1string)]} {
5781 set id
$tagids($sha1string)
5782 } elseif
{[info exists headids
($sha1string)]} {
5783 set id
$headids($sha1string)
5785 set id
[string tolower
$sha1string]
5786 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
5788 foreach i
$displayorder {
5789 if {[string match
$id* $i]} {
5793 if {$matches ne
{}} {
5794 if {[llength
$matches] > 1} {
5795 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
5798 set id
[lindex
$matches 0]
5802 if {[info exists commitrow
($curview,$id)]} {
5803 selectline
$commitrow($curview,$id) 1
5806 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
5807 set msg
[mc
"SHA1 id %s is not known" $sha1string]
5809 set msg
[mc
"Tag/Head %s is not known" $sha1string]
5814 proc lineenter
{x y id
} {
5815 global hoverx hovery hoverid hovertimer
5816 global commitinfo canv
5818 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5822 if {[info exists hovertimer
]} {
5823 after cancel
$hovertimer
5825 set hovertimer
[after
500 linehover
]
5829 proc linemotion
{x y id
} {
5830 global hoverx hovery hoverid hovertimer
5832 if {[info exists hoverid
] && $id == $hoverid} {
5835 if {[info exists hovertimer
]} {
5836 after cancel
$hovertimer
5838 set hovertimer
[after
500 linehover
]
5842 proc lineleave
{id
} {
5843 global hoverid hovertimer canv
5845 if {[info exists hoverid
] && $id == $hoverid} {
5847 if {[info exists hovertimer
]} {
5848 after cancel
$hovertimer
5856 global hoverx hovery hoverid hovertimer
5857 global canv linespc lthickness
5860 set text
[lindex
$commitinfo($hoverid) 0]
5861 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5862 if {$ymax == {}} return
5863 set yfrac
[lindex
[$canv yview
] 0]
5864 set x
[expr {$hoverx + 2 * $linespc}]
5865 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5866 set x0
[expr {$x - 2 * $lthickness}]
5867 set y0
[expr {$y - 2 * $lthickness}]
5868 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
5869 set y1
[expr {$y + $linespc + 2 * $lthickness}]
5870 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
5871 -fill \
#ffff80 -outline black -width 1 -tags hover]
5873 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
5878 proc clickisonarrow
{id y
} {
5881 set ranges
[rowranges
$id]
5882 set thresh
[expr {2 * $lthickness + 6}]
5883 set n
[expr {[llength
$ranges] - 1}]
5884 for {set i
1} {$i < $n} {incr i
} {
5885 set row
[lindex
$ranges $i]
5886 if {abs
([yc
$row] - $y) < $thresh} {
5893 proc arrowjump
{id n y
} {
5896 # 1 <-> 2, 3 <-> 4, etc...
5897 set n
[expr {(($n - 1) ^
1) + 1}]
5898 set row
[lindex
[rowranges
$id] $n]
5900 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5901 if {$ymax eq
{} ||
$ymax <= 0} return
5902 set view
[$canv yview
]
5903 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
5904 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
5908 allcanvs yview moveto
$yfrac
5911 proc lineclick
{x y id isnew
} {
5912 global ctext commitinfo children canv thickerline curview commitrow
5914 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5919 # draw this line thicker than normal
5923 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5924 if {$ymax eq
{}} return
5925 set yfrac
[lindex
[$canv yview
] 0]
5926 set y
[expr {$y + $yfrac * $ymax}]
5928 set dirn
[clickisonarrow
$id $y]
5930 arrowjump
$id $dirn $y
5935 addtohistory
[list lineclick
$x $y $id 0]
5937 # fill the details pane with info about this line
5938 $ctext conf
-state normal
5941 $ctext insert end
"[mc "Parent
"]:\t"
5942 $ctext insert end
$id link0
5944 set info
$commitinfo($id)
5945 $ctext insert end
"\n\t[lindex $info 0]\n"
5946 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
5947 set date [formatdate
[lindex
$info 2]]
5948 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
5949 set kids
$children($curview,$id)
5951 $ctext insert end
"\n[mc "Children
"]:"
5953 foreach child
$kids {
5955 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
5956 set info
$commitinfo($child)
5957 $ctext insert end
"\n\t"
5958 $ctext insert end
$child link
$i
5959 setlink
$child link
$i
5960 $ctext insert end
"\n\t[lindex $info 0]"
5961 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
5962 set date [formatdate
[lindex
$info 2]]
5963 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
5966 $ctext conf
-state disabled
5970 proc normalline
{} {
5972 if {[info exists thickerline
]} {
5980 global commitrow curview
5981 if {[info exists commitrow
($curview,$id)]} {
5982 selectline
$commitrow($curview,$id) 1
5988 if {![info exists startmstime
]} {
5989 set startmstime
[clock clicks
-milliseconds]
5991 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
5994 proc rowmenu
{x y id
} {
5995 global rowctxmenu commitrow selectedline rowmenuid curview
5996 global nullid nullid2 fakerowmenu mainhead
6000 if {![info exists selectedline
]
6001 ||
$commitrow($curview,$id) eq
$selectedline} {
6006 if {$id ne
$nullid && $id ne
$nullid2} {
6007 set menu
$rowctxmenu
6008 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
6010 set menu
$fakerowmenu
6012 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
6013 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
6014 $menu entryconfigure
[mc
"Make patch"] -state $state
6015 tk_popup
$menu $x $y
6018 proc diffvssel
{dirn
} {
6019 global rowmenuid selectedline displayorder
6021 if {![info exists selectedline
]} return
6023 set oldid
[lindex
$displayorder $selectedline]
6024 set newid
$rowmenuid
6026 set oldid
$rowmenuid
6027 set newid
[lindex
$displayorder $selectedline]
6029 addtohistory
[list doseldiff
$oldid $newid]
6030 doseldiff
$oldid $newid
6033 proc doseldiff
{oldid newid
} {
6037 $ctext conf
-state normal
6039 init_flist
[mc
"Top"]
6040 $ctext insert end
"[mc "From
"] "
6041 $ctext insert end
$oldid link0
6042 setlink
$oldid link0
6043 $ctext insert end
"\n "
6044 $ctext insert end
[lindex
$commitinfo($oldid) 0]
6045 $ctext insert end
"\n\n[mc "To
"] "
6046 $ctext insert end
$newid link1
6047 setlink
$newid link1
6048 $ctext insert end
"\n "
6049 $ctext insert end
[lindex
$commitinfo($newid) 0]
6050 $ctext insert end
"\n"
6051 $ctext conf
-state disabled
6052 $ctext tag remove found
1.0 end
6053 startdiff
[list
$oldid $newid]
6057 global rowmenuid currentid commitinfo patchtop patchnum
6059 if {![info exists currentid
]} return
6060 set oldid
$currentid
6061 set oldhead
[lindex
$commitinfo($oldid) 0]
6062 set newid
$rowmenuid
6063 set newhead
[lindex
$commitinfo($newid) 0]
6066 catch
{destroy
$top}
6068 label
$top.title
-text [mc
"Generate patch"]
6069 grid
$top.title
- -pady 10
6070 label
$top.from
-text [mc
"From:"]
6071 entry
$top.fromsha1
-width 40 -relief flat
6072 $top.fromsha1 insert
0 $oldid
6073 $top.fromsha1 conf
-state readonly
6074 grid
$top.from
$top.fromsha1
-sticky w
6075 entry
$top.fromhead
-width 60 -relief flat
6076 $top.fromhead insert
0 $oldhead
6077 $top.fromhead conf
-state readonly
6078 grid x
$top.fromhead
-sticky w
6079 label
$top.to
-text [mc
"To:"]
6080 entry
$top.tosha1
-width 40 -relief flat
6081 $top.tosha1 insert
0 $newid
6082 $top.tosha1 conf
-state readonly
6083 grid
$top.to
$top.tosha1
-sticky w
6084 entry
$top.tohead
-width 60 -relief flat
6085 $top.tohead insert
0 $newhead
6086 $top.tohead conf
-state readonly
6087 grid x
$top.tohead
-sticky w
6088 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6089 grid
$top.
rev x
-pady 10
6090 label
$top.flab
-text [mc
"Output file:"]
6091 entry
$top.fname
-width 60
6092 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6094 grid
$top.flab
$top.fname
-sticky w
6096 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6097 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6098 grid
$top.buts.gen
$top.buts.can
6099 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6100 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6101 grid
$top.buts
- -pady 10 -sticky ew
6105 proc mkpatchrev
{} {
6108 set oldid
[$patchtop.fromsha1 get
]
6109 set oldhead
[$patchtop.fromhead get
]
6110 set newid
[$patchtop.tosha1 get
]
6111 set newhead
[$patchtop.tohead get
]
6112 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6113 v
[list
$newid $newhead $oldid $oldhead] {
6114 $patchtop.
$e conf
-state normal
6115 $patchtop.
$e delete
0 end
6116 $patchtop.
$e insert
0 $v
6117 $patchtop.
$e conf
-state readonly
6122 global patchtop nullid nullid2
6124 set oldid
[$patchtop.fromsha1 get
]
6125 set newid
[$patchtop.tosha1 get
]
6126 set fname
[$patchtop.fname get
]
6127 set cmd
[diffcmd
[list
$oldid $newid] -p]
6128 # trim off the initial "|"
6129 set cmd
[lrange
$cmd 1 end
]
6130 lappend cmd
>$fname &
6131 if {[catch
{eval exec $cmd} err
]} {
6132 error_popup
"[mc "Error creating
patch:"] $err"
6134 catch
{destroy
$patchtop}
6138 proc mkpatchcan
{} {
6141 catch
{destroy
$patchtop}
6146 global rowmenuid mktagtop commitinfo
6150 catch
{destroy
$top}
6152 label
$top.title
-text [mc
"Create tag"]
6153 grid
$top.title
- -pady 10
6154 label
$top.id
-text [mc
"ID:"]
6155 entry
$top.sha1
-width 40 -relief flat
6156 $top.sha1 insert
0 $rowmenuid
6157 $top.sha1 conf
-state readonly
6158 grid
$top.id
$top.sha1
-sticky w
6159 entry
$top.
head -width 60 -relief flat
6160 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6161 $top.
head conf
-state readonly
6162 grid x
$top.
head -sticky w
6163 label
$top.tlab
-text [mc
"Tag name:"]
6164 entry
$top.tag
-width 60
6165 grid
$top.tlab
$top.tag
-sticky w
6167 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6168 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6169 grid
$top.buts.gen
$top.buts.can
6170 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6171 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6172 grid
$top.buts
- -pady 10 -sticky ew
6177 global mktagtop env tagids idtags
6179 set id
[$mktagtop.sha1 get
]
6180 set tag
[$mktagtop.tag get
]
6182 error_popup
[mc
"No tag name specified"]
6185 if {[info exists tagids
($tag)]} {
6186 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6190 exec git tag
$tag $id
6192 error_popup
"[mc "Error creating tag
:"] $err"
6196 set tagids
($tag) $id
6197 lappend idtags
($id) $tag
6204 proc redrawtags
{id
} {
6205 global canv linehtag commitrow idpos selectedline curview
6206 global canvxmax iddrawn
6208 if {![info exists commitrow
($curview,$id)]} return
6209 if {![info exists iddrawn
($id)]} return
6210 drawcommits
$commitrow($curview,$id)
6211 $canv delete tag.
$id
6212 set xt
[eval drawtags
$id $idpos($id)]
6213 $canv coords
$linehtag($commitrow($curview,$id)) $xt [lindex
$idpos($id) 2]
6214 set text
[$canv itemcget
$linehtag($commitrow($curview,$id)) -text]
6215 set xr
[expr {$xt + [font measure mainfont
$text]}]
6216 if {$xr > $canvxmax} {
6220 if {[info exists selectedline
]
6221 && $selectedline == $commitrow($curview,$id)} {
6222 selectline
$selectedline 0
6229 catch
{destroy
$mktagtop}
6238 proc writecommit
{} {
6239 global rowmenuid wrcomtop commitinfo wrcomcmd
6241 set top .writecommit
6243 catch
{destroy
$top}
6245 label
$top.title
-text [mc
"Write commit to file"]
6246 grid
$top.title
- -pady 10
6247 label
$top.id
-text [mc
"ID:"]
6248 entry
$top.sha1
-width 40 -relief flat
6249 $top.sha1 insert
0 $rowmenuid
6250 $top.sha1 conf
-state readonly
6251 grid
$top.id
$top.sha1
-sticky w
6252 entry
$top.
head -width 60 -relief flat
6253 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6254 $top.
head conf
-state readonly
6255 grid x
$top.
head -sticky w
6256 label
$top.clab
-text [mc
"Command:"]
6257 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6258 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6259 label
$top.flab
-text [mc
"Output file:"]
6260 entry
$top.fname
-width 60
6261 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6262 grid
$top.flab
$top.fname
-sticky w
6264 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6265 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6266 grid
$top.buts.gen
$top.buts.can
6267 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6268 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6269 grid
$top.buts
- -pady 10 -sticky ew
6276 set id
[$wrcomtop.sha1 get
]
6277 set cmd
"echo $id | [$wrcomtop.cmd get]"
6278 set fname
[$wrcomtop.fname get
]
6279 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6280 error_popup
"[mc "Error writing commit
:"] $err"
6282 catch
{destroy
$wrcomtop}
6289 catch
{destroy
$wrcomtop}
6294 global rowmenuid mkbrtop
6297 catch
{destroy
$top}
6299 label
$top.title
-text [mc
"Create new branch"]
6300 grid
$top.title
- -pady 10
6301 label
$top.id
-text [mc
"ID:"]
6302 entry
$top.sha1
-width 40 -relief flat
6303 $top.sha1 insert
0 $rowmenuid
6304 $top.sha1 conf
-state readonly
6305 grid
$top.id
$top.sha1
-sticky w
6306 label
$top.nlab
-text [mc
"Name:"]
6307 entry
$top.name
-width 40
6308 grid
$top.nlab
$top.name
-sticky w
6310 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6311 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6312 grid
$top.buts.go
$top.buts.can
6313 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6314 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6315 grid
$top.buts
- -pady 10 -sticky ew
6320 global headids idheads
6322 set name
[$top.name get
]
6323 set id
[$top.sha1 get
]
6325 error_popup
[mc
"Please specify a name for the new branch"]
6328 catch
{destroy
$top}
6332 exec git branch
$name $id
6337 set headids
($name) $id
6338 lappend idheads
($id) $name
6347 proc cherrypick
{} {
6348 global rowmenuid curview commitrow
6351 set oldhead
[exec git rev-parse HEAD
]
6352 set dheads
[descheads
$rowmenuid]
6353 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6354 set ok
[confirm_popup
[mc
"Commit %s is already\
6355 included in branch %s -- really re-apply it?" \
6356 [string range
$rowmenuid 0 7] $mainhead]]
6359 nowbusy cherrypick
[mc
"Cherry-picking"]
6361 # Unfortunately git-cherry-pick writes stuff to stderr even when
6362 # no error occurs, and exec takes that as an indication of error...
6363 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6368 set newhead
[exec git rev-parse HEAD
]
6369 if {$newhead eq
$oldhead} {
6371 error_popup
[mc
"No changes committed"]
6374 addnewchild
$newhead $oldhead
6375 if {[info exists commitrow
($curview,$oldhead)]} {
6376 insertrow
$commitrow($curview,$oldhead) $newhead
6377 if {$mainhead ne
{}} {
6378 movehead
$newhead $mainhead
6379 movedhead
$newhead $mainhead
6388 global mainheadid mainhead rowmenuid confirm_ok resettype
6391 set w
".confirmreset"
6394 wm title
$w [mc
"Confirm reset"]
6395 message
$w.m
-text \
6396 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6397 -justify center
-aspect 1000
6398 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6399 frame
$w.f
-relief sunken
-border 2
6400 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6401 grid
$w.f.rt
-sticky w
6403 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6404 -text [mc
"Soft: Leave working tree and index untouched"]
6405 grid
$w.f.soft
-sticky w
6406 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6407 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6408 grid
$w.f.mixed
-sticky w
6409 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6410 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6411 grid
$w.f.hard
-sticky w
6412 pack
$w.f
-side top
-fill x
6413 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6414 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6415 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6416 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6417 bind $w <Visibility
> "grab $w; focus $w"
6419 if {!$confirm_ok} return
6420 if {[catch
{set fd
[open \
6421 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
6425 filerun
$fd [list readresetstat
$fd]
6426 nowbusy
reset [mc
"Resetting"]
6430 proc readresetstat
{fd
} {
6431 global mainhead mainheadid showlocalchanges rprogcoord
6433 if {[gets
$fd line
] >= 0} {
6434 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
6435 set rprogcoord
[expr {1.0 * $m / $n}]
6443 if {[catch
{close
$fd} err
]} {
6446 set oldhead
$mainheadid
6447 set newhead
[exec git rev-parse HEAD
]
6448 if {$newhead ne
$oldhead} {
6449 movehead
$newhead $mainhead
6450 movedhead
$newhead $mainhead
6451 set mainheadid
$newhead
6455 if {$showlocalchanges} {
6461 # context menu for a head
6462 proc headmenu
{x y id
head} {
6463 global headmenuid headmenuhead headctxmenu mainhead
6467 set headmenuhead
$head
6469 if {$head eq
$mainhead} {
6472 $headctxmenu entryconfigure
0 -state $state
6473 $headctxmenu entryconfigure
1 -state $state
6474 tk_popup
$headctxmenu $x $y
6478 global headmenuid headmenuhead mainhead headids
6479 global showlocalchanges mainheadid
6481 # check the tree is clean first??
6482 set oldmainhead
$mainhead
6483 nowbusy checkout
[mc
"Checking out"]
6487 exec git checkout
-q $headmenuhead
6493 set mainhead
$headmenuhead
6494 set mainheadid
$headmenuid
6495 if {[info exists headids
($oldmainhead)]} {
6496 redrawtags
$headids($oldmainhead)
6498 redrawtags
$headmenuid
6500 if {$showlocalchanges} {
6506 global headmenuid headmenuhead mainhead
6509 set head $headmenuhead
6511 # this check shouldn't be needed any more...
6512 if {$head eq
$mainhead} {
6513 error_popup
[mc
"Cannot delete the currently checked-out branch"]
6516 set dheads
[descheads
$id]
6517 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
6518 # the stuff on this branch isn't on any other branch
6519 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
6520 branch.\nReally delete branch %s?" $head $head]]} return
6524 if {[catch
{exec git branch
-D $head} err
]} {
6529 removehead
$id $head
6530 removedhead
$id $head
6537 # Display a list of tags and heads
6539 global showrefstop bgcolor fgcolor selectbgcolor
6540 global bglist fglist reflistfilter reflist maincursor
6543 set showrefstop
$top
6544 if {[winfo exists
$top]} {
6550 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
6551 text
$top.list
-background $bgcolor -foreground $fgcolor \
6552 -selectbackground $selectbgcolor -font mainfont \
6553 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6554 -width 30 -height 20 -cursor $maincursor \
6555 -spacing1 1 -spacing3 1 -state disabled
6556 $top.list tag configure highlight
-background $selectbgcolor
6557 lappend bglist
$top.list
6558 lappend fglist
$top.list
6559 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
6560 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
6561 grid
$top.list
$top.ysb
-sticky nsew
6562 grid
$top.xsb x
-sticky ew
6564 label
$top.f.l
-text "[mc "Filter
"]: "
6565 entry
$top.f.e
-width 20 -textvariable reflistfilter
6566 set reflistfilter
"*"
6567 trace add variable reflistfilter
write reflistfilter_change
6568 pack
$top.f.e
-side right
-fill x
-expand 1
6569 pack
$top.f.l
-side left
6570 grid
$top.f
- -sticky ew
-pady 2
6571 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
6573 grid columnconfigure
$top 0 -weight 1
6574 grid rowconfigure
$top 0 -weight 1
6575 bind $top.list
<1> {break}
6576 bind $top.list
<B1-Motion
> {break}
6577 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
6582 proc sel_reflist
{w x y
} {
6583 global showrefstop reflist headids tagids otherrefids
6585 if {![winfo exists
$showrefstop]} return
6586 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
6587 set ref
[lindex
$reflist [expr {$l-1}]]
6588 set n
[lindex
$ref 0]
6589 switch
-- [lindex
$ref 1] {
6590 "H" {selbyid
$headids($n)}
6591 "T" {selbyid
$tagids($n)}
6592 "o" {selbyid
$otherrefids($n)}
6594 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
6597 proc unsel_reflist
{} {
6600 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6601 $showrefstop.list tag remove highlight
0.0 end
6604 proc reflistfilter_change
{n1 n2 op
} {
6605 global reflistfilter
6607 after cancel refill_reflist
6608 after
200 refill_reflist
6611 proc refill_reflist
{} {
6612 global reflist reflistfilter showrefstop headids tagids otherrefids
6613 global commitrow curview commitinterest
6615 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6617 foreach n
[array names headids
] {
6618 if {[string match
$reflistfilter $n]} {
6619 if {[info exists commitrow
($curview,$headids($n))]} {
6620 lappend refs
[list
$n H
]
6622 set commitinterest
($headids($n)) {run refill_reflist
}
6626 foreach n
[array names tagids
] {
6627 if {[string match
$reflistfilter $n]} {
6628 if {[info exists commitrow
($curview,$tagids($n))]} {
6629 lappend refs
[list
$n T
]
6631 set commitinterest
($tagids($n)) {run refill_reflist
}
6635 foreach n
[array names otherrefids
] {
6636 if {[string match
$reflistfilter $n]} {
6637 if {[info exists commitrow
($curview,$otherrefids($n))]} {
6638 lappend refs
[list
$n o
]
6640 set commitinterest
($otherrefids($n)) {run refill_reflist
}
6644 set refs
[lsort
-index 0 $refs]
6645 if {$refs eq
$reflist} return
6647 # Update the contents of $showrefstop.list according to the
6648 # differences between $reflist (old) and $refs (new)
6649 $showrefstop.list conf
-state normal
6650 $showrefstop.list insert end
"\n"
6653 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
6654 if {$i < [llength
$reflist]} {
6655 if {$j < [llength
$refs]} {
6656 set cmp [string compare
[lindex
$reflist $i 0] \
6657 [lindex
$refs $j 0]]
6659 set cmp [string compare
[lindex
$reflist $i 1] \
6660 [lindex
$refs $j 1]]
6670 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
6678 set l
[expr {$j + 1}]
6679 $showrefstop.list image create
$l.0 -align baseline \
6680 -image reficon-
[lindex
$refs $j 1] -padx 2
6681 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
6687 # delete last newline
6688 $showrefstop.list delete end-2c end-1c
6689 $showrefstop.list conf
-state disabled
6692 # Stuff for finding nearby tags
6693 proc getallcommits
{} {
6694 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6695 global idheads idtags idotherrefs allparents tagobjid
6697 if {![info exists allcommits
]} {
6703 set allccache
[file join [gitdir
] "gitk.cache"]
6705 set f
[open
$allccache r
]
6714 set cmd
[list | git rev-list
--parents]
6715 set allcupdate
[expr {$seeds ne
{}}]
6719 set refs
[concat
[array names idheads
] [array names idtags
] \
6720 [array names idotherrefs
]]
6723 foreach name
[array names tagobjid
] {
6724 lappend tagobjs
$tagobjid($name)
6726 foreach id
[lsort
-unique $refs] {
6727 if {![info exists allparents
($id)] &&
6728 [lsearch
-exact $tagobjs $id] < 0} {
6739 set fd
[open
[concat
$cmd $ids] r
]
6740 fconfigure
$fd -blocking 0
6743 filerun
$fd [list getallclines
$fd]
6749 # Since most commits have 1 parent and 1 child, we group strings of
6750 # such commits into "arcs" joining branch/merge points (BMPs), which
6751 # are commits that either don't have 1 parent or don't have 1 child.
6753 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6754 # arcout(id) - outgoing arcs for BMP
6755 # arcids(a) - list of IDs on arc including end but not start
6756 # arcstart(a) - BMP ID at start of arc
6757 # arcend(a) - BMP ID at end of arc
6758 # growing(a) - arc a is still growing
6759 # arctags(a) - IDs out of arcids (excluding end) that have tags
6760 # archeads(a) - IDs out of arcids (excluding end) that have heads
6761 # The start of an arc is at the descendent end, so "incoming" means
6762 # coming from descendents, and "outgoing" means going towards ancestors.
6764 proc getallclines
{fd
} {
6765 global allparents allchildren idtags idheads nextarc
6766 global arcnos arcids arctags arcout arcend arcstart archeads growing
6767 global seeds allcommits cachedarcs allcupdate
6770 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
6771 set id
[lindex
$line 0]
6772 if {[info exists allparents
($id)]} {
6777 set olds
[lrange
$line 1 end
]
6778 set allparents
($id) $olds
6779 if {![info exists allchildren
($id)]} {
6780 set allchildren
($id) {}
6785 if {[llength
$olds] == 1 && [llength
$a] == 1} {
6786 lappend arcids
($a) $id
6787 if {[info exists idtags
($id)]} {
6788 lappend arctags
($a) $id
6790 if {[info exists idheads
($id)]} {
6791 lappend archeads
($a) $id
6793 if {[info exists allparents
($olds)]} {
6794 # seen parent already
6795 if {![info exists arcout
($olds)]} {
6798 lappend arcids
($a) $olds
6799 set arcend
($a) $olds
6802 lappend allchildren
($olds) $id
6803 lappend arcnos
($olds) $a
6807 foreach a
$arcnos($id) {
6808 lappend arcids
($a) $id
6815 lappend allchildren
($p) $id
6816 set a
[incr nextarc
]
6817 set arcstart
($a) $id
6824 if {[info exists allparents
($p)]} {
6825 # seen it already, may need to make a new branch
6826 if {![info exists arcout
($p)]} {
6829 lappend arcids
($a) $p
6833 lappend arcnos
($p) $a
6838 global cached_dheads cached_dtags cached_atags
6839 catch
{unset cached_dheads
}
6840 catch
{unset cached_dtags
}
6841 catch
{unset cached_atags
}
6844 return [expr {$nid >= 1000?
2: 1}]
6848 fconfigure
$fd -blocking 1
6851 # got an error reading the list of commits
6852 # if we were updating, try rereading the whole thing again
6858 error_popup
"[mc "Error reading commit topology information
;\
6859 branch and preceding
/following tag information\
6860 will be incomplete.
"]\n($err)"
6863 if {[incr allcommits
-1] == 0} {
6873 proc recalcarc
{a
} {
6874 global arctags archeads arcids idtags idheads
6878 foreach id
[lrange
$arcids($a) 0 end-1
] {
6879 if {[info exists idtags
($id)]} {
6882 if {[info exists idheads
($id)]} {
6887 set archeads
($a) $ah
6891 global arcnos arcids nextarc arctags archeads idtags idheads
6892 global arcstart arcend arcout allparents growing
6895 if {[llength
$a] != 1} {
6896 puts
"oops splitarc called but [llength $a] arcs already"
6900 set i
[lsearch
-exact $arcids($a) $p]
6902 puts
"oops splitarc $p not in arc $a"
6905 set na
[incr nextarc
]
6906 if {[info exists arcend
($a)]} {
6907 set arcend
($na) $arcend($a)
6909 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
6910 set j
[lsearch
-exact $arcnos($l) $a]
6911 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
6913 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
6914 set arcids
($a) [lrange
$arcids($a) 0 $i]
6916 set arcstart
($na) $p
6918 set arcids
($na) $tail
6919 if {[info exists growing
($a)]} {
6925 if {[llength
$arcnos($id)] == 1} {
6928 set j
[lsearch
-exact $arcnos($id) $a]
6929 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
6933 # reconstruct tags and heads lists
6934 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
6939 set archeads
($na) {}
6943 # Update things for a new commit added that is a child of one
6944 # existing commit. Used when cherry-picking.
6945 proc addnewchild
{id p
} {
6946 global allparents allchildren idtags nextarc
6947 global arcnos arcids arctags arcout arcend arcstart archeads growing
6948 global seeds allcommits
6950 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
6951 set allparents
($id) [list
$p]
6952 set allchildren
($id) {}
6955 lappend allchildren
($p) $id
6956 set a
[incr nextarc
]
6957 set arcstart
($a) $id
6960 set arcids
($a) [list
$p]
6962 if {![info exists arcout
($p)]} {
6965 lappend arcnos
($p) $a
6966 set arcout
($id) [list
$a]
6969 # This implements a cache for the topology information.
6970 # The cache saves, for each arc, the start and end of the arc,
6971 # the ids on the arc, and the outgoing arcs from the end.
6972 proc readcache
{f
} {
6973 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6974 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6979 if {$lim - $a > 500} {
6980 set lim
[expr {$a + 500}]
6984 # finish reading the cache and setting up arctags, etc.
6986 if {$line ne
"1"} {error
"bad final version"}
6988 foreach id
[array names idtags
] {
6989 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6990 [llength
$allparents($id)] == 1} {
6991 set a
[lindex
$arcnos($id) 0]
6992 if {$arctags($a) eq
{}} {
6997 foreach id
[array names idheads
] {
6998 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6999 [llength
$allparents($id)] == 1} {
7000 set a
[lindex
$arcnos($id) 0]
7001 if {$archeads($a) eq
{}} {
7006 foreach id
[lsort
-unique $possible_seeds] {
7007 if {$arcnos($id) eq
{}} {
7013 while {[incr a
] <= $lim} {
7015 if {[llength
$line] != 3} {error
"bad line"}
7016 set s
[lindex
$line 0]
7018 lappend arcout
($s) $a
7019 if {![info exists arcnos
($s)]} {
7020 lappend possible_seeds
$s
7023 set e
[lindex
$line 1]
7028 if {![info exists arcout
($e)]} {
7032 set arcids
($a) [lindex
$line 2]
7033 foreach id
$arcids($a) {
7034 lappend allparents
($s) $id
7036 lappend arcnos
($id) $a
7038 if {![info exists allparents
($s)]} {
7039 set allparents
($s) {}
7044 set nextarc
[expr {$a - 1}]
7057 global nextarc cachedarcs possible_seeds
7061 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7062 # make sure it's an integer
7063 set cachedarcs
[expr {int
([lindex
$line 1])}]
7064 if {$cachedarcs < 0} {error
"bad number of arcs"}
7066 set possible_seeds
{}
7074 proc dropcache
{err
} {
7075 global allcwait nextarc cachedarcs seeds
7077 #puts "dropping cache ($err)"
7078 foreach v
{arcnos arcout arcids arcstart arcend growing \
7079 arctags archeads allparents allchildren
} {
7090 proc writecache
{f
} {
7091 global cachearc cachedarcs allccache
7092 global arcstart arcend arcnos arcids arcout
7096 if {$lim - $a > 1000} {
7097 set lim
[expr {$a + 1000}]
7100 while {[incr a
] <= $lim} {
7101 if {[info exists arcend
($a)]} {
7102 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7104 puts
$f [list
$arcstart($a) {} $arcids($a)]
7109 catch
{file delete
$allccache}
7110 #puts "writing cache failed ($err)"
7113 set cachearc
[expr {$a - 1}]
7114 if {$a > $cachedarcs} {
7123 global nextarc cachedarcs cachearc allccache
7125 if {$nextarc == $cachedarcs} return
7127 set cachedarcs
$nextarc
7129 set f
[open
$allccache w
]
7130 puts
$f [list
1 $cachedarcs]
7135 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7136 # or 0 if neither is true.
7137 proc anc_or_desc
{a b
} {
7138 global arcout arcstart arcend arcnos cached_isanc
7140 if {$arcnos($a) eq
$arcnos($b)} {
7141 # Both are on the same arc(s); either both are the same BMP,
7142 # or if one is not a BMP, the other is also not a BMP or is
7143 # the BMP at end of the arc (and it only has 1 incoming arc).
7144 # Or both can be BMPs with no incoming arcs.
7145 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7148 # assert {[llength $arcnos($a)] == 1}
7149 set arc
[lindex
$arcnos($a) 0]
7150 set i
[lsearch
-exact $arcids($arc) $a]
7151 set j
[lsearch
-exact $arcids($arc) $b]
7152 if {$i < 0 ||
$i > $j} {
7159 if {![info exists arcout
($a)]} {
7160 set arc
[lindex
$arcnos($a) 0]
7161 if {[info exists arcend
($arc)]} {
7162 set aend
$arcend($arc)
7166 set a
$arcstart($arc)
7170 if {![info exists arcout
($b)]} {
7171 set arc
[lindex
$arcnos($b) 0]
7172 if {[info exists arcend
($arc)]} {
7173 set bend
$arcend($arc)
7177 set b
$arcstart($arc)
7187 if {[info exists cached_isanc
($a,$bend)]} {
7188 if {$cached_isanc($a,$bend)} {
7192 if {[info exists cached_isanc
($b,$aend)]} {
7193 if {$cached_isanc($b,$aend)} {
7196 if {[info exists cached_isanc
($a,$bend)]} {
7201 set todo
[list
$a $b]
7204 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7205 set x
[lindex
$todo $i]
7206 if {$anc($x) eq
{}} {
7209 foreach arc
$arcnos($x) {
7210 set xd
$arcstart($arc)
7212 set cached_isanc
($a,$bend) 1
7213 set cached_isanc
($b,$aend) 0
7215 } elseif
{$xd eq
$aend} {
7216 set cached_isanc
($b,$aend) 1
7217 set cached_isanc
($a,$bend) 0
7220 if {![info exists anc
($xd)]} {
7221 set anc
($xd) $anc($x)
7223 } elseif
{$anc($xd) ne
$anc($x)} {
7228 set cached_isanc
($a,$bend) 0
7229 set cached_isanc
($b,$aend) 0
7233 # This identifies whether $desc has an ancestor that is
7234 # a growing tip of the graph and which is not an ancestor of $anc
7235 # and returns 0 if so and 1 if not.
7236 # If we subsequently discover a tag on such a growing tip, and that
7237 # turns out to be a descendent of $anc (which it could, since we
7238 # don't necessarily see children before parents), then $desc
7239 # isn't a good choice to display as a descendent tag of
7240 # $anc (since it is the descendent of another tag which is
7241 # a descendent of $anc). Similarly, $anc isn't a good choice to
7242 # display as a ancestor tag of $desc.
7244 proc is_certain
{desc anc
} {
7245 global arcnos arcout arcstart arcend growing problems
7248 if {[llength
$arcnos($anc)] == 1} {
7249 # tags on the same arc are certain
7250 if {$arcnos($desc) eq
$arcnos($anc)} {
7253 if {![info exists arcout
($anc)]} {
7254 # if $anc is partway along an arc, use the start of the arc instead
7255 set a
[lindex
$arcnos($anc) 0]
7256 set anc
$arcstart($a)
7259 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7262 set a
[lindex
$arcnos($desc) 0]
7268 set anclist
[list
$x]
7272 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7273 set x
[lindex
$anclist $i]
7278 foreach a
$arcout($x) {
7279 if {[info exists growing
($a)]} {
7280 if {![info exists growanc
($x)] && $dl($x)} {
7286 if {[info exists dl
($y)]} {
7290 if {![info exists
done($y)]} {
7293 if {[info exists growanc
($x)]} {
7297 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7298 set z
[lindex
$xl $k]
7299 foreach c
$arcout($z) {
7300 if {[info exists arcend
($c)]} {
7302 if {[info exists dl
($v)] && $dl($v)} {
7304 if {![info exists
done($v)]} {
7307 if {[info exists growanc
($v)]} {
7317 } elseif
{$y eq
$anc ||
!$dl($x)} {
7328 foreach x
[array names growanc
] {
7337 proc validate_arctags
{a
} {
7338 global arctags idtags
7342 foreach id
$arctags($a) {
7344 if {![info exists idtags
($id)]} {
7345 set na
[lreplace
$na $i $i]
7352 proc validate_archeads
{a
} {
7353 global archeads idheads
7356 set na
$archeads($a)
7357 foreach id
$archeads($a) {
7359 if {![info exists idheads
($id)]} {
7360 set na
[lreplace
$na $i $i]
7364 set archeads
($a) $na
7367 # Return the list of IDs that have tags that are descendents of id,
7368 # ignoring IDs that are descendents of IDs already reported.
7369 proc desctags
{id
} {
7370 global arcnos arcstart arcids arctags idtags allparents
7371 global growing cached_dtags
7373 if {![info exists allparents
($id)]} {
7376 set t1
[clock clicks
-milliseconds]
7378 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7379 # part-way along an arc; check that arc first
7380 set a
[lindex
$arcnos($id) 0]
7381 if {$arctags($a) ne
{}} {
7383 set i
[lsearch
-exact $arcids($a) $id]
7385 foreach t
$arctags($a) {
7386 set j
[lsearch
-exact $arcids($a) $t]
7394 set id
$arcstart($a)
7395 if {[info exists idtags
($id)]} {
7399 if {[info exists cached_dtags
($id)]} {
7400 return $cached_dtags($id)
7407 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7408 set id
[lindex
$todo $i]
7410 set ta
[info exists hastaggedancestor
($id)]
7414 # ignore tags on starting node
7415 if {!$ta && $i > 0} {
7416 if {[info exists idtags
($id)]} {
7419 } elseif
{[info exists cached_dtags
($id)]} {
7420 set tagloc
($id) $cached_dtags($id)
7424 foreach a
$arcnos($id) {
7426 if {!$ta && $arctags($a) ne
{}} {
7428 if {$arctags($a) ne
{}} {
7429 lappend tagloc
($id) [lindex
$arctags($a) end
]
7432 if {$ta ||
$arctags($a) ne
{}} {
7433 set tomark
[list
$d]
7434 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7435 set dd [lindex
$tomark $j]
7436 if {![info exists hastaggedancestor
($dd)]} {
7437 if {[info exists
done($dd)]} {
7438 foreach b
$arcnos($dd) {
7439 lappend tomark
$arcstart($b)
7441 if {[info exists tagloc
($dd)]} {
7444 } elseif
{[info exists queued
($dd)]} {
7447 set hastaggedancestor
($dd) 1
7451 if {![info exists queued
($d)]} {
7454 if {![info exists hastaggedancestor
($d)]} {
7461 foreach id
[array names tagloc
] {
7462 if {![info exists hastaggedancestor
($id)]} {
7463 foreach t
$tagloc($id) {
7464 if {[lsearch
-exact $tags $t] < 0} {
7470 set t2
[clock clicks
-milliseconds]
7473 # remove tags that are descendents of other tags
7474 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7475 set a
[lindex
$tags $i]
7476 for {set j
0} {$j < $i} {incr j
} {
7477 set b
[lindex
$tags $j]
7478 set r
[anc_or_desc
$a $b]
7480 set tags
[lreplace
$tags $j $j]
7483 } elseif
{$r == -1} {
7484 set tags
[lreplace
$tags $i $i]
7491 if {[array names growing
] ne
{}} {
7492 # graph isn't finished, need to check if any tag could get
7493 # eclipsed by another tag coming later. Simply ignore any
7494 # tags that could later get eclipsed.
7497 if {[is_certain
$t $origid]} {
7501 if {$tags eq
$ctags} {
7502 set cached_dtags
($origid) $tags
7507 set cached_dtags
($origid) $tags
7509 set t3
[clock clicks
-milliseconds]
7510 if {0 && $t3 - $t1 >= 100} {
7511 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
7512 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7518 global arcnos arcids arcout arcend arctags idtags allparents
7519 global growing cached_atags
7521 if {![info exists allparents
($id)]} {
7524 set t1
[clock clicks
-milliseconds]
7526 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7527 # part-way along an arc; check that arc first
7528 set a
[lindex
$arcnos($id) 0]
7529 if {$arctags($a) ne
{}} {
7531 set i
[lsearch
-exact $arcids($a) $id]
7532 foreach t
$arctags($a) {
7533 set j
[lsearch
-exact $arcids($a) $t]
7539 if {![info exists arcend
($a)]} {
7543 if {[info exists idtags
($id)]} {
7547 if {[info exists cached_atags
($id)]} {
7548 return $cached_atags($id)
7556 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7557 set id
[lindex
$todo $i]
7559 set td
[info exists hastaggeddescendent
($id)]
7563 # ignore tags on starting node
7564 if {!$td && $i > 0} {
7565 if {[info exists idtags
($id)]} {
7568 } elseif
{[info exists cached_atags
($id)]} {
7569 set tagloc
($id) $cached_atags($id)
7573 foreach a
$arcout($id) {
7574 if {!$td && $arctags($a) ne
{}} {
7576 if {$arctags($a) ne
{}} {
7577 lappend tagloc
($id) [lindex
$arctags($a) 0]
7580 if {![info exists arcend
($a)]} continue
7582 if {$td ||
$arctags($a) ne
{}} {
7583 set tomark
[list
$d]
7584 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7585 set dd [lindex
$tomark $j]
7586 if {![info exists hastaggeddescendent
($dd)]} {
7587 if {[info exists
done($dd)]} {
7588 foreach b
$arcout($dd) {
7589 if {[info exists arcend
($b)]} {
7590 lappend tomark
$arcend($b)
7593 if {[info exists tagloc
($dd)]} {
7596 } elseif
{[info exists queued
($dd)]} {
7599 set hastaggeddescendent
($dd) 1
7603 if {![info exists queued
($d)]} {
7606 if {![info exists hastaggeddescendent
($d)]} {
7612 set t2
[clock clicks
-milliseconds]
7615 foreach id
[array names tagloc
] {
7616 if {![info exists hastaggeddescendent
($id)]} {
7617 foreach t
$tagloc($id) {
7618 if {[lsearch
-exact $tags $t] < 0} {
7625 # remove tags that are ancestors of other tags
7626 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7627 set a
[lindex
$tags $i]
7628 for {set j
0} {$j < $i} {incr j
} {
7629 set b
[lindex
$tags $j]
7630 set r
[anc_or_desc
$a $b]
7632 set tags
[lreplace
$tags $j $j]
7635 } elseif
{$r == 1} {
7636 set tags
[lreplace
$tags $i $i]
7643 if {[array names growing
] ne
{}} {
7644 # graph isn't finished, need to check if any tag could get
7645 # eclipsed by another tag coming later. Simply ignore any
7646 # tags that could later get eclipsed.
7649 if {[is_certain
$origid $t]} {
7653 if {$tags eq
$ctags} {
7654 set cached_atags
($origid) $tags
7659 set cached_atags
($origid) $tags
7661 set t3
[clock clicks
-milliseconds]
7662 if {0 && $t3 - $t1 >= 100} {
7663 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
7664 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7669 # Return the list of IDs that have heads that are descendents of id,
7670 # including id itself if it has a head.
7671 proc descheads
{id
} {
7672 global arcnos arcstart arcids archeads idheads cached_dheads
7675 if {![info exists allparents
($id)]} {
7679 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7680 # part-way along an arc; check it first
7681 set a
[lindex
$arcnos($id) 0]
7682 if {$archeads($a) ne
{}} {
7683 validate_archeads
$a
7684 set i
[lsearch
-exact $arcids($a) $id]
7685 foreach t
$archeads($a) {
7686 set j
[lsearch
-exact $arcids($a) $t]
7691 set id
$arcstart($a)
7697 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7698 set id
[lindex
$todo $i]
7699 if {[info exists cached_dheads
($id)]} {
7700 set ret
[concat
$ret $cached_dheads($id)]
7702 if {[info exists idheads
($id)]} {
7705 foreach a
$arcnos($id) {
7706 if {$archeads($a) ne
{}} {
7707 validate_archeads
$a
7708 if {$archeads($a) ne
{}} {
7709 set ret
[concat
$ret $archeads($a)]
7713 if {![info exists seen
($d)]} {
7720 set ret
[lsort
-unique $ret]
7721 set cached_dheads
($origid) $ret
7722 return [concat
$ret $aret]
7725 proc addedtag
{id
} {
7726 global arcnos arcout cached_dtags cached_atags
7728 if {![info exists arcnos
($id)]} return
7729 if {![info exists arcout
($id)]} {
7730 recalcarc
[lindex
$arcnos($id) 0]
7732 catch
{unset cached_dtags
}
7733 catch
{unset cached_atags
}
7736 proc addedhead
{hid
head} {
7737 global arcnos arcout cached_dheads
7739 if {![info exists arcnos
($hid)]} return
7740 if {![info exists arcout
($hid)]} {
7741 recalcarc
[lindex
$arcnos($hid) 0]
7743 catch
{unset cached_dheads
}
7746 proc removedhead
{hid
head} {
7747 global cached_dheads
7749 catch
{unset cached_dheads
}
7752 proc movedhead
{hid
head} {
7753 global arcnos arcout cached_dheads
7755 if {![info exists arcnos
($hid)]} return
7756 if {![info exists arcout
($hid)]} {
7757 recalcarc
[lindex
$arcnos($hid) 0]
7759 catch
{unset cached_dheads
}
7762 proc changedrefs
{} {
7763 global cached_dheads cached_dtags cached_atags
7764 global arctags archeads arcnos arcout idheads idtags
7766 foreach id
[concat
[array names idheads
] [array names idtags
]] {
7767 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
7768 set a
[lindex
$arcnos($id) 0]
7769 if {![info exists donearc
($a)]} {
7775 catch
{unset cached_dtags
}
7776 catch
{unset cached_atags
}
7777 catch
{unset cached_dheads
}
7780 proc rereadrefs
{} {
7781 global idtags idheads idotherrefs mainhead
7783 set refids
[concat
[array names idtags
] \
7784 [array names idheads
] [array names idotherrefs
]]
7785 foreach id
$refids {
7786 if {![info exists ref
($id)]} {
7787 set ref
($id) [listrefs
$id]
7790 set oldmainhead
$mainhead
7793 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
7794 [array names idheads
] [array names idotherrefs
]]]
7795 foreach id
$refids {
7796 set v
[listrefs
$id]
7797 if {![info exists ref
($id)] ||
$ref($id) != $v ||
7798 ($id eq
$oldmainhead && $id ne
$mainhead) ||
7799 ($id eq
$mainhead && $id ne
$oldmainhead)} {
7806 proc listrefs
{id
} {
7807 global idtags idheads idotherrefs
7810 if {[info exists idtags
($id)]} {
7814 if {[info exists idheads
($id)]} {
7818 if {[info exists idotherrefs
($id)]} {
7819 set z
$idotherrefs($id)
7821 return [list
$x $y $z]
7824 proc showtag
{tag isnew
} {
7825 global ctext tagcontents tagids linknum tagobjid
7828 addtohistory
[list showtag
$tag 0]
7830 $ctext conf
-state normal
7834 if {![info exists tagcontents
($tag)]} {
7836 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
7839 if {[info exists tagcontents
($tag)]} {
7840 set text
$tagcontents($tag)
7842 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
7844 appendwithlinks
$text {}
7845 $ctext conf
-state disabled
7856 proc mkfontdisp
{font top
which} {
7857 global fontattr fontpref
$font
7859 set fontpref
($font) [set $font]
7860 button
$top.
${font}but
-text $which -font optionfont \
7861 -command [list choosefont
$font $which]
7862 label
$top.
$font -relief flat
-font $font \
7863 -text $fontattr($font,family
) -justify left
7864 grid x
$top.
${font}but
$top.
$font -sticky w
7867 proc choosefont
{font
which} {
7868 global fontparam fontlist fonttop fontattr
7870 set fontparam
(which) $which
7871 set fontparam
(font
) $font
7872 set fontparam
(family
) [font actual
$font -family]
7873 set fontparam
(size
) $fontattr($font,size
)
7874 set fontparam
(weight
) $fontattr($font,weight
)
7875 set fontparam
(slant
) $fontattr($font,slant
)
7878 if {![winfo exists
$top]} {
7880 eval font config sample
[font actual
$font]
7882 wm title
$top [mc
"Gitk font chooser"]
7883 label
$top.l
-textvariable fontparam
(which)
7884 pack
$top.l
-side top
7885 set fontlist
[lsort
[font families
]]
7887 listbox
$top.f.fam
-listvariable fontlist \
7888 -yscrollcommand [list
$top.f.sb
set]
7889 bind $top.f.fam
<<ListboxSelect>> selfontfam
7890 scrollbar $top.f.sb -command [list $top.f.fam yview]
7891 pack $top.f.sb -side right -fill y
7892 pack $top.f.fam -side left -fill both -expand 1
7893 pack $top.f -side top -fill both -expand 1
7895 spinbox $top.g.size -from 4 -to 40 -width 4 \
7896 -textvariable fontparam(size) \
7897 -validatecommand {string is integer -strict %s}
7898 checkbutton $top.g.bold -padx 5 \
7899 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7900 -variable fontparam(weight) -onvalue bold -offvalue normal
7901 checkbutton $top.g.ital -padx 5 \
7902 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7903 -variable fontparam(slant) -onvalue italic -offvalue roman
7904 pack $top.g.size $top.g.bold $top.g.ital -side left
7905 pack $top.g -side top
7906 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7908 $top.c create text 100 25 -anchor center -text $which -font sample \
7909 -fill black -tags text
7910 bind $top.c <Configure> [list centertext $top.c]
7911 pack $top.c -side top -fill x
7913 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7914 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7915 grid $top.buts.ok $top.buts.can
7916 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7917 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7918 pack $top.buts -side bottom -fill x
7919 trace add variable fontparam write chg_fontparam
7922 $top.c itemconf text -text $which
7924 set i [lsearch -exact $fontlist $fontparam(family)]
7926 $top.f.fam selection set $i
7931 proc centertext {w} {
7932 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7936 global fontparam fontpref prefstop
7938 set f $fontparam(font)
7939 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7940 if {$fontparam(weight) eq "bold"} {
7941 lappend fontpref($f) "bold"
7943 if {$fontparam(slant) eq "italic"} {
7944 lappend fontpref($f) "italic"
7947 $w conf -text $fontparam(family) -font $fontpref($f)
7953 global fonttop fontparam
7955 if {[info exists fonttop]} {
7956 catch {destroy $fonttop}
7957 catch {font delete sample}
7963 proc selfontfam {} {
7964 global fonttop fontparam
7966 set i [$fonttop.f.fam curselection]
7968 set fontparam(family) [$fonttop.f.fam get $i]
7972 proc chg_fontparam {v sub op} {
7975 font config sample -$sub $fontparam($sub)
7979 global maxwidth maxgraphpct
7980 global oldprefs prefstop showneartags showlocalchanges
7981 global bgcolor fgcolor ctext diffcolors selectbgcolor
7982 global tabstop limitdiffs autoselect
7986 if {[winfo exists $top]} {
7990 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7991 limitdiffs tabstop} {
7992 set oldprefs($v) [set $v]
7995 wm title $top [mc "Gitk preferences"]
7996 label $top.ldisp -text [mc "Commit list display options"]
7997 grid $top.ldisp - -sticky w -pady 10
7998 label $top.spacer -text " "
7999 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8001 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8002 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8003 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8005 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8006 grid x $top.maxpctl $top.maxpct -sticky w
8007 frame $top.showlocal
8008 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8009 checkbutton $top.showlocal.b -variable showlocalchanges
8010 pack $top.showlocal.b $top.showlocal.l -side left
8011 grid x $top.showlocal -sticky w
8012 frame $top.autoselect
8013 label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8014 checkbutton $top.autoselect.b -variable autoselect
8015 pack $top.autoselect.b $top.autoselect.l -side left
8016 grid x $top.autoselect -sticky w
8018 label $top.ddisp -text [mc "Diff display options"]
8019 grid $top.ddisp - -sticky w -pady 10
8020 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8021 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8022 grid x $top.tabstopl $top.tabstop -sticky w
8024 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8025 checkbutton $top.ntag.b -variable showneartags
8026 pack $top.ntag.b $top.ntag.l -side left
8027 grid x $top.ntag -sticky w
8029 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8030 checkbutton $top.ldiff.b -variable limitdiffs
8031 pack $top.ldiff.b $top.ldiff.l -side left
8032 grid x $top.ldiff -sticky w
8034 label $top.cdisp -text [mc "Colors: press to choose"]
8035 grid $top.cdisp - -sticky w -pady 10
8036 label $top.bg -padx 40 -relief sunk -background $bgcolor
8037 button $top.bgbut -text [mc "Background"] -font optionfont \
8038 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8039 grid x $top.bgbut $top.bg -sticky w
8040 label $top.fg -padx 40 -relief sunk -background $fgcolor
8041 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8042 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8043 grid x $top.fgbut $top.fg -sticky w
8044 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8045 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8046 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8047 [list $ctext tag conf d0 -foreground]]
8048 grid x $top.diffoldbut $top.diffold -sticky w
8049 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8050 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8051 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8052 [list $ctext tag conf d1 -foreground]]
8053 grid x $top.diffnewbut $top.diffnew -sticky w
8054 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8055 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8056 -command [list choosecolor diffcolors 2 $top.hunksep \
8057 "diff hunk header" \
8058 [list $ctext tag conf hunksep -foreground]]
8059 grid x $top.hunksepbut $top.hunksep -sticky w
8060 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8061 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8062 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8063 grid x $top.selbgbut $top.selbgsep -sticky w
8065 label $top.cfont -text [mc "Fonts: press to choose"]
8066 grid $top.cfont - -sticky w -pady 10
8067 mkfontdisp mainfont $top [mc "Main font"]
8068 mkfontdisp textfont $top [mc "Diff display font"]
8069 mkfontdisp uifont $top [mc "User interface font"]
8072 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8073 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8074 grid $top.buts.ok $top.buts.can
8075 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8076 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8077 grid $top.buts - - -pady 10 -sticky ew
8078 bind $top <Visibility> "focus $top.buts.ok"
8081 proc choosecolor {v vi w x cmd} {
8084 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8085 -title [mc "Gitk: choose color for %s" $x]]
8086 if {$c eq {}} return
8087 $w conf -background $c
8093 global bglist cflist
8095 $w configure -selectbackground $c
8097 $cflist tag configure highlight \
8098 -background [$cflist cget -selectbackground]
8099 allcanvs itemconf secsel -fill $c
8106 $w conf -background $c
8114 $w conf -foreground $c
8116 allcanvs itemconf text -fill $c
8117 $canv itemconf circle -outline $c
8121 global oldprefs prefstop
8123 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8124 limitdiffs tabstop} {
8126 set $v $oldprefs($v)
8128 catch {destroy $prefstop}
8134 global maxwidth maxgraphpct
8135 global oldprefs prefstop showneartags showlocalchanges
8136 global fontpref mainfont textfont uifont
8137 global limitdiffs treediffs
8139 catch {destroy $prefstop}
8143 if {$mainfont ne $fontpref(mainfont)} {
8144 set mainfont $fontpref(mainfont)
8145 parsefont mainfont $mainfont
8146 eval font configure mainfont [fontflags mainfont]
8147 eval font configure mainfontbold [fontflags mainfont 1]
8151 if {$textfont ne $fontpref(textfont)} {
8152 set textfont $fontpref(textfont)
8153 parsefont textfont $textfont
8154 eval font configure textfont [fontflags textfont]
8155 eval font configure textfontbold [fontflags textfont 1]
8157 if {$uifont ne $fontpref(uifont)} {
8158 set uifont $fontpref(uifont)
8159 parsefont uifont $uifont
8160 eval font configure uifont [fontflags uifont]
8163 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8164 if {$showlocalchanges} {
8170 if {$limitdiffs != $oldprefs(limitdiffs)} {
8171 # treediffs elements are limited by path
8172 catch {unset treediffs}
8174 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8175 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8177 } elseif {$showneartags != $oldprefs(showneartags) ||
8178 $limitdiffs != $oldprefs(limitdiffs)} {
8183 proc formatdate {d} {
8184 global datetimeformat
8186 set d [clock format $d -format $datetimeformat]
8191 # This list of encoding names and aliases is distilled from
8192 # http://www.iana.org/assignments/character-sets.
8193 # Not all of them are supported by Tcl.
8194 set encoding_aliases {
8195 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8196 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8197 { ISO-10646-UTF-1 csISO10646UTF1 }
8198 { ISO_646.basic:1983 ref csISO646basic1983 }
8199 { INVARIANT csINVARIANT }
8200 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8201 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8202 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8203 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8204 { NATS-DANO iso-ir-9-1 csNATSDANO }
8205 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8206 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8207 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8208 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8209 { ISO-2022-KR csISO2022KR }
8211 { ISO-2022-JP csISO2022JP }
8212 { ISO-2022-JP-2 csISO2022JP2 }
8213 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8215 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8216 { IT iso-ir-15 ISO646-IT csISO15Italian }
8217 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8218 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8219 { greek7-old iso-ir-18 csISO18Greek7Old }
8220 { latin-greek iso-ir-19 csISO19LatinGreek }
8221 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8222 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8223 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8224 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8225 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8226 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8227 { INIS iso-ir-49 csISO49INIS }
8228 { INIS-8 iso-ir-50 csISO50INIS8 }
8229 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8230 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8231 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8232 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8233 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8234 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8236 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8237 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8238 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8239 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8240 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8241 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8242 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8243 { greek7 iso-ir-88 csISO88Greek7 }
8244 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8245 { iso-ir-90 csISO90 }
8246 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8247 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8248 csISO92JISC62991984b }
8249 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8250 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8251 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8252 csISO95JIS62291984handadd }
8253 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8254 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8255 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8256 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8258 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8259 { T.61-7bit iso-ir-102 csISO102T617bit }
8260 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8261 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8262 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8263 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8264 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8265 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8266 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8267 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8268 arabic csISOLatinArabic }
8269 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8270 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8271 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8272 greek greek8 csISOLatinGreek }
8273 { T.101-G2 iso-ir-128 csISO128T101G2 }
8274 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8276 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8277 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8278 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8279 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8280 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8281 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8282 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8283 csISOLatinCyrillic }
8284 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8285 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8286 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8287 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8288 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8289 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8290 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8291 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8292 { ISO_10367-box iso-ir-155 csISO10367Box }
8293 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8294 { latin-lap lap iso-ir-158 csISO158Lap }
8295 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8296 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8299 { JIS_X0201 X0201 csHalfWidthKatakana }
8300 { KSC5636 ISO646-KR csKSC5636 }
8301 { ISO-10646-UCS-2 csUnicode }
8302 { ISO-10646-UCS-4 csUCS4 }
8303 { DEC-MCS dec csDECMCS }
8304 { hp-roman8 roman8 r8 csHPRoman8 }
8305 { macintosh mac csMacintosh }
8306 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8308 { IBM038 EBCDIC-INT cp038 csIBM038 }
8309 { IBM273 CP273 csIBM273 }
8310 { IBM274 EBCDIC-BE CP274 csIBM274 }
8311 { IBM275 EBCDIC-BR cp275 csIBM275 }
8312 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8313 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8314 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8315 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8316 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8317 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8318 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8319 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8320 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8321 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8322 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8323 { IBM437 cp437 437 csPC8CodePage437 }
8324 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8325 { IBM775 cp775 csPC775Baltic }
8326 { IBM850 cp850 850 csPC850Multilingual }
8327 { IBM851 cp851 851 csIBM851 }
8328 { IBM852 cp852 852 csPCp852 }
8329 { IBM855 cp855 855 csIBM855 }
8330 { IBM857 cp857 857 csIBM857 }
8331 { IBM860 cp860 860 csIBM860 }
8332 { IBM861 cp861 861 cp-is csIBM861 }
8333 { IBM862 cp862 862 csPC862LatinHebrew }
8334 { IBM863 cp863 863 csIBM863 }
8335 { IBM864 cp864 csIBM864 }
8336 { IBM865 cp865 865 csIBM865 }
8337 { IBM866 cp866 866 csIBM866 }
8338 { IBM868 CP868 cp-ar csIBM868 }
8339 { IBM869 cp869 869 cp-gr csIBM869 }
8340 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8341 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8342 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8343 { IBM891 cp891 csIBM891 }
8344 { IBM903 cp903 csIBM903 }
8345 { IBM904 cp904 904 csIBBM904 }
8346 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8347 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8348 { IBM1026 CP1026 csIBM1026 }
8349 { EBCDIC-AT-DE csIBMEBCDICATDE }
8350 { EBCDIC-AT-DE-A csEBCDICATDEA }
8351 { EBCDIC-CA-FR csEBCDICCAFR }
8352 { EBCDIC-DK-NO csEBCDICDKNO }
8353 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8354 { EBCDIC-FI-SE csEBCDICFISE }
8355 { EBCDIC-FI-SE-A csEBCDICFISEA }
8356 { EBCDIC-FR csEBCDICFR }
8357 { EBCDIC-IT csEBCDICIT }
8358 { EBCDIC-PT csEBCDICPT }
8359 { EBCDIC-ES csEBCDICES }
8360 { EBCDIC-ES-A csEBCDICESA }
8361 { EBCDIC-ES-S csEBCDICESS }
8362 { EBCDIC-UK csEBCDICUK }
8363 { EBCDIC-US csEBCDICUS }
8364 { UNKNOWN-8BIT csUnknown8BiT }
8365 { MNEMONIC csMnemonic }
8370 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8371 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8372 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8373 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8374 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8375 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8376 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8377 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8378 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8379 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8380 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8381 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8382 { IBM1047 IBM-1047 }
8383 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8384 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8385 { UNICODE-1-1 csUnicode11 }
8388 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8389 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8391 { ISO-8859-15 ISO_8859-15 Latin-9 }
8392 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8393 { GBK CP936 MS936 windows-936 }
8394 { JIS_Encoding csJISEncoding }
8395 { Shift_JIS MS_Kanji csShiftJIS }
8396 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8398 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8399 { ISO-10646-UCS-Basic csUnicodeASCII }
8400 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8401 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8402 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8403 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8404 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8405 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8406 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8407 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8408 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8409 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8410 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8411 { Ventura-US csVenturaUS }
8412 { Ventura-International csVenturaInternational }
8413 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8414 { PC8-Turkish csPC8Turkish }
8415 { IBM-Symbols csIBMSymbols }
8416 { IBM-Thai csIBMThai }
8417 { HP-Legal csHPLegal }
8418 { HP-Pi-font csHPPiFont }
8419 { HP-Math8 csHPMath8 }
8420 { Adobe-Symbol-Encoding csHPPSMath }
8421 { HP-DeskTop csHPDesktop }
8422 { Ventura-Math csVenturaMath }
8423 { Microsoft-Publishing csMicrosoftPublishing }
8424 { Windows-31J csWindows31J }
8429 proc tcl_encoding {enc} {
8430 global encoding_aliases
8431 set names [encoding names]
8432 set lcnames [string tolower $names]
8433 set enc [string tolower $enc]
8434 set i [lsearch -exact $lcnames $enc]
8436 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8437 if {[regsub {^iso[-_]} $enc iso encx]} {
8438 set i [lsearch -exact $lcnames $encx]
8442 foreach l $encoding_aliases {
8443 set ll [string tolower $l]
8444 if {[lsearch -exact $ll $enc] < 0} continue
8445 # look through the aliases for one that tcl knows about
8447 set i [lsearch -exact $lcnames $e]
8449 if {[regsub {^iso[-_]} $e iso ex]} {
8450 set i [lsearch -exact $lcnames $ex]
8459 return [lindex $names $i]
8464 # First check that Tcl/Tk is recent enough
8465 if {[catch {package require Tk 8.4} err]} {
8466 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8467 Gitk requires at least Tcl/Tk 8.4."]
8473 set wrcomcmd "git diff-tree --stdin -p --pretty"
8477 set gitencoding [exec git config --get i18n.commitencoding]
8479 if {$gitencoding == ""} {
8480 set gitencoding "utf-8"
8482 set tclencoding [tcl_encoding $gitencoding]
8483 if {$tclencoding == {}} {
8484 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8487 set mainfont {Helvetica 9}
8488 set textfont {Courier 9}
8489 set uifont {Helvetica 9 bold}
8491 set findmergefiles 0
8499 set cmitmode "patch"
8500 set wrapcomment "none"
8504 set showlocalchanges 1
8506 set datetimeformat "%Y-%m-%d %H:%M:%S"
8509 set colors {green red blue magenta darkgrey brown orange}
8512 set diffcolors {red "#00a000" blue}
8515 set selectbgcolor gray85
8517 ## For msgcat loading, first locate the installation location.
8518 if { [info exists ::env(GITK_MSGSDIR)] } {
8519 ## Msgsdir was manually set in the environment.
8520 set gitk_msgsdir $::env(GITK_MSGSDIR)
8522 ## Let's guess the prefix from argv0.
8523 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8524 set gitk_libdir [file join $gitk_prefix share gitk lib]
8525 set gitk_msgsdir [file join $gitk_libdir msgs]
8529 ## Internationalization (i18n) through msgcat and gettext. See
8530 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8531 package require msgcat
8532 namespace import ::msgcat::mc
8533 ## And eventually load the actual message catalog
8534 ::msgcat::mcload $gitk_msgsdir
8536 catch {source ~/.gitk}
8538 font create optionfont -family sans-serif -size -12
8540 parsefont mainfont $mainfont
8541 eval font create mainfont [fontflags mainfont]
8542 eval font create mainfontbold [fontflags mainfont 1]
8544 parsefont textfont $textfont
8545 eval font create textfont [fontflags textfont]
8546 eval font create textfontbold [fontflags textfont 1]
8548 parsefont uifont $uifont
8549 eval font create uifont [fontflags uifont]
8553 # check that we can find a .git directory somewhere...
8554 if {[catch {set gitdir [gitdir]}]} {
8555 show_error {} . [mc "Cannot find a git repository here."]
8558 if {![file isdirectory $gitdir]} {
8559 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8565 set cmdline_files {}
8567 set revtreeargscmd {}
8569 switch -glob -- $arg {
8571 "-d" { set datemode 1 }
8574 lappend revtreeargs $arg
8577 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8581 set revtreeargscmd [string range $arg 10 end]
8584 lappend revtreeargs $arg
8590 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8591 # no -- on command line, but some arguments (other than -d)
8593 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8594 set cmdline_files [split $f "\n"]
8595 set n [llength $cmdline_files]
8596 set revtreeargs [lrange $revtreeargs 0 end-$n]
8597 # Unfortunately git rev-parse doesn't produce an error when
8598 # something is both a revision and a filename. To be consistent
8599 # with git log and git rev-list, check revtreeargs for filenames.
8600 foreach arg $revtreeargs {
8601 if {[file exists $arg]} {
8602 show_error {} . [mc "Ambiguous argument '%s': both revision\
8608 # unfortunately we get both stdout and stderr in $err,
8609 # so look for "fatal:".
8610 set i [string first "fatal:" $err]
8612 set err [string range $err [expr {$i + 6}] end]
8614 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8620 # find the list of unmerged files
8624 set fd [open "| git ls-files -u" r]
8626 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8629 while {[gets $fd line] >= 0} {
8630 set i [string first "\t" $line]
8631 if {$i < 0} continue
8632 set fname [string range $line [expr {$i+1}] end]
8633 if {[lsearch -exact $mlist $fname] >= 0} continue
8635 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8636 lappend mlist $fname
8641 if {$nr_unmerged == 0} {
8642 show_error {} . [mc "No files selected: --merge specified but\
8643 no files are unmerged."]
8645 show_error {} . [mc "No files selected: --merge specified but\
8646 no unmerged files are within file limit."]
8650 set cmdline_files $mlist
8653 set nullid "0000000000000000000000000000000000000000"
8654 set nullid2 "0000000000000000000000000000000000000001"
8656 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8663 set highlight_paths {}
8665 set searchdirn -forwards
8669 set markingmatches 0
8670 set linkentercount 0
8671 set need_redisplay 0
8678 set selectedhlview [mc "None"]
8679 set highlight_related [mc "None"]
8680 set highlight_files {}
8684 set viewargscmd(0) {}
8695 # wait for the window to become visible
8697 wm title . "[file tail $argv0]: [file tail [pwd]]"
8700 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8701 # create a view for the files/dirs specified on the command line
8705 set viewname(1) [mc "Command line"]
8706 set viewfiles(1) $cmdline_files
8707 set viewargs(1) $revtreeargs
8708 set viewargscmd(1) $revtreeargscmd
8711 .bar.view entryconf [mc "Edit view..."] -state normal
8712 .bar.view entryconf [mc "Delete view"] -state normal
8715 if {[info exists permviews]} {
8716 foreach v $permviews {
8719 set viewname($n) [lindex $v 0]
8720 set viewfiles($n) [lindex $v 1]
8721 set viewargs($n) [lindex $v 2]
8722 set viewargscmd($n) [lindex $v 3]