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 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 order
"--topo-order"
95 set order
"--date-order"
98 set fd
[open
[concat | git log
--no-color -z --pretty=raw
$order --parents \
99 --boundary $viewargs($view) "--" $viewfiles($view)] r
]
101 error_popup
"[mc "Error executing git rev-list
:"] $err"
104 set commfd
($view) $fd
105 set leftover
($view) {}
106 if {$showlocalchanges} {
107 lappend commitinterest
($mainheadid) {dodiffindex
}
109 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
110 if {$tclencoding != {}} {
111 fconfigure
$fd -encoding $tclencoding
113 filerun
$fd [list getcommitlines
$fd $view]
114 nowbusy
$view [mc
"Reading"]
115 if {$view == $curview} {
117 set progresscoords
{0 0}
122 proc stop_rev_list
{} {
123 global commfd curview
125 if {![info exists commfd
($curview)]} return
126 set fd
$commfd($curview)
132 unset commfd
($curview)
136 global phase canv curview
140 start_rev_list
$curview
141 show_status
[mc
"Reading commits..."]
144 # This makes a string representation of a positive integer which
145 # sorts as a string in numerical order
148 return [format
"%x" $n]
149 } elseif
{$n < 256} {
150 return [format
"x%.2x" $n]
151 } elseif
{$n < 65536} {
152 return [format
"y%.4x" $n]
154 return [format
"z%.8x" $n]
157 proc getcommitlines
{fd view
} {
158 global commitlisted commitinterest
159 global leftover commfd
160 global displayorder commitidx viewcomplete commitrow commitdata
161 global parentlist children curview hlview
162 global vparentlist vdisporder vcmitlisted
163 global ordertok vnextroot idpending
165 set stuff
[read $fd 500000]
166 # git log doesn't terminate the last commit with a null...
167 if {$stuff == {} && $leftover($view) ne
{} && [eof
$fd]} {
174 # Check if we have seen any ids listed as parents that haven't
175 # appeared in the list
176 foreach vid
[array names idpending
"$view,*"] {
177 # should only get here if git log is buggy
178 set id
[lindex
[split $vid ","] 1]
179 set commitrow
($vid) $commitidx($view)
180 incr commitidx
($view)
181 if {$view == $curview} {
182 lappend parentlist
{}
183 lappend displayorder
$id
184 lappend commitlisted
0
186 lappend vparentlist
($view) {}
187 lappend vdisporder
($view) $id
188 lappend vcmitlisted
($view) 0
191 set viewcomplete
($view) 1
192 global viewname progresscoords
195 set progresscoords
{0 0}
197 # set it blocking so we wait for the process to terminate
198 fconfigure
$fd -blocking 1
199 if {[catch
{close
$fd} err
]} {
201 if {$view != $curview} {
202 set fv
" for the \"$viewname($view)\" view"
204 if {[string range
$err 0 4] == "usage"} {
205 set err
"Gitk: error reading commits$fv:\
206 bad arguments to git rev-list."
207 if {$viewname($view) eq
"Command line"} {
209 " (Note: arguments to gitk are passed to git rev-list\
210 to allow selection of commits to be displayed.)"
213 set err
"Error reading commits$fv: $err"
217 if {$view == $curview} {
218 run chewcommits
$view
225 set i
[string first
"\0" $stuff $start]
227 append leftover
($view) [string range
$stuff $start end
]
231 set cmit
$leftover($view)
232 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
233 set leftover
($view) {}
235 set cmit
[string range
$stuff $start [expr {$i - 1}]]
237 set start
[expr {$i + 1}]
238 set j
[string first
"\n" $cmit]
241 if {$j >= 0 && [string match
"commit *" $cmit]} {
242 set ids
[string range
$cmit 7 [expr {$j - 1}]]
243 if {[string match
{[-<>]*} $ids]} {
244 switch
-- [string index
$ids 0] {
249 set ids
[string range
$ids 1 end
]
253 if {[string length
$id] != 40} {
261 if {[string length
$shortcmit] > 80} {
262 set shortcmit
"[string range $shortcmit 0 80]..."
264 error_popup
"[mc "Can
't parse git log output:"] {$shortcmit}"
267 set id [lindex $ids 0]
268 if {![info exists ordertok($view,$id)]} {
269 set otok "o[strrep $vnextroot($view)]"
270 incr vnextroot($view)
271 set ordertok($view,$id) $otok
273 set otok $ordertok($view,$id)
274 unset idpending($view,$id)
277 set olds [lrange $ids 1 end]
278 if {[llength $olds] == 1} {
279 set p [lindex $olds 0]
280 lappend children($view,$p) $id
281 if {![info exists ordertok($view,$p)]} {
282 set ordertok($view,$p) $ordertok($view,$id)
283 set idpending($view,$p) 1
288 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
289 lappend children($view,$p) $id
291 if {![info exists ordertok($view,$p)]} {
292 set ordertok($view,$p) "$otok[strrep $i]]"
293 set idpending($view,$p) 1
301 if {![info exists children($view,$id)]} {
302 set children($view,$id) {}
304 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
305 set commitrow($view,$id) $commitidx($view)
306 incr commitidx($view)
307 if {$view == $curview} {
308 lappend parentlist $olds
309 lappend displayorder $id
310 lappend commitlisted $listed
312 lappend vparentlist($view) $olds
313 lappend vdisporder($view) $id
314 lappend vcmitlisted($view) $listed
316 if {[info exists commitinterest($id)]} {
317 foreach script $commitinterest($id) {
318 eval [string map [list "%I" $id] $script]
320 unset commitinterest($id)
325 run chewcommits $view
326 if {$view == $curview} {
327 # update progress bar
328 global progressdirn progresscoords proglastnc
329 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
330 set proglastnc $commitidx($view)
331 set l [lindex $progresscoords 0]
332 set r [lindex $progresscoords 1]
334 set r [expr {$r + $inc}]
340 set l [expr {$r - 0.2}]
343 set l [expr {$l - $inc}]
348 set r [expr {$l + 0.2}]
350 set progresscoords [list $l $r]
357 proc chewcommits {view} {
358 global curview hlview viewcomplete
359 global selectedline pending_select
361 if {$view == $curview} {
363 if {$viewcomplete($view)} {
364 global displayorder commitidx phase
365 global numcommits startmsecs
367 if {[info exists pending_select]} {
368 set row [first_real_row]
371 if {$commitidx($curview) > 0} {
372 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
373 #puts "overall $ms ms for $numcommits commits"
375 show_status [mc "No commits selected"]
381 if {[info exists hlview] && $view == $hlview} {
387 proc readcommit {id} {
388 if {[catch {set contents [exec git cat-file commit $id]}]} return
389 parsecommit $id $contents 0
392 proc updatecommits {} {
393 global viewdata curview phase displayorder ordertok idpending
394 global children commitrow selectedline thickerline showneartags
401 foreach id $displayorder {
402 catch {unset children($n,$id)}
403 catch {unset commitrow($n,$id)}
404 catch {unset ordertok($n,$id)}
406 foreach vid [array names idpending "$n,*"] {
407 unset idpending($vid)
410 catch {unset selectedline}
411 catch {unset thickerline}
412 catch {unset viewdata($n)}
421 proc parsecommit {id contents listed} {
422 global commitinfo cdate
431 set hdrend [string first "\n\n" $contents]
433 # should never happen...
434 set hdrend [string length $contents]
436 set header [string range $contents 0 [expr {$hdrend - 1}]]
437 set comment [string range $contents [expr {$hdrend + 2}] end]
438 foreach line [split $header "\n"] {
439 set tag [lindex $line 0]
440 if {$tag == "author"} {
441 set audate [lindex $line end-1]
442 set auname [lrange $line 1 end-2]
443 } elseif {$tag == "committer"} {
444 set comdate [lindex $line end-1]
445 set comname [lrange $line 1 end-2]
449 # take the first non-blank line of the comment as the headline
450 set headline [string trimleft $comment]
451 set i [string first "\n" $headline]
453 set headline [string range $headline 0 $i]
455 set headline [string trimright $headline]
456 set i [string first "\r" $headline]
458 set headline [string trimright [string range $headline 0 $i]]
461 # git rev-list indents the comment by 4 spaces;
462 # if we got this via git cat-file, add the indentation
464 foreach line [split $comment "\n"] {
465 append newcomment " "
466 append newcomment $line
467 append newcomment "\n"
469 set comment $newcomment
471 if {$comdate != {}} {
472 set cdate($id) $comdate
474 set commitinfo($id) [list $headline $auname $audate \
475 $comname $comdate $comment]
478 proc getcommit {id} {
479 global commitdata commitinfo
481 if {[info exists commitdata($id)]} {
482 parsecommit $id $commitdata($id) 1
485 if {![info exists commitinfo($id)]} {
486 set commitinfo($id) [list [mc "No commit information available"]]
493 global tagids idtags headids idheads tagobjid
494 global otherrefids idotherrefs mainhead mainheadid
496 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
499 set refd [open [list | git show-ref -d] r]
500 while {[gets $refd line] >= 0} {
501 if {[string index $line 40] ne " "} continue
502 set id [string range $line 0 39]
503 set ref [string range $line 41 end]
504 if {![string match "refs/*" $ref]} continue
505 set name [string range $ref 5 end]
506 if {[string match "remotes/*" $name]} {
507 if {![string match "*/HEAD" $name]} {
508 set headids($name) $id
509 lappend idheads($id) $name
511 } elseif {[string match "heads/*" $name]} {
512 set name [string range $name 6 end]
513 set headids($name) $id
514 lappend idheads($id) $name
515 } elseif {[string match "tags/*" $name]} {
516 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
517 # which is what we want since the former is the commit ID
518 set name [string range $name 5 end]
519 if {[string match "*^{}" $name]} {
520 set name [string range $name 0 end-3]
522 set tagobjid($name) $id
524 set tagids($name) $id
525 lappend idtags($id) $name
527 set otherrefids($name) $id
528 lappend idotherrefs($id) $name
535 set thehead [exec git symbolic-ref HEAD]
536 if {[string match "refs/heads/*" $thehead]} {
537 set mainhead [string range $thehead 11 end]
538 if {[info exists headids($mainhead)]} {
539 set mainheadid $headids($mainhead)
545 # skip over fake commits
546 proc first_real_row {} {
547 global nullid nullid2 displayorder numcommits
549 for {set row 0} {$row < $numcommits} {incr row} {
550 set id [lindex $displayorder $row]
551 if {$id ne $nullid && $id ne $nullid2} {
558 # update things for a head moved to a child of its previous location
559 proc movehead {id name} {
560 global headids idheads
562 removehead $headids($name) $name
563 set headids($name) $id
564 lappend idheads($id) $name
567 # update things when a head has been removed
568 proc removehead {id name} {
569 global headids idheads
571 if {$idheads($id) eq $name} {
574 set i [lsearch -exact $idheads($id) $name]
576 set idheads($id) [lreplace $idheads($id) $i $i]
582 proc show_error {w top msg} {
583 message $w.m -text $msg -justify center -aspect 400
584 pack $w.m -side top -fill x -padx 20 -pady 20
585 button $w.ok -text [mc OK] -command "destroy $top"
586 pack $w.ok -side bottom -fill x
587 bind $top <Visibility> "grab $top; focus $top"
588 bind $top <Key-Return> "destroy $top"
592 proc error_popup msg {
596 show_error $w $w $msg
599 proc confirm_popup msg {
605 message $w.m -text $msg -justify center -aspect 400
606 pack $w.m -side top -fill x -padx 20 -pady 20
607 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
608 pack $w.ok -side left -fill x
609 button $w.cancel -text [mc Cancel] -command "destroy $w"
610 pack $w.cancel -side right -fill x
611 bind $w <Visibility> "grab $w; focus $w"
617 option add *Panedwindow.showHandle 1 startupFile
618 option add *Panedwindow.sashRelief raised startupFile
619 option add *Button.font uifont startupFile
620 option add *Checkbutton.font uifont startupFile
621 option add *Radiobutton.font uifont startupFile
622 option add *Menu.font uifont startupFile
623 option add *Menubutton.font uifont startupFile
624 option add *Label.font uifont startupFile
625 option add *Message.font uifont startupFile
626 option add *Entry.font uifont startupFile
630 global canv canv2 canv3 linespc charspc ctext cflist
632 global findtype findtypemenu findloc findstring fstring geometry
633 global entries sha1entry sha1string sha1but
634 global diffcontextstring diffcontext
635 global maincursor textcursor curtextcursor
636 global rowctxmenu fakerowmenu mergemax wrapcomment
637 global highlight_files gdttype
638 global searchstring sstring
639 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
640 global headctxmenu progresscanv progressitem progresscoords statusw
641 global fprogitem fprogcoord lastprogupdate progupdatepending
642 global rprogitem rprogcoord
646 .bar add cascade -label [mc "File"] -menu .bar.file
648 .bar.file add command -label [mc "Update"] -command updatecommits
649 .bar.file add command -label [mc "Reread references"] -command rereadrefs
650 .bar.file add command -label [mc "List references"] -command showrefs
651 .bar.file add command -label [mc "Quit"] -command doquit
653 .bar add cascade -label [mc "Edit"] -menu .bar.edit
654 .bar.edit add command -label [mc "Preferences"] -command doprefs
657 .bar add cascade -label [mc "View"] -menu .bar.view
658 .bar.view add command -label [mc "New view..."] -command {newview 0}
659 .bar.view add command -label [mc "Edit view..."] -command editview \
661 .bar.view add command -label [mc "Delete view"] -command delview -state disabled
662 .bar.view add separator
663 .bar.view add radiobutton -label [mc "All files"] -command {showview 0} \
664 -variable selectedview -value 0
667 .bar add cascade -label [mc "Help"] -menu .bar.help
668 .bar.help add command -label [mc "About gitk"] -command about
669 .bar.help add command -label [mc "Key bindings"] -command keys
671 . configure -menu .bar
673 # the gui has upper and lower half, parts of a paned window.
674 panedwindow .ctop -orient vertical
676 # possibly use assumed geometry
677 if {![info exists geometry(pwsash0)]} {
678 set geometry(topheight) [expr {15 * $linespc}]
679 set geometry(topwidth) [expr {80 * $charspc}]
680 set geometry(botheight) [expr {15 * $linespc}]
681 set geometry(botwidth) [expr {50 * $charspc}]
682 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
683 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
686 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
687 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
689 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
691 # create three canvases
692 set cscroll .tf.histframe.csb
693 set canv .tf.histframe.pwclist.canv
695 -selectbackground $selectbgcolor \
696 -background $bgcolor -bd 0 \
697 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
698 .tf.histframe.pwclist add $canv
699 set canv2 .tf.histframe.pwclist.canv2
701 -selectbackground $selectbgcolor \
702 -background $bgcolor -bd 0 -yscrollincr $linespc
703 .tf.histframe.pwclist add $canv2
704 set canv3 .tf.histframe.pwclist.canv3
706 -selectbackground $selectbgcolor \
707 -background $bgcolor -bd 0 -yscrollincr $linespc
708 .tf.histframe.pwclist add $canv3
709 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
710 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
712 # a scroll bar to rule them
713 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
714 pack $cscroll -side right -fill y
715 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
716 lappend bglist $canv $canv2 $canv3
717 pack .tf.histframe.pwclist -fill both -expand 1 -side left
719 # we have two button bars at bottom of top frame. Bar 1
721 frame .tf.lbar -height 15
723 set sha1entry .tf.bar.sha1
724 set entries $sha1entry
725 set sha1but .tf.bar.sha1label
726 button $sha1but -text [mc "SHA1 ID: "] -state disabled -relief flat \
727 -command gotocommit -width 8
728 $sha1but conf -disabledforeground [$sha1but cget -foreground]
729 pack .tf.bar.sha1label -side left
730 entry $sha1entry -width 40 -font textfont -textvariable sha1string
731 trace add variable sha1string write sha1change
732 pack $sha1entry -side left -pady 2
734 image create bitmap bm-left -data {
735 #define left_width 16
736 #define left_height 16
737 static unsigned char left_bits[] = {
738 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
739 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
740 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
742 image create bitmap bm-right -data {
743 #define right_width 16
744 #define right_height 16
745 static unsigned char right_bits[] = {
746 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
747 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
748 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
750 button .tf.bar.leftbut -image bm-left -command goback \
751 -state disabled -width 26
752 pack .tf.bar.leftbut -side left -fill y
753 button .tf.bar.rightbut -image bm-right -command goforw \
754 -state disabled -width 26
755 pack .tf.bar.rightbut -side left -fill y
757 # Status label and progress bar
758 set statusw .tf.bar.status
759 label $statusw -width 15 -relief sunken
760 pack $statusw -side left -padx 5
761 set h [expr {[font metrics uifont -linespace] + 2}]
762 set progresscanv .tf.bar.progress
763 canvas $progresscanv -relief sunken -height $h -borderwidth 2
764 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
765 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
766 set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
767 pack $progresscanv -side right -expand 1 -fill x
768 set progresscoords {0 0}
771 bind $progresscanv <Configure> adjustprogress
772 set lastprogupdate [clock clicks -milliseconds]
773 set progupdatepending 0
775 # build up the bottom bar of upper window
776 label .tf.lbar.flabel -text "[mc "Find"] "
777 button .tf.lbar.fnext -text [mc "next"] -command {dofind 1 1}
778 button .tf.lbar.fprev -text [mc "prev"] -command {dofind -1 1}
779 label .tf.lbar.flab2 -text " [mc "commit"] "
780 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
782 set gdttype [mc "containing:"]
783 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
785 [mc "touching paths:"] \
786 [mc "adding/removing string:"]]
787 trace add variable gdttype write gdttype_change
788 pack .tf.lbar.gdttype -side left -fill y
791 set fstring .tf.lbar.findstring
792 lappend entries $fstring
793 entry $fstring -width 30 -font textfont -textvariable findstring
794 trace add variable findstring write find_change
795 set findtype [mc "Exact"]
796 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
797 findtype [mc "Exact"] [mc "IgnCase"] [mc "Regexp"]]
798 trace add variable findtype write findcom_change
799 set findloc [mc "All fields"]
800 tk_optionMenu .tf.lbar.findloc findloc [mc "All fields"] [mc "Headline"] \
801 [mc "Comments"] [mc "Author"] [mc "Committer"]
802 trace add variable findloc write find_change
803 pack .tf.lbar.findloc -side right
804 pack .tf.lbar.findtype -side right
805 pack $fstring -side left -expand 1 -fill x
807 # Finish putting the upper half of the viewer together
808 pack .tf.lbar -in .tf -side bottom -fill x
809 pack .tf.bar -in .tf -side bottom -fill x
810 pack .tf.histframe -fill both -side top -expand 1
812 .ctop paneconfigure .tf -height $geometry(topheight)
813 .ctop paneconfigure .tf -width $geometry(topwidth)
815 # now build up the bottom
816 panedwindow .pwbottom -orient horizontal
818 # lower left, a text box over search bar, scroll bar to the right
819 # if we know window height, then that will set the lower text height, otherwise
820 # we set lower text height which will drive window height
821 if {[info exists geometry(main)]} {
822 frame .bleft -width $geometry(botwidth)
824 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
829 button .bleft.top.search -text [mc "Search"] -command dosearch
830 pack .bleft.top.search -side left -padx 5
831 set sstring .bleft.top.sstring
832 entry $sstring -width 20 -font textfont -textvariable searchstring
833 lappend entries $sstring
834 trace add variable searchstring write incrsearch
835 pack $sstring -side left -expand 1 -fill x
836 radiobutton .bleft.mid.diff -text [mc "Diff"] \
837 -command changediffdisp -variable diffelide -value {0 0}
838 radiobutton .bleft.mid.old -text [mc "Old version"] \
839 -command changediffdisp -variable diffelide -value {0 1}
840 radiobutton .bleft.mid.new -text [mc "New version"] \
841 -command changediffdisp -variable diffelide -value {1 0}
842 label .bleft.mid.labeldiffcontext -text " [mc "Lines of context"]: "
843 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
844 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
845 -from 1 -increment 1 -to 10000000 \
846 -validate all -validatecommand "diffcontextvalidate %P" \
847 -textvariable diffcontextstring
848 .bleft.mid.diffcontext set $diffcontext
849 trace add variable diffcontextstring write diffcontextchange
850 lappend entries .bleft.mid.diffcontext
851 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
852 set ctext .bleft.ctext
853 text $ctext -background $bgcolor -foreground $fgcolor \
854 -state disabled -font textfont \
855 -yscrollcommand scrolltext -wrap none
857 $ctext conf -tabstyle wordprocessor
859 scrollbar .bleft.sb -command "$ctext yview"
860 pack .bleft.top -side top -fill x
861 pack .bleft.mid -side top -fill x
862 pack .bleft.sb -side right -fill y
863 pack $ctext -side left -fill both -expand 1
864 lappend bglist $ctext
865 lappend fglist $ctext
867 $ctext tag conf comment -wrap $wrapcomment
868 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
869 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
870 $ctext tag conf d0 -fore [lindex $diffcolors 0]
871 $ctext tag conf d1 -fore [lindex $diffcolors 1]
872 $ctext tag conf m0 -fore red
873 $ctext tag conf m1 -fore blue
874 $ctext tag conf m2 -fore green
875 $ctext tag conf m3 -fore purple
876 $ctext tag conf m4 -fore brown
877 $ctext tag conf m5 -fore "#009090"
878 $ctext tag conf m6 -fore magenta
879 $ctext tag conf m7 -fore "#808000"
880 $ctext tag conf m8 -fore "#009000"
881 $ctext tag conf m9 -fore "#ff0080"
882 $ctext tag conf m10 -fore cyan
883 $ctext tag conf m11 -fore "#b07070"
884 $ctext tag conf m12 -fore "#70b0f0"
885 $ctext tag conf m13 -fore "#70f0b0"
886 $ctext tag conf m14 -fore "#f0b070"
887 $ctext tag conf m15 -fore "#ff70b0"
888 $ctext tag conf mmax -fore darkgrey
890 $ctext tag conf mresult -font textfontbold
891 $ctext tag conf msep -font textfontbold
892 $ctext tag conf found -back yellow
895 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
900 radiobutton .bright.mode.patch -text [mc "Patch"] \
901 -command reselectline -variable cmitmode -value "patch"
902 radiobutton .bright.mode.tree -text [mc "Tree"] \
903 -command reselectline -variable cmitmode -value "tree"
904 grid .bright.mode.patch .bright.mode.tree -sticky ew
905 pack .bright.mode -side top -fill x
906 set cflist .bright.cfiles
907 set indent [font measure mainfont "nn"]
909 -selectbackground $selectbgcolor \
910 -background $bgcolor -foreground $fgcolor \
912 -tabs [list $indent [expr {2 * $indent}]] \
913 -yscrollcommand ".bright.sb set" \
914 -cursor [. cget -cursor] \
915 -spacing1 1 -spacing3 1
916 lappend bglist $cflist
917 lappend fglist $cflist
918 scrollbar .bright.sb -command "$cflist yview"
919 pack .bright.sb -side right -fill y
920 pack $cflist -side left -fill both -expand 1
921 $cflist tag configure highlight \
922 -background [$cflist cget -selectbackground]
923 $cflist tag configure bold -font mainfontbold
925 .pwbottom add .bright
928 # restore window position if known
929 if {[info exists geometry(main)]} {
930 wm geometry . "$geometry(main)"
933 if {[tk windowingsystem] eq {aqua}} {
939 bind .pwbottom <Configure> {resizecdetpanes %W %w}
940 pack .ctop -fill both -expand 1
941 bindall <1> {selcanvline %W %x %y}
942 #bindall <B1-Motion> {selcanvline %W %x %y}
943 if {[tk windowingsystem] == "win32"} {
944 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
945 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
947 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
948 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
949 if {[tk windowingsystem] eq "aqua"} {
950 bindall <MouseWheel> {
951 set delta [expr {- (%D)}]
952 allcanvs yview scroll $delta units
956 bindall <2> "canvscan mark %W %x %y"
957 bindall <B2-Motion> "canvscan dragto %W %x %y"
958 bindkey <Home> selfirstline
959 bindkey <End> sellastline
960 bind . <Key-Up> "selnextline -1"
961 bind . <Key-Down> "selnextline 1"
962 bind . <Shift-Key-Up> "dofind -1 0"
963 bind . <Shift-Key-Down> "dofind 1 0"
964 bindkey <Key-Right> "goforw"
965 bindkey <Key-Left> "goback"
966 bind . <Key-Prior> "selnextpage -1"
967 bind . <Key-Next> "selnextpage 1"
968 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
969 bind . <$M1B-End> "allcanvs yview moveto 1.0"
970 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
971 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
972 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
973 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
974 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
975 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
976 bindkey <Key-space> "$ctext yview scroll 1 pages"
977 bindkey p "selnextline -1"
978 bindkey n "selnextline 1"
981 bindkey i "selnextline -1"
982 bindkey k "selnextline 1"
985 bindkey b "$ctext yview scroll -1 pages"
986 bindkey d "$ctext yview scroll 18 units"
987 bindkey u "$ctext yview scroll -18 units"
988 bindkey / {dofind 1 1}
989 bindkey <Key-Return> {dofind 1 1}
990 bindkey ? {dofind -1 1}
992 bindkey <F5> updatecommits
993 bind . <$M1B-q> doquit
994 bind . <$M1B-f> {dofind 1 1}
995 bind . <$M1B-g> {dofind 1 0}
996 bind . <$M1B-r> dosearchback
997 bind . <$M1B-s> dosearch
998 bind . <$M1B-equal> {incrfont 1}
999 bind . <$M1B-plus> {incrfont 1}
1000 bind . <$M1B-KP_Add> {incrfont 1}
1001 bind . <$M1B-minus> {incrfont -1}
1002 bind . <$M1B-KP_Subtract> {incrfont -1}
1003 wm protocol . WM_DELETE_WINDOW doquit
1004 bind . <Button-1> "click %W"
1005 bind $fstring <Key-Return> {dofind 1 1}
1006 bind $sha1entry <Key-Return> gotocommit
1007 bind $sha1entry <<PasteSelection>> clearsha1
1008 bind $cflist <1> {sel_flist %W %x %y; break}
1009 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1010 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1011 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1013 set maincursor [. cget -cursor]
1014 set textcursor [$ctext cget -cursor]
1015 set curtextcursor $textcursor
1017 set rowctxmenu .rowctxmenu
1018 menu $rowctxmenu -tearoff 0
1019 $rowctxmenu add command -label [mc "Diff this -> selected"] \
1020 -command {diffvssel 0}
1021 $rowctxmenu add command -label [mc "Diff selected -> this"] \
1022 -command {diffvssel 1}
1023 $rowctxmenu add command -label [mc "Make patch"] -command mkpatch
1024 $rowctxmenu add command -label [mc "Create tag"] -command mktag
1025 $rowctxmenu add command -label [mc "Write commit to file"] -command writecommit
1026 $rowctxmenu add command -label [mc "Create new branch"] -command mkbranch
1027 $rowctxmenu add command -label [mc "Cherry-pick this commit"] \
1029 $rowctxmenu add command -label [mc "Reset HEAD branch to here"] \
1032 set fakerowmenu .fakerowmenu
1033 menu $fakerowmenu -tearoff 0
1034 $fakerowmenu add command -label [mc "Diff this -> selected"] \
1035 -command {diffvssel 0}
1036 $fakerowmenu add command -label [mc "Diff selected -> this"] \
1037 -command {diffvssel 1}
1038 $fakerowmenu add command -label [mc "Make patch"] -command mkpatch
1039 # $fakerowmenu add command -label [mc "Commit"] -command {mkcommit 0}
1040 # $fakerowmenu add command -label [mc "Commit all"] -command {mkcommit 1}
1041 # $fakerowmenu add command -label [mc "Revert local changes"] -command revertlocal
1043 set headctxmenu .headctxmenu
1044 menu $headctxmenu -tearoff 0
1045 $headctxmenu add command -label [mc "Check out this branch"] \
1047 $headctxmenu add command -label [mc "Remove this branch"] \
1051 set flist_menu .flistctxmenu
1052 menu $flist_menu -tearoff 0
1053 $flist_menu add command -label [mc "Highlight this too"] \
1054 -command {flist_hl 0}
1055 $flist_menu add command -label [mc "Highlight this only"] \
1056 -command {flist_hl 1}
1059 # Windows sends all mouse wheel events to the current focused window, not
1060 # the one where the mouse hovers, so bind those events here and redirect
1061 # to the correct window
1062 proc windows_mousewheel_redirector {W X Y D} {
1063 global canv canv2 canv3
1064 set w [winfo containing -displayof $W $X $Y]
1066 set u [expr {$D < 0 ? 5 : -5}]
1067 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1068 allcanvs yview scroll $u units
1071 $w yview scroll $u units
1077 # mouse-2 makes all windows scan vertically, but only the one
1078 # the cursor is in scans horizontally
1079 proc canvscan {op w x y} {
1080 global canv canv2 canv3
1081 foreach c [list $canv $canv2 $canv3] {
1090 proc scrollcanv {cscroll f0 f1} {
1091 $cscroll set $f0 $f1
1096 # when we make a key binding for the toplevel, make sure
1097 # it doesn't get triggered when that key is pressed
in the
1098 # find string entry widget.
1099 proc bindkey
{ev
script} {
1102 set escript
[bind Entry
$ev]
1103 if {$escript == {}} {
1104 set escript
[bind Entry
<Key
>]
1106 foreach e
$entries {
1107 bind $e $ev "$escript; break"
1111 # set the focus back to the toplevel for any click outside
1114 global ctext entries
1115 foreach e
[concat
$entries $ctext] {
1116 if {$w == $e} return
1121 # Adjust the progress bar for a change in requested extent or canvas size
1122 proc adjustprogress
{} {
1123 global progresscanv progressitem progresscoords
1124 global fprogitem fprogcoord lastprogupdate progupdatepending
1125 global rprogitem rprogcoord
1127 set w
[expr {[winfo width
$progresscanv] - 4}]
1128 set x0
[expr {$w * [lindex
$progresscoords 0]}]
1129 set x1
[expr {$w * [lindex
$progresscoords 1]}]
1130 set h
[winfo height
$progresscanv]
1131 $progresscanv coords
$progressitem $x0 0 $x1 $h
1132 $progresscanv coords
$fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1133 $progresscanv coords
$rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1134 set now
[clock clicks
-milliseconds]
1135 if {$now >= $lastprogupdate + 100} {
1136 set progupdatepending
0
1138 } elseif
{!$progupdatepending} {
1139 set progupdatepending
1
1140 after
[expr {$lastprogupdate + 100 - $now}] doprogupdate
1144 proc doprogupdate
{} {
1145 global lastprogupdate progupdatepending
1147 if {$progupdatepending} {
1148 set progupdatepending
0
1149 set lastprogupdate
[clock clicks
-milliseconds]
1154 proc savestuff
{w
} {
1155 global canv canv2 canv3 mainfont textfont uifont tabstop
1156 global stuffsaved findmergefiles maxgraphpct
1157 global maxwidth showneartags showlocalchanges
1158 global viewname viewfiles viewargs viewperm nextviewnum
1159 global cmitmode wrapcomment datetimeformat limitdiffs
1160 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1162 if {$stuffsaved} return
1163 if {![winfo viewable .
]} return
1165 set f
[open
"~/.gitk-new" w
]
1166 puts
$f [list
set mainfont
$mainfont]
1167 puts
$f [list
set textfont
$textfont]
1168 puts
$f [list
set uifont
$uifont]
1169 puts
$f [list
set tabstop
$tabstop]
1170 puts
$f [list
set findmergefiles
$findmergefiles]
1171 puts
$f [list
set maxgraphpct
$maxgraphpct]
1172 puts
$f [list
set maxwidth
$maxwidth]
1173 puts
$f [list
set cmitmode
$cmitmode]
1174 puts
$f [list
set wrapcomment
$wrapcomment]
1175 puts
$f [list
set showneartags
$showneartags]
1176 puts
$f [list
set showlocalchanges
$showlocalchanges]
1177 puts
$f [list
set datetimeformat
$datetimeformat]
1178 puts
$f [list
set limitdiffs
$limitdiffs]
1179 puts
$f [list
set bgcolor
$bgcolor]
1180 puts
$f [list
set fgcolor
$fgcolor]
1181 puts
$f [list
set colors
$colors]
1182 puts
$f [list
set diffcolors
$diffcolors]
1183 puts
$f [list
set diffcontext
$diffcontext]
1184 puts
$f [list
set selectbgcolor
$selectbgcolor]
1186 puts
$f "set geometry(main) [wm geometry .]"
1187 puts
$f "set geometry(topwidth) [winfo width .tf]"
1188 puts
$f "set geometry(topheight) [winfo height .tf]"
1189 puts
$f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1190 puts
$f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1191 puts
$f "set geometry(botwidth) [winfo width .bleft]"
1192 puts
$f "set geometry(botheight) [winfo height .bleft]"
1194 puts
-nonewline $f "set permviews {"
1195 for {set v
0} {$v < $nextviewnum} {incr v
} {
1196 if {$viewperm($v)} {
1197 puts
$f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1202 file rename
-force "~/.gitk-new" "~/.gitk"
1207 proc resizeclistpanes
{win w
} {
1209 if {[info exists oldwidth
($win)]} {
1210 set s0
[$win sash coord
0]
1211 set s1
[$win sash coord
1]
1213 set sash0
[expr {int
($w/2 - 2)}]
1214 set sash1
[expr {int
($w*5/6 - 2)}]
1216 set factor [expr {1.0 * $w / $oldwidth($win)}]
1217 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1218 set sash1
[expr {int
($factor * [lindex
$s1 0])}]
1222 if {$sash1 < $sash0 + 20} {
1223 set sash1
[expr {$sash0 + 20}]
1225 if {$sash1 > $w - 10} {
1226 set sash1
[expr {$w - 10}]
1227 if {$sash0 > $sash1 - 20} {
1228 set sash0
[expr {$sash1 - 20}]
1232 $win sash place
0 $sash0 [lindex
$s0 1]
1233 $win sash place
1 $sash1 [lindex
$s1 1]
1235 set oldwidth
($win) $w
1238 proc resizecdetpanes
{win w
} {
1240 if {[info exists oldwidth
($win)]} {
1241 set s0
[$win sash coord
0]
1243 set sash0
[expr {int
($w*3/4 - 2)}]
1245 set factor [expr {1.0 * $w / $oldwidth($win)}]
1246 set sash0
[expr {int
($factor * [lindex
$s0 0])}]
1250 if {$sash0 > $w - 15} {
1251 set sash0
[expr {$w - 15}]
1254 $win sash place
0 $sash0 [lindex
$s0 1]
1256 set oldwidth
($win) $w
1259 proc allcanvs args
{
1260 global canv canv2 canv3
1266 proc bindall
{event action
} {
1267 global canv canv2 canv3
1268 bind $canv $event $action
1269 bind $canv2 $event $action
1270 bind $canv3 $event $action
1276 if {[winfo exists
$w]} {
1281 wm title
$w [mc
"About gitk"]
1282 message
$w.m
-text [mc
"
1283 Gitk - a commit viewer for git
1285 Copyright © 2005-2006 Paul Mackerras
1287 Use and redistribute under the terms of the GNU General Public License"] \
1288 -justify center
-aspect 400 -border 2 -bg white
-relief groove
1289 pack
$w.m
-side top
-fill x
-padx 2 -pady 2
1290 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1291 pack
$w.ok
-side bottom
1292 bind $w <Visibility
> "focus $w.ok"
1293 bind $w <Key-Escape
> "destroy $w"
1294 bind $w <Key-Return
> "destroy $w"
1299 if {[winfo exists
$w]} {
1303 if {[tk windowingsystem
] eq
{aqua
}} {
1309 wm title
$w [mc
"Gitk key bindings"]
1310 message
$w.m
-text [mc
"
1314 <Home> Move to first commit
1315 <End> Move to last commit
1316 <Up>, p, i Move up one commit
1317 <Down>, n, k Move down one commit
1318 <Left>, z, j Go back in history list
1319 <Right>, x, l Go forward in history list
1320 <PageUp> Move up one page in commit list
1321 <PageDown> Move down one page in commit list
1322 <$M1T-Home> Scroll to top of commit list
1323 <$M1T-End> Scroll to bottom of commit list
1324 <$M1T-Up> Scroll commit list up one line
1325 <$M1T-Down> Scroll commit list down one line
1326 <$M1T-PageUp> Scroll commit list up one page
1327 <$M1T-PageDown> Scroll commit list down one page
1328 <Shift-Up> Find backwards (upwards, later commits)
1329 <Shift-Down> Find forwards (downwards, earlier commits)
1330 <Delete>, b Scroll diff view up one page
1331 <Backspace> Scroll diff view up one page
1332 <Space> Scroll diff view down one page
1333 u Scroll diff view up 18 lines
1334 d Scroll diff view down 18 lines
1336 <$M1T-G> Move to next find hit
1337 <Return> Move to next find hit
1338 / Move to next find hit, or redo find
1339 ? Move to previous find hit
1340 f Scroll diff view to next file
1341 <$M1T-S> Search for next hit in diff view
1342 <$M1T-R> Search for previous hit in diff view
1343 <$M1T-KP+> Increase font size
1344 <$M1T-plus> Increase font size
1345 <$M1T-KP-> Decrease font size
1346 <$M1T-minus> Decrease font size
1349 -justify left
-bg white
-border 2 -relief groove
1350 pack
$w.m
-side top
-fill both
-padx 2 -pady 2
1351 button
$w.ok
-text [mc
"Close"] -command "destroy $w" -default active
1352 pack
$w.ok
-side bottom
1353 bind $w <Visibility
> "focus $w.ok"
1354 bind $w <Key-Escape
> "destroy $w"
1355 bind $w <Key-Return
> "destroy $w"
1358 # Procedures for manipulating the file list window at the
1359 # bottom right of the overall window.
1361 proc treeview
{w l openlevs
} {
1362 global treecontents treediropen treeheight treeparent treeindex
1372 set treecontents
() {}
1373 $w conf
-state normal
1375 while {[string range
$f 0 $prefixend] ne
$prefix} {
1376 if {$lev <= $openlevs} {
1377 $w mark
set e
:$treeindex($prefix) "end -1c"
1378 $w mark gravity e
:$treeindex($prefix) left
1380 set treeheight
($prefix) $ht
1381 incr ht
[lindex
$htstack end
]
1382 set htstack
[lreplace
$htstack end end
]
1383 set prefixend
[lindex
$prefendstack end
]
1384 set prefendstack
[lreplace
$prefendstack end end
]
1385 set prefix
[string range
$prefix 0 $prefixend]
1388 set tail [string range
$f [expr {$prefixend+1}] end
]
1389 while {[set slash
[string first
"/" $tail]] >= 0} {
1392 lappend prefendstack
$prefixend
1393 incr prefixend
[expr {$slash + 1}]
1394 set d
[string range
$tail 0 $slash]
1395 lappend treecontents
($prefix) $d
1396 set oldprefix
$prefix
1398 set treecontents
($prefix) {}
1399 set treeindex
($prefix) [incr ix
]
1400 set treeparent
($prefix) $oldprefix
1401 set tail [string range
$tail [expr {$slash+1}] end
]
1402 if {$lev <= $openlevs} {
1404 set treediropen
($prefix) [expr {$lev < $openlevs}]
1405 set bm
[expr {$lev == $openlevs?
"tri-rt": "tri-dn"}]
1406 $w mark
set d
:$ix "end -1c"
1407 $w mark gravity d
:$ix left
1409 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1411 $w image create end
-align center
-image $bm -padx 1 \
1413 $w insert end
$d [highlight_tag
$prefix]
1414 $w mark
set s
:$ix "end -1c"
1415 $w mark gravity s
:$ix left
1420 if {$lev <= $openlevs} {
1423 for {set i
0} {$i < $lev} {incr i
} {append str
"\t"}
1425 $w insert end
$tail [highlight_tag
$f]
1427 lappend treecontents
($prefix) $tail
1430 while {$htstack ne
{}} {
1431 set treeheight
($prefix) $ht
1432 incr ht
[lindex
$htstack end
]
1433 set htstack
[lreplace
$htstack end end
]
1434 set prefixend
[lindex
$prefendstack end
]
1435 set prefendstack
[lreplace
$prefendstack end end
]
1436 set prefix
[string range
$prefix 0 $prefixend]
1438 $w conf
-state disabled
1441 proc linetoelt
{l
} {
1442 global treeheight treecontents
1447 foreach e
$treecontents($prefix) {
1452 if {[string index
$e end
] eq
"/"} {
1453 set n
$treeheight($prefix$e)
1465 proc highlight_tree
{y prefix
} {
1466 global treeheight treecontents cflist
1468 foreach e
$treecontents($prefix) {
1470 if {[highlight_tag
$path] ne
{}} {
1471 $cflist tag add bold
$y.0 "$y.0 lineend"
1474 if {[string index
$e end
] eq
"/" && $treeheight($path) > 1} {
1475 set y
[highlight_tree
$y $path]
1481 proc treeclosedir
{w dir
} {
1482 global treediropen treeheight treeparent treeindex
1484 set ix
$treeindex($dir)
1485 $w conf
-state normal
1486 $w delete s
:$ix e
:$ix
1487 set treediropen
($dir) 0
1488 $w image configure a
:$ix -image tri-rt
1489 $w conf
-state disabled
1490 set n
[expr {1 - $treeheight($dir)}]
1491 while {$dir ne
{}} {
1492 incr treeheight
($dir) $n
1493 set dir
$treeparent($dir)
1497 proc treeopendir
{w dir
} {
1498 global treediropen treeheight treeparent treecontents treeindex
1500 set ix
$treeindex($dir)
1501 $w conf
-state normal
1502 $w image configure a
:$ix -image tri-dn
1503 $w mark
set e
:$ix s
:$ix
1504 $w mark gravity e
:$ix right
1507 set n
[llength
$treecontents($dir)]
1508 for {set x
$dir} {$x ne
{}} {set x
$treeparent($x)} {
1511 incr treeheight
($x) $n
1513 foreach e
$treecontents($dir) {
1515 if {[string index
$e end
] eq
"/"} {
1516 set iy
$treeindex($de)
1517 $w mark
set d
:$iy e
:$ix
1518 $w mark gravity d
:$iy left
1519 $w insert e
:$ix $str
1520 set treediropen
($de) 0
1521 $w image create e
:$ix -align center
-image tri-rt
-padx 1 \
1523 $w insert e
:$ix $e [highlight_tag
$de]
1524 $w mark
set s
:$iy e
:$ix
1525 $w mark gravity s
:$iy left
1526 set treeheight
($de) 1
1528 $w insert e
:$ix $str
1529 $w insert e
:$ix $e [highlight_tag
$de]
1532 $w mark gravity e
:$ix left
1533 $w conf
-state disabled
1534 set treediropen
($dir) 1
1535 set top
[lindex
[split [$w index @
0,0] .
] 0]
1536 set ht
[$w cget
-height]
1537 set l
[lindex
[split [$w index s
:$ix] .
] 0]
1540 } elseif
{$l + $n + 1 > $top + $ht} {
1541 set top
[expr {$l + $n + 2 - $ht}]
1549 proc treeclick
{w x y
} {
1550 global treediropen cmitmode ctext cflist cflist_top
1552 if {$cmitmode ne
"tree"} return
1553 if {![info exists cflist_top
]} return
1554 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1555 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1556 $cflist tag add highlight
$l.0 "$l.0 lineend"
1562 set e
[linetoelt
$l]
1563 if {[string index
$e end
] ne
"/"} {
1565 } elseif
{$treediropen($e)} {
1572 proc setfilelist
{id
} {
1573 global treefilelist cflist
1575 treeview
$cflist $treefilelist($id) 0
1578 image create bitmap tri-rt
-background black
-foreground blue
-data {
1579 #define tri-rt_width 13
1580 #define tri-rt_height 13
1581 static unsigned char tri-rt_bits
[] = {
1582 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1583 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1586 #define tri-rt-mask_width 13
1587 #define tri-rt-mask_height 13
1588 static unsigned char tri-rt-mask_bits
[] = {
1589 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1590 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1593 image create bitmap tri-dn
-background black
-foreground blue
-data {
1594 #define tri-dn_width 13
1595 #define tri-dn_height 13
1596 static unsigned char tri-dn_bits
[] = {
1597 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1598 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1601 #define tri-dn-mask_width 13
1602 #define tri-dn-mask_height 13
1603 static unsigned char tri-dn-mask_bits
[] = {
1604 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1605 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1609 image create bitmap reficon-T
-background black
-foreground yellow
-data {
1610 #define tagicon_width 13
1611 #define tagicon_height 9
1612 static unsigned char tagicon_bits
[] = {
1613 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1614 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1616 #define tagicon-mask_width 13
1617 #define tagicon-mask_height 9
1618 static unsigned char tagicon-mask_bits
[] = {
1619 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1620 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1623 #define headicon_width 13
1624 #define headicon_height 9
1625 static unsigned char headicon_bits
[] = {
1626 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1627 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1630 #define headicon-mask_width 13
1631 #define headicon-mask_height 9
1632 static unsigned char headicon-mask_bits
[] = {
1633 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1634 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1636 image create bitmap reficon-H
-background black
-foreground green \
1637 -data $rectdata -maskdata $rectmask
1638 image create bitmap reficon-o
-background black
-foreground "#ddddff" \
1639 -data $rectdata -maskdata $rectmask
1641 proc init_flist
{first
} {
1642 global cflist cflist_top selectedline difffilestart
1644 $cflist conf
-state normal
1645 $cflist delete
0.0 end
1647 $cflist insert end
$first
1649 $cflist tag add highlight
1.0 "1.0 lineend"
1651 catch
{unset cflist_top
}
1653 $cflist conf
-state disabled
1654 set difffilestart
{}
1657 proc highlight_tag
{f
} {
1658 global highlight_paths
1660 foreach p
$highlight_paths {
1661 if {[string match
$p $f]} {
1668 proc highlight_filelist
{} {
1669 global cmitmode cflist
1671 $cflist conf
-state normal
1672 if {$cmitmode ne
"tree"} {
1673 set end
[lindex
[split [$cflist index end
] .
] 0]
1674 for {set l
2} {$l < $end} {incr l
} {
1675 set line
[$cflist get
$l.0 "$l.0 lineend"]
1676 if {[highlight_tag
$line] ne
{}} {
1677 $cflist tag add bold
$l.0 "$l.0 lineend"
1683 $cflist conf
-state disabled
1686 proc unhighlight_filelist
{} {
1689 $cflist conf
-state normal
1690 $cflist tag remove bold
1.0 end
1691 $cflist conf
-state disabled
1694 proc add_flist
{fl
} {
1697 $cflist conf
-state normal
1699 $cflist insert end
"\n"
1700 $cflist insert end
$f [highlight_tag
$f]
1702 $cflist conf
-state disabled
1705 proc sel_flist
{w x y
} {
1706 global ctext difffilestart cflist cflist_top cmitmode
1708 if {$cmitmode eq
"tree"} return
1709 if {![info exists cflist_top
]} return
1710 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1711 $cflist tag remove highlight
$cflist_top.0 "$cflist_top.0 lineend"
1712 $cflist tag add highlight
$l.0 "$l.0 lineend"
1717 catch
{$ctext yview
[lindex
$difffilestart [expr {$l - 2}]]}
1721 proc pop_flist_menu
{w X Y x y
} {
1722 global ctext cflist cmitmode flist_menu flist_menu_file
1723 global treediffs diffids
1726 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
1728 if {$cmitmode eq
"tree"} {
1729 set e
[linetoelt
$l]
1730 if {[string index
$e end
] eq
"/"} return
1732 set e
[lindex
$treediffs($diffids) [expr {$l-2}]]
1734 set flist_menu_file
$e
1735 tk_popup
$flist_menu $X $Y
1738 proc flist_hl
{only
} {
1739 global flist_menu_file findstring gdttype
1741 set x
[shellquote
$flist_menu_file]
1742 if {$only ||
$findstring eq
{} ||
$gdttype ne
[mc
"touching paths:"]} {
1745 append findstring
" " $x
1747 set gdttype
[mc
"touching paths:"]
1750 # Functions for adding and removing shell-type quoting
1752 proc shellquote
{str
} {
1753 if {![string match
"*\['\"\\ \t]*" $str]} {
1756 if {![string match
"*\['\"\\]*" $str]} {
1759 if {![string match
"*'*" $str]} {
1762 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1765 proc shellarglist
{l
} {
1771 append str
[shellquote
$a]
1776 proc shelldequote
{str
} {
1781 if {![regexp
-start $used -indices "\['\"\\\\ \t]" $str first
]} {
1782 append ret
[string range
$str $used end
]
1783 set used
[string length
$str]
1786 set first
[lindex
$first 0]
1787 set ch
[string index
$str $first]
1788 if {$first > $used} {
1789 append ret
[string range
$str $used [expr {$first - 1}]]
1792 if {$ch eq
" " ||
$ch eq
"\t"} break
1795 set first
[string first
"'" $str $used]
1797 error
"unmatched single-quote"
1799 append ret
[string range
$str $used [expr {$first - 1}]]
1804 if {$used >= [string length
$str]} {
1805 error
"trailing backslash"
1807 append ret
[string index
$str $used]
1812 if {![regexp
-start $used -indices "\[\"\\\\]" $str first
]} {
1813 error
"unmatched double-quote"
1815 set first
[lindex
$first 0]
1816 set ch
[string index
$str $first]
1817 if {$first > $used} {
1818 append ret
[string range
$str $used [expr {$first - 1}]]
1821 if {$ch eq
"\""} break
1823 append ret
[string index
$str $used]
1827 return [list
$used $ret]
1830 proc shellsplit
{str
} {
1833 set str
[string trimleft
$str]
1834 if {$str eq
{}} break
1835 set dq
[shelldequote
$str]
1836 set n
[lindex
$dq 0]
1837 set word
[lindex
$dq 1]
1838 set str
[string range
$str $n end
]
1844 # Code to implement multiple views
1846 proc newview
{ishighlight
} {
1847 global nextviewnum newviewname newviewperm newishighlight
1848 global newviewargs revtreeargs
1850 set newishighlight
$ishighlight
1852 if {[winfo exists
$top]} {
1856 set newviewname
($nextviewnum) "View $nextviewnum"
1857 set newviewperm
($nextviewnum) 0
1858 set newviewargs
($nextviewnum) [shellarglist
$revtreeargs]
1859 vieweditor
$top $nextviewnum [mc
"Gitk view definition"]
1864 global viewname viewperm newviewname newviewperm
1865 global viewargs newviewargs
1867 set top .gitkvedit-
$curview
1868 if {[winfo exists
$top]} {
1872 set newviewname
($curview) $viewname($curview)
1873 set newviewperm
($curview) $viewperm($curview)
1874 set newviewargs
($curview) [shellarglist
$viewargs($curview)]
1875 vieweditor
$top $curview "Gitk: edit view $viewname($curview)"
1878 proc vieweditor
{top n title
} {
1879 global newviewname newviewperm viewfiles bgcolor
1882 wm title
$top $title
1883 label
$top.
nl -text [mc
"Name"]
1884 entry
$top.name
-width 20 -textvariable newviewname
($n)
1885 grid
$top.
nl $top.name
-sticky w
-pady 5
1886 checkbutton
$top.perm
-text [mc
"Remember this view"] \
1887 -variable newviewperm
($n)
1888 grid
$top.perm
- -pady 5 -sticky w
1889 message
$top.al
-aspect 1000 \
1890 -text [mc
"Commits to include (arguments to git rev-list):"]
1891 grid
$top.al
- -sticky w
-pady 5
1892 entry
$top.args
-width 50 -textvariable newviewargs
($n) \
1893 -background $bgcolor
1894 grid
$top.args
- -sticky ew
-padx 5
1895 message
$top.l
-aspect 1000 \
1896 -text [mc
"Enter files and directories to include, one per line:"]
1897 grid
$top.l
- -sticky w
1898 text
$top.t
-width 40 -height 10 -background $bgcolor -font uifont
1899 if {[info exists viewfiles
($n)]} {
1900 foreach f
$viewfiles($n) {
1901 $top.t insert end
$f
1902 $top.t insert end
"\n"
1904 $top.t delete
{end
- 1c
} end
1905 $top.t mark
set insert
0.0
1907 grid
$top.t
- -sticky ew
-padx 5
1909 button
$top.buts.ok
-text [mc
"OK"] -command [list newviewok
$top $n]
1910 button
$top.buts.can
-text [mc
"Cancel"] -command [list destroy
$top]
1911 grid
$top.buts.ok
$top.buts.can
1912 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
1913 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
1914 grid
$top.buts
- -pady 10 -sticky ew
1918 proc doviewmenu
{m first cmd op argv
} {
1919 set nmenu
[$m index end
]
1920 for {set i
$first} {$i <= $nmenu} {incr i
} {
1921 if {[$m entrycget
$i -command] eq
$cmd} {
1922 eval $m $op $i $argv
1928 proc allviewmenus
{n op args
} {
1931 doviewmenu .bar.view
5 [list showview
$n] $op $args
1932 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1935 proc newviewok
{top n
} {
1936 global nextviewnum newviewperm newviewname newishighlight
1937 global viewname viewfiles viewperm selectedview curview
1938 global viewargs newviewargs viewhlmenu
1941 set newargs
[shellsplit
$newviewargs($n)]
1943 error_popup
"[mc "Error
in commit selection arguments
:"] $err"
1949 foreach f
[split [$top.t get
0.0 end
] "\n"] {
1950 set ft
[string trim
$f]
1955 if {![info exists viewfiles
($n)]} {
1956 # creating a new view
1958 set viewname
($n) $newviewname($n)
1959 set viewperm
($n) $newviewperm($n)
1960 set viewfiles
($n) $files
1961 set viewargs
($n) $newargs
1963 if {!$newishighlight} {
1966 run addvhighlight
$n
1969 # editing an existing view
1970 set viewperm
($n) $newviewperm($n)
1971 if {$newviewname($n) ne
$viewname($n)} {
1972 set viewname
($n) $newviewname($n)
1973 doviewmenu .bar.view
5 [list showview
$n] \
1974 entryconf
[list
-label $viewname($n)]
1975 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1976 # entryconf [list -label $viewname($n) -value $viewname($n)]
1978 if {$files ne
$viewfiles($n) ||
$newargs ne
$viewargs($n)} {
1979 set viewfiles
($n) $files
1980 set viewargs
($n) $newargs
1981 if {$curview == $n} {
1986 catch
{destroy
$top}
1990 global curview viewdata viewperm hlview selectedhlview
1992 if {$curview == 0} return
1993 if {[info exists hlview
] && $hlview == $curview} {
1994 set selectedhlview
[mc
"None"]
1997 allviewmenus
$curview delete
1998 set viewdata
($curview) {}
1999 set viewperm
($curview) 0
2003 proc addviewmenu
{n
} {
2004 global viewname viewhlmenu
2006 .bar.view add radiobutton
-label $viewname($n) \
2007 -command [list showview
$n] -variable selectedview
-value $n
2008 #$viewhlmenu add radiobutton -label $viewname($n) \
2009 # -command [list addvhighlight $n] -variable selectedhlview
2012 proc flatten
{var
} {
2016 foreach i
[array names
$var] {
2017 lappend ret
$i [set $var\
($i\
)]
2022 proc unflatten
{var l
} {
2032 global curview viewdata viewfiles
2033 global displayorder parentlist rowidlist rowisopt rowfinal
2034 global colormap rowtextx commitrow nextcolor canvxmax
2035 global numcommits commitlisted
2036 global selectedline currentid canv canvy0
2038 global pending_select phase
2041 global selectedview selectfirst
2042 global vparentlist vdisporder vcmitlisted
2043 global hlview selectedhlview commitinterest
2045 if {$n == $curview} return
2047 if {[info exists selectedline
]} {
2048 set selid
$currentid
2049 set y
[yc
$selectedline]
2050 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2051 set span
[$canv yview
]
2052 set ytop
[expr {[lindex
$span 0] * $ymax}]
2053 set ybot
[expr {[lindex
$span 1] * $ymax}]
2054 if {$ytop < $y && $y < $ybot} {
2055 set yscreen
[expr {$y - $ytop}]
2057 set yscreen
[expr {($ybot - $ytop) / 2}]
2059 } elseif
{[info exists pending_select
]} {
2060 set selid
$pending_select
2061 unset pending_select
2065 if {$curview >= 0} {
2066 set vparentlist
($curview) $parentlist
2067 set vdisporder
($curview) $displayorder
2068 set vcmitlisted
($curview) $commitlisted
2070 ![info exists viewdata
($curview)] ||
2071 [lindex
$viewdata($curview) 0] ne
{}} {
2072 set viewdata
($curview) \
2073 [list
$phase $rowidlist $rowisopt $rowfinal]
2076 catch
{unset treediffs
}
2078 if {[info exists hlview
] && $hlview == $n} {
2080 set selectedhlview
[mc
"None"]
2082 catch
{unset commitinterest
}
2086 .bar.view entryconf
[mc
"Edit view..."] -state [expr {$n == 0?
"disabled": "normal"}]
2087 .bar.view entryconf
[mc
"Delete view"] -state [expr {$n == 0?
"disabled": "normal"}]
2090 if {![info exists viewdata
($n)]} {
2092 set pending_select
$selid
2099 set phase
[lindex
$v 0]
2100 set displayorder
$vdisporder($n)
2101 set parentlist
$vparentlist($n)
2102 set commitlisted
$vcmitlisted($n)
2103 set rowidlist
[lindex
$v 1]
2104 set rowisopt
[lindex
$v 2]
2105 set rowfinal
[lindex
$v 3]
2106 set numcommits
$commitidx($n)
2108 catch
{unset colormap
}
2109 catch
{unset rowtextx
}
2111 set canvxmax
[$canv cget
-width]
2118 if {$selid ne
{} && [info exists commitrow
($n,$selid)]} {
2119 set row
$commitrow($n,$selid)
2120 # try to get the selected row in the same position on the screen
2121 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2122 set ytop
[expr {[yc
$row] - $yscreen}]
2126 set yf
[expr {$ytop * 1.0 / $ymax}]
2128 allcanvs yview moveto
$yf
2132 } elseif
{$selid ne
{}} {
2133 set pending_select
$selid
2135 set row
[first_real_row
]
2136 if {$row < $numcommits} {
2143 if {$phase eq
"getcommits"} {
2144 show_status
[mc
"Reading commits..."]
2147 } elseif
{$numcommits == 0} {
2148 show_status
[mc
"No commits selected"]
2152 # Stuff relating to the highlighting facility
2154 proc ishighlighted
{row
} {
2155 global vhighlights fhighlights nhighlights rhighlights
2157 if {[info exists nhighlights
($row)] && $nhighlights($row) > 0} {
2158 return $nhighlights($row)
2160 if {[info exists vhighlights
($row)] && $vhighlights($row) > 0} {
2161 return $vhighlights($row)
2163 if {[info exists fhighlights
($row)] && $fhighlights($row) > 0} {
2164 return $fhighlights($row)
2166 if {[info exists rhighlights
($row)] && $rhighlights($row) > 0} {
2167 return $rhighlights($row)
2172 proc bolden
{row font
} {
2173 global canv linehtag selectedline boldrows
2175 lappend boldrows
$row
2176 $canv itemconf
$linehtag($row) -font $font
2177 if {[info exists selectedline
] && $row == $selectedline} {
2179 set t
[eval $canv create rect
[$canv bbox
$linehtag($row)] \
2180 -outline {{}} -tags secsel \
2181 -fill [$canv cget
-selectbackground]]
2186 proc bolden_name
{row font
} {
2187 global canv2 linentag selectedline boldnamerows
2189 lappend boldnamerows
$row
2190 $canv2 itemconf
$linentag($row) -font $font
2191 if {[info exists selectedline
] && $row == $selectedline} {
2192 $canv2 delete secsel
2193 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($row)] \
2194 -outline {{}} -tags secsel \
2195 -fill [$canv2 cget
-selectbackground]]
2204 foreach row
$boldrows {
2205 if {![ishighlighted
$row]} {
2206 bolden
$row mainfont
2208 lappend stillbold
$row
2211 set boldrows
$stillbold
2214 proc addvhighlight
{n
} {
2215 global hlview curview viewdata vhl_done vhighlights commitidx
2217 if {[info exists hlview
]} {
2221 if {$n != $curview && ![info exists viewdata
($n)]} {
2222 set viewdata
($n) [list getcommits
{{}} 0 0 0]
2223 set vparentlist
($n) {}
2224 set vdisporder
($n) {}
2225 set vcmitlisted
($n) {}
2228 set vhl_done
$commitidx($hlview)
2229 if {$vhl_done > 0} {
2234 proc delvhighlight
{} {
2235 global hlview vhighlights
2237 if {![info exists hlview
]} return
2239 catch
{unset vhighlights
}
2243 proc vhighlightmore
{} {
2244 global hlview vhl_done commitidx vhighlights
2245 global displayorder vdisporder curview
2247 set max
$commitidx($hlview)
2248 if {$hlview == $curview} {
2249 set disp
$displayorder
2251 set disp
$vdisporder($hlview)
2253 set vr
[visiblerows
]
2254 set r0
[lindex
$vr 0]
2255 set r1
[lindex
$vr 1]
2256 for {set i
$vhl_done} {$i < $max} {incr i
} {
2257 set id
[lindex
$disp $i]
2258 if {[info exists commitrow
($curview,$id)]} {
2259 set row
$commitrow($curview,$id)
2260 if {$r0 <= $row && $row <= $r1} {
2261 if {![highlighted
$row]} {
2262 bolden
$row mainfontbold
2264 set vhighlights
($row) 1
2271 proc askvhighlight
{row id
} {
2272 global hlview vhighlights commitrow iddrawn
2274 if {[info exists commitrow
($hlview,$id)]} {
2275 if {[info exists iddrawn
($id)] && ![ishighlighted
$row]} {
2276 bolden
$row mainfontbold
2278 set vhighlights
($row) 1
2280 set vhighlights
($row) 0
2284 proc hfiles_change
{} {
2285 global highlight_files filehighlight fhighlights fh_serial
2286 global highlight_paths gdttype
2288 if {[info exists filehighlight
]} {
2289 # delete previous highlights
2290 catch
{close
$filehighlight}
2292 catch
{unset fhighlights
}
2294 unhighlight_filelist
2296 set highlight_paths
{}
2297 after cancel do_file_hl
$fh_serial
2299 if {$highlight_files ne
{}} {
2300 after
300 do_file_hl
$fh_serial
2304 proc gdttype_change
{name ix op
} {
2305 global gdttype highlight_files findstring findpattern
2308 if {$findstring ne
{}} {
2309 if {$gdttype eq
[mc
"containing:"]} {
2310 if {$highlight_files ne
{}} {
2311 set highlight_files
{}
2316 if {$findpattern ne
{}} {
2320 set highlight_files
$findstring
2325 # enable/disable findtype/findloc menus too
2328 proc find_change
{name ix op
} {
2329 global gdttype findstring highlight_files
2332 if {$gdttype eq
[mc
"containing:"]} {
2335 if {$highlight_files ne
$findstring} {
2336 set highlight_files
$findstring
2343 proc findcom_change args
{
2344 global nhighlights boldnamerows
2345 global findpattern findtype findstring gdttype
2348 # delete previous highlights, if any
2349 foreach row
$boldnamerows {
2350 bolden_name
$row mainfont
2353 catch
{unset nhighlights
}
2356 if {$gdttype ne
[mc
"containing:"] ||
$findstring eq
{}} {
2358 } elseif
{$findtype eq
[mc
"Regexp"]} {
2359 set findpattern
$findstring
2361 set e
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2363 set findpattern
"*$e*"
2367 proc makepatterns
{l
} {
2370 set ee
[string map
{"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2371 if {[string index
$ee end
] eq
"/"} {
2381 proc do_file_hl
{serial
} {
2382 global highlight_files filehighlight highlight_paths gdttype fhl_list
2384 if {$gdttype eq
[mc
"touching paths:"]} {
2385 if {[catch
{set paths
[shellsplit
$highlight_files]}]} return
2386 set highlight_paths
[makepatterns
$paths]
2388 set gdtargs
[concat
-- $paths]
2389 } elseif
{$gdttype eq
[mc
"adding/removing string:"]} {
2390 set gdtargs
[list
"-S$highlight_files"]
2392 # must be "containing:", i.e. we're searching commit info
2395 set cmd
[concat | git diff-tree
-r -s --stdin $gdtargs]
2396 set filehighlight
[open
$cmd r
+]
2397 fconfigure
$filehighlight -blocking 0
2398 filerun
$filehighlight readfhighlight
2404 proc flushhighlights
{} {
2405 global filehighlight fhl_list
2407 if {[info exists filehighlight
]} {
2409 puts
$filehighlight ""
2410 flush
$filehighlight
2414 proc askfilehighlight
{row id
} {
2415 global filehighlight fhighlights fhl_list
2417 lappend fhl_list
$id
2418 set fhighlights
($row) -1
2419 puts
$filehighlight $id
2422 proc readfhighlight
{} {
2423 global filehighlight fhighlights commitrow curview iddrawn
2424 global fhl_list find_dirn
2426 if {![info exists filehighlight
]} {
2430 while {[incr nr
] <= 100 && [gets
$filehighlight line
] >= 0} {
2431 set line
[string trim
$line]
2432 set i
[lsearch
-exact $fhl_list $line]
2433 if {$i < 0} continue
2434 for {set j
0} {$j < $i} {incr j
} {
2435 set id
[lindex
$fhl_list $j]
2436 if {[info exists commitrow
($curview,$id)]} {
2437 set fhighlights
($commitrow($curview,$id)) 0
2440 set fhl_list
[lrange
$fhl_list [expr {$i+1}] end
]
2441 if {$line eq
{}} continue
2442 if {![info exists commitrow
($curview,$line)]} continue
2443 set row
$commitrow($curview,$line)
2444 if {[info exists iddrawn
($line)] && ![ishighlighted
$row]} {
2445 bolden
$row mainfontbold
2447 set fhighlights
($row) 1
2449 if {[eof
$filehighlight]} {
2451 puts
"oops, git diff-tree died"
2452 catch
{close
$filehighlight}
2456 if {[info exists find_dirn
]} {
2462 proc doesmatch
{f
} {
2463 global findtype findpattern
2465 if {$findtype eq
[mc
"Regexp"]} {
2466 return [regexp
$findpattern $f]
2467 } elseif
{$findtype eq
[mc
"IgnCase"]} {
2468 return [string match
-nocase $findpattern $f]
2470 return [string match
$findpattern $f]
2474 proc askfindhighlight
{row id
} {
2475 global nhighlights commitinfo iddrawn
2477 global markingmatches
2479 if {![info exists commitinfo
($id)]} {
2482 set info
$commitinfo($id)
2484 set fldtypes
[list
[mc Headline
] [mc Author
] [mc Date
] [mc Committer
] [mc CDate
] [mc Comments
]]
2485 foreach f
$info ty
$fldtypes {
2486 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
2488 if {$ty eq
[mc
"Author"]} {
2495 if {$isbold && [info exists iddrawn
($id)]} {
2496 if {![ishighlighted
$row]} {
2497 bolden
$row mainfontbold
2499 bolden_name
$row mainfontbold
2502 if {$markingmatches} {
2503 markrowmatches
$row $id
2506 set nhighlights
($row) $isbold
2509 proc markrowmatches
{row id
} {
2510 global canv canv2 linehtag linentag commitinfo findloc
2512 set headline
[lindex
$commitinfo($id) 0]
2513 set author
[lindex
$commitinfo($id) 1]
2514 $canv delete match
$row
2515 $canv2 delete match
$row
2516 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Headline"]} {
2517 set m
[findmatches
$headline]
2519 markmatches
$canv $row $headline $linehtag($row) $m \
2520 [$canv itemcget
$linehtag($row) -font] $row
2523 if {$findloc eq
[mc
"All fields"] ||
$findloc eq
[mc
"Author"]} {
2524 set m
[findmatches
$author]
2526 markmatches
$canv2 $row $author $linentag($row) $m \
2527 [$canv2 itemcget
$linentag($row) -font] $row
2532 proc vrel_change
{name ix op
} {
2533 global highlight_related
2536 if {$highlight_related ne
[mc
"None"]} {
2541 # prepare for testing whether commits are descendents or ancestors of a
2542 proc rhighlight_sel
{a
} {
2543 global descendent desc_todo ancestor anc_todo
2544 global highlight_related rhighlights
2546 catch
{unset descendent
}
2547 set desc_todo
[list
$a]
2548 catch
{unset ancestor
}
2549 set anc_todo
[list
$a]
2550 if {$highlight_related ne
[mc
"None"]} {
2556 proc rhighlight_none
{} {
2559 catch
{unset rhighlights
}
2563 proc is_descendent
{a
} {
2564 global curview children commitrow descendent desc_todo
2567 set la
$commitrow($v,$a)
2571 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2572 set do [lindex
$todo $i]
2573 if {$commitrow($v,$do) < $la} {
2574 lappend leftover
$do
2577 foreach nk
$children($v,$do) {
2578 if {![info exists descendent
($nk)]} {
2579 set descendent
($nk) 1
2587 set desc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2591 set descendent
($a) 0
2592 set desc_todo
$leftover
2595 proc is_ancestor
{a
} {
2596 global curview parentlist commitrow ancestor anc_todo
2599 set la
$commitrow($v,$a)
2603 for {set i
0} {$i < [llength
$todo]} {incr i
} {
2604 set do [lindex
$todo $i]
2605 if {![info exists commitrow
($v,$do)] ||
$commitrow($v,$do) > $la} {
2606 lappend leftover
$do
2609 foreach np
[lindex
$parentlist $commitrow($v,$do)] {
2610 if {![info exists ancestor
($np)]} {
2619 set anc_todo
[concat
$leftover [lrange
$todo [expr {$i+1}] end
]]
2624 set anc_todo
$leftover
2627 proc askrelhighlight
{row id
} {
2628 global descendent highlight_related iddrawn rhighlights
2629 global selectedline ancestor
2631 if {![info exists selectedline
]} return
2633 if {$highlight_related eq
[mc
"Descendant"] ||
2634 $highlight_related eq
[mc
"Not descendant"]} {
2635 if {![info exists descendent
($id)]} {
2638 if {$descendent($id) == ($highlight_related eq
[mc
"Descendant"])} {
2641 } elseif
{$highlight_related eq
[mc
"Ancestor"] ||
2642 $highlight_related eq
[mc
"Not ancestor"]} {
2643 if {![info exists ancestor
($id)]} {
2646 if {$ancestor($id) == ($highlight_related eq
[mc
"Ancestor"])} {
2650 if {[info exists iddrawn
($id)]} {
2651 if {$isbold && ![ishighlighted
$row]} {
2652 bolden
$row mainfontbold
2655 set rhighlights
($row) $isbold
2658 # Graph layout functions
2660 proc shortids
{ids
} {
2663 if {[llength
$id] > 1} {
2664 lappend res
[shortids
$id]
2665 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $id]} {
2666 lappend res
[string range
$id 0 7]
2677 for {set mask
1} {$mask <= $n} {incr mask
$mask} {
2678 if {($n & $mask) != 0} {
2679 set ret
[concat
$ret $o]
2681 set o
[concat
$o $o]
2686 # Work out where id should go in idlist so that order-token
2687 # values increase from left to right
2688 proc idcol
{idlist id
{i
0}} {
2689 global ordertok curview
2691 set t
$ordertok($curview,$id)
2692 if {$i >= [llength
$idlist] ||
2693 $t < $ordertok($curview,[lindex
$idlist $i])} {
2694 if {$i > [llength
$idlist]} {
2695 set i
[llength
$idlist]
2697 while {[incr i
-1] >= 0 &&
2698 $t < $ordertok($curview,[lindex
$idlist $i])} {}
2701 if {$t > $ordertok($curview,[lindex
$idlist $i])} {
2702 while {[incr i
] < [llength
$idlist] &&
2703 $t >= $ordertok($curview,[lindex
$idlist $i])} {}
2709 proc initlayout
{} {
2710 global rowidlist rowisopt rowfinal displayorder commitlisted
2711 global numcommits canvxmax canv
2714 global colormap rowtextx
2725 set canvxmax
[$canv cget
-width]
2726 catch
{unset colormap
}
2727 catch
{unset rowtextx
}
2731 proc setcanvscroll
{} {
2732 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2734 set ymax
[expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2735 $canv conf
-scrollregion [list
0 0 $canvxmax $ymax]
2736 $canv2 conf
-scrollregion [list
0 0 0 $ymax]
2737 $canv3 conf
-scrollregion [list
0 0 0 $ymax]
2740 proc visiblerows
{} {
2741 global canv numcommits linespc
2743 set ymax
[lindex
[$canv cget
-scrollregion] 3]
2744 if {$ymax eq
{} ||
$ymax == 0} return
2746 set y0
[expr {int
([lindex
$f 0] * $ymax)}]
2747 set r0
[expr {int
(($y0 - 3) / $linespc) - 1}]
2751 set y1
[expr {int
([lindex
$f 1] * $ymax)}]
2752 set r1
[expr {int
(($y1 - 3) / $linespc) + 1}]
2753 if {$r1 >= $numcommits} {
2754 set r1
[expr {$numcommits - 1}]
2756 return [list
$r0 $r1]
2759 proc layoutmore
{} {
2760 global commitidx viewcomplete numcommits
2761 global uparrowlen downarrowlen mingaplen curview
2763 set show
$commitidx($curview)
2764 if {$show > $numcommits ||
$viewcomplete($curview)} {
2765 showstuff
$show $viewcomplete($curview)
2769 proc showstuff
{canshow last
} {
2770 global numcommits commitrow pending_select selectedline curview
2771 global mainheadid displayorder selectfirst
2772 global lastscrollset commitinterest
2774 if {$numcommits == 0} {
2776 set phase
"incrdraw"
2780 set prev
$numcommits
2781 set numcommits
$canshow
2782 set t
[clock clicks
-milliseconds]
2783 if {$prev < 100 ||
$last ||
$t - $lastscrollset > 500} {
2784 set lastscrollset
$t
2787 set rows
[visiblerows
]
2788 set r1
[lindex
$rows 1]
2789 if {$r1 >= $canshow} {
2790 set r1
[expr {$canshow - 1}]
2795 if {[info exists pending_select
] &&
2796 [info exists commitrow
($curview,$pending_select)] &&
2797 $commitrow($curview,$pending_select) < $numcommits} {
2798 selectline
$commitrow($curview,$pending_select) 1
2801 if {[info exists selectedline
] ||
[info exists pending_select
]} {
2804 set l
[first_real_row
]
2811 proc doshowlocalchanges
{} {
2812 global curview mainheadid phase commitrow
2814 if {[info exists commitrow
($curview,$mainheadid)] &&
2815 ($phase eq
{} ||
$commitrow($curview,$mainheadid) < $numcommits - 1)} {
2817 } elseif
{$phase ne
{}} {
2818 lappend commitinterest
($mainheadid) {}
2822 proc dohidelocalchanges
{} {
2823 global localfrow localirow lserial
2825 if {$localfrow >= 0} {
2826 removerow
$localfrow
2828 if {$localirow > 0} {
2832 if {$localirow >= 0} {
2833 removerow
$localirow
2839 # spawn off a process to do git diff-index --cached HEAD
2840 proc dodiffindex
{} {
2841 global localirow localfrow lserial showlocalchanges
2843 if {!$showlocalchanges} return
2847 set fd
[open
"|git diff-index --cached HEAD" r
]
2848 fconfigure
$fd -blocking 0
2849 filerun
$fd [list readdiffindex
$fd $lserial]
2852 proc readdiffindex
{fd serial
} {
2853 global localirow commitrow mainheadid nullid2 curview
2854 global commitinfo commitdata lserial
2857 if {[gets
$fd line
] < 0} {
2863 # we only need to see one line and we don't really care what it says...
2866 # now see if there are any local changes not checked in to the index
2867 if {$serial == $lserial} {
2868 set fd
[open
"|git diff-files" r
]
2869 fconfigure
$fd -blocking 0
2870 filerun
$fd [list readdifffiles
$fd $serial]
2873 if {$isdiff && $serial == $lserial && $localirow == -1} {
2874 # add the line for the changes in the index to the graph
2875 set localirow
$commitrow($curview,$mainheadid)
2876 set hl
[mc
"Local changes checked in to index but not committed"]
2877 set commitinfo
($nullid2) [list
$hl {} {} {} {} " $hl\n"]
2878 set commitdata
($nullid2) "\n $hl\n"
2879 insertrow
$localirow $nullid2
2884 proc readdifffiles
{fd serial
} {
2885 global localirow localfrow commitrow mainheadid nullid curview
2886 global commitinfo commitdata lserial
2889 if {[gets
$fd line
] < 0} {
2895 # we only need to see one line and we don't really care what it says...
2898 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2899 # add the line for the local diff to the graph
2900 if {$localirow >= 0} {
2901 set localfrow
$localirow
2904 set localfrow
$commitrow($curview,$mainheadid)
2906 set hl
[mc
"Local uncommitted changes, not checked in to index"]
2907 set commitinfo
($nullid) [list
$hl {} {} {} {} " $hl\n"]
2908 set commitdata
($nullid) "\n $hl\n"
2909 insertrow
$localfrow $nullid
2914 proc nextuse
{id row
} {
2915 global commitrow curview children
2917 if {[info exists children
($curview,$id)]} {
2918 foreach kid
$children($curview,$id) {
2919 if {![info exists commitrow
($curview,$kid)]} {
2922 if {$commitrow($curview,$kid) > $row} {
2923 return $commitrow($curview,$kid)
2927 if {[info exists commitrow
($curview,$id)]} {
2928 return $commitrow($curview,$id)
2933 proc prevuse
{id row
} {
2934 global commitrow curview children
2937 if {[info exists children
($curview,$id)]} {
2938 foreach kid
$children($curview,$id) {
2939 if {![info exists commitrow
($curview,$kid)]} break
2940 if {$commitrow($curview,$kid) < $row} {
2941 set ret
$commitrow($curview,$kid)
2948 proc make_idlist
{row
} {
2949 global displayorder parentlist uparrowlen downarrowlen mingaplen
2950 global commitidx curview ordertok children commitrow
2952 set r
[expr {$row - $mingaplen - $downarrowlen - 1}]
2956 set ra
[expr {$row - $downarrowlen}]
2960 set rb
[expr {$row + $uparrowlen}]
2961 if {$rb > $commitidx($curview)} {
2962 set rb
$commitidx($curview)
2965 for {} {$r < $ra} {incr r
} {
2966 set nextid
[lindex
$displayorder [expr {$r + 1}]]
2967 foreach p
[lindex
$parentlist $r] {
2968 if {$p eq
$nextid} continue
2969 set rn
[nextuse
$p $r]
2971 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2972 lappend ids
[list
$ordertok($curview,$p) $p]
2976 for {} {$r < $row} {incr r
} {
2977 set nextid
[lindex
$displayorder [expr {$r + 1}]]
2978 foreach p
[lindex
$parentlist $r] {
2979 if {$p eq
$nextid} continue
2980 set rn
[nextuse
$p $r]
2981 if {$rn < 0 ||
$rn >= $row} {
2982 lappend ids
[list
$ordertok($curview,$p) $p]
2986 set id
[lindex
$displayorder $row]
2987 lappend ids
[list
$ordertok($curview,$id) $id]
2989 foreach p
[lindex
$parentlist $r] {
2990 set firstkid
[lindex
$children($curview,$p) 0]
2991 if {$commitrow($curview,$firstkid) < $row} {
2992 lappend ids
[list
$ordertok($curview,$p) $p]
2996 set id
[lindex
$displayorder $r]
2998 set firstkid
[lindex
$children($curview,$id) 0]
2999 if {$firstkid ne
{} && $commitrow($curview,$firstkid) < $row} {
3000 lappend ids
[list
$ordertok($curview,$id) $id]
3005 foreach idx
[lsort
-unique $ids] {
3006 lappend idlist
[lindex
$idx 1]
3011 proc rowsequal
{a b
} {
3012 while {[set i
[lsearch
-exact $a {}]] >= 0} {
3013 set a
[lreplace
$a $i $i]
3015 while {[set i
[lsearch
-exact $b {}]] >= 0} {
3016 set b
[lreplace
$b $i $i]
3018 return [expr {$a eq
$b}]
3021 proc makeupline
{id row rend
col} {
3022 global rowidlist uparrowlen downarrowlen mingaplen
3024 for {set r
$rend} {1} {set r
$rstart} {
3025 set rstart
[prevuse
$id $r]
3026 if {$rstart < 0} return
3027 if {$rstart < $row} break
3029 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3030 set rstart
[expr {$rend - $uparrowlen - 1}]
3032 for {set r
$rstart} {[incr r
] <= $row} {} {
3033 set idlist
[lindex
$rowidlist $r]
3034 if {$idlist ne
{} && [lsearch
-exact $idlist $id] < 0} {
3035 set col [idcol
$idlist $id $col]
3036 lset rowidlist
$r [linsert
$idlist $col $id]
3042 proc layoutrows
{row endrow
} {
3043 global rowidlist rowisopt rowfinal displayorder
3044 global uparrowlen downarrowlen maxwidth mingaplen
3045 global children parentlist
3046 global commitidx viewcomplete curview commitrow
3050 set rm1
[expr {$row - 1}]
3051 foreach id
[lindex
$rowidlist $rm1] {
3056 set final
[lindex
$rowfinal $rm1]
3058 for {} {$row < $endrow} {incr row
} {
3059 set rm1
[expr {$row - 1}]
3060 if {$rm1 < 0 ||
$idlist eq
{}} {
3061 set idlist
[make_idlist
$row]
3064 set id
[lindex
$displayorder $rm1]
3065 set col [lsearch
-exact $idlist $id]
3066 set idlist
[lreplace
$idlist $col $col]
3067 foreach p
[lindex
$parentlist $rm1] {
3068 if {[lsearch
-exact $idlist $p] < 0} {
3069 set col [idcol
$idlist $p $col]
3070 set idlist
[linsert
$idlist $col $p]
3071 # if not the first child, we have to insert a line going up
3072 if {$id ne
[lindex
$children($curview,$p) 0]} {
3073 makeupline
$p $rm1 $row $col
3077 set id
[lindex
$displayorder $row]
3078 if {$row > $downarrowlen} {
3079 set termrow
[expr {$row - $downarrowlen - 1}]
3080 foreach p
[lindex
$parentlist $termrow] {
3081 set i
[lsearch
-exact $idlist $p]
3082 if {$i < 0} continue
3083 set nr
[nextuse
$p $termrow]
3084 if {$nr < 0 ||
$nr >= $row + $mingaplen + $uparrowlen} {
3085 set idlist
[lreplace
$idlist $i $i]
3089 set col [lsearch
-exact $idlist $id]
3091 set col [idcol
$idlist $id]
3092 set idlist
[linsert
$idlist $col $id]
3093 if {$children($curview,$id) ne
{}} {
3094 makeupline
$id $rm1 $row $col
3097 set r
[expr {$row + $uparrowlen - 1}]
3098 if {$r < $commitidx($curview)} {
3100 foreach p
[lindex
$parentlist $r] {
3101 if {[lsearch
-exact $idlist $p] >= 0} continue
3102 set fk
[lindex
$children($curview,$p) 0]
3103 if {$commitrow($curview,$fk) < $row} {
3104 set x
[idcol
$idlist $p $x]
3105 set idlist
[linsert
$idlist $x $p]
3108 if {[incr r
] < $commitidx($curview)} {
3109 set p
[lindex
$displayorder $r]
3110 if {[lsearch
-exact $idlist $p] < 0} {
3111 set fk
[lindex
$children($curview,$p) 0]
3112 if {$fk ne
{} && $commitrow($curview,$fk) < $row} {
3113 set x
[idcol
$idlist $p $x]
3114 set idlist
[linsert
$idlist $x $p]
3120 if {$final && !$viewcomplete($curview) &&
3121 $row + $uparrowlen + $mingaplen + $downarrowlen
3122 >= $commitidx($curview)} {
3125 set l
[llength
$rowidlist]
3127 lappend rowidlist
$idlist
3129 lappend rowfinal
$final
3130 } elseif
{$row < $l} {
3131 if {![rowsequal
$idlist [lindex
$rowidlist $row]]} {
3132 lset rowidlist
$row $idlist
3135 lset rowfinal
$row $final
3137 set pad
[ntimes
[expr {$row - $l}] {}]
3138 set rowidlist
[concat
$rowidlist $pad]
3139 lappend rowidlist
$idlist
3140 set rowfinal
[concat
$rowfinal $pad]
3141 lappend rowfinal
$final
3142 set rowisopt
[concat
$rowisopt [ntimes
[expr {$row - $l + 1}] 0]]
3148 proc changedrow
{row
} {
3149 global displayorder iddrawn rowisopt need_redisplay
3151 set l
[llength
$rowisopt]
3153 lset rowisopt
$row 0
3154 if {$row + 1 < $l} {
3155 lset rowisopt
[expr {$row + 1}] 0
3156 if {$row + 2 < $l} {
3157 lset rowisopt
[expr {$row + 2}] 0
3161 set id
[lindex
$displayorder $row]
3162 if {[info exists iddrawn
($id)]} {
3163 set need_redisplay
1
3167 proc insert_pad
{row
col npad
} {
3170 set pad
[ntimes
$npad {}]
3171 set idlist
[lindex
$rowidlist $row]
3172 set bef
[lrange
$idlist 0 [expr {$col - 1}]]
3173 set aft
[lrange
$idlist $col end
]
3174 set i
[lsearch
-exact $aft {}]
3176 set aft
[lreplace
$aft $i $i]
3178 lset rowidlist
$row [concat
$bef $pad $aft]
3182 proc optimize_rows
{row
col endrow
} {
3183 global rowidlist rowisopt displayorder curview children
3188 for {} {$row < $endrow} {incr row
; set col 0} {
3189 if {[lindex
$rowisopt $row]} continue
3191 set y0
[expr {$row - 1}]
3192 set ym
[expr {$row - 2}]
3193 set idlist
[lindex
$rowidlist $row]
3194 set previdlist
[lindex
$rowidlist $y0]
3195 if {$idlist eq
{} ||
$previdlist eq
{}} continue
3197 set pprevidlist
[lindex
$rowidlist $ym]
3198 if {$pprevidlist eq
{}} continue
3204 for {} {$col < [llength
$idlist]} {incr
col} {
3205 set id
[lindex
$idlist $col]
3206 if {[lindex
$previdlist $col] eq
$id} continue
3211 set x0
[lsearch
-exact $previdlist $id]
3212 if {$x0 < 0} continue
3213 set z
[expr {$x0 - $col}]
3217 set xm
[lsearch
-exact $pprevidlist $id]
3219 set z0
[expr {$xm - $x0}]
3223 # if row y0 is the first child of $id then it's not an arrow
3224 if {[lindex
$children($curview,$id) 0] ne
3225 [lindex
$displayorder $y0]} {
3229 if {!$isarrow && $id ne
[lindex
$displayorder $row] &&
3230 [lsearch
-exact [lindex
$rowidlist [expr {$row+1}]] $id] < 0} {
3233 # Looking at lines from this row to the previous row,
3234 # make them go straight up if they end in an arrow on
3235 # the previous row; otherwise make them go straight up
3237 if {$z < -1 ||
($z < 0 && $isarrow)} {
3238 # Line currently goes left too much;
3239 # insert pads in the previous row, then optimize it
3240 set npad
[expr {-1 - $z + $isarrow}]
3241 insert_pad
$y0 $x0 $npad
3243 optimize_rows
$y0 $x0 $row
3245 set previdlist
[lindex
$rowidlist $y0]
3246 set x0
[lsearch
-exact $previdlist $id]
3247 set z
[expr {$x0 - $col}]
3249 set pprevidlist
[lindex
$rowidlist $ym]
3250 set xm
[lsearch
-exact $pprevidlist $id]
3251 set z0
[expr {$xm - $x0}]
3253 } elseif
{$z > 1 ||
($z > 0 && $isarrow)} {
3254 # Line currently goes right too much;
3255 # insert pads in this line
3256 set npad
[expr {$z - 1 + $isarrow}]
3257 insert_pad
$row $col $npad
3258 set idlist
[lindex
$rowidlist $row]
3260 set z
[expr {$x0 - $col}]
3263 if {$z0 eq
{} && !$isarrow && $ym >= 0} {
3264 # this line links to its first child on row $row-2
3265 set id
[lindex
$displayorder $ym]
3266 set xc
[lsearch
-exact $pprevidlist $id]
3268 set z0
[expr {$xc - $x0}]
3271 # avoid lines jigging left then immediately right
3272 if {$z0 ne
{} && $z < 0 && $z0 > 0} {
3273 insert_pad
$y0 $x0 1
3275 optimize_rows
$y0 $x0 $row
3276 set previdlist
[lindex
$rowidlist $y0]
3280 # Find the first column that doesn't have a line going right
3281 for {set col [llength
$idlist]} {[incr
col -1] >= 0} {} {
3282 set id
[lindex
$idlist $col]
3283 if {$id eq
{}} break
3284 set x0
[lsearch
-exact $previdlist $id]
3286 # check if this is the link to the first child
3287 set kid
[lindex
$displayorder $y0]
3288 if {[lindex
$children($curview,$id) 0] eq
$kid} {
3289 # it is, work out offset to child
3290 set x0
[lsearch
-exact $previdlist $kid]
3293 if {$x0 <= $col} break
3295 # Insert a pad at that column as long as it has a line and
3296 # isn't the last column
3297 if {$x0 >= 0 && [incr
col] < [llength
$idlist]} {
3298 set idlist
[linsert
$idlist $col {}]
3299 lset rowidlist
$row $idlist
3307 global canvx0 linespc
3308 return [expr {$canvx0 + $col * $linespc}]
3312 global canvy0 linespc
3313 return [expr {$canvy0 + $row * $linespc}]
3316 proc linewidth
{id
} {
3317 global thickerline lthickness
3320 if {[info exists thickerline
] && $id eq
$thickerline} {
3321 set wid
[expr {2 * $lthickness}]
3326 proc rowranges
{id
} {
3327 global commitrow curview children uparrowlen downarrowlen
3330 set kids
$children($curview,$id)
3336 foreach child
$kids {
3337 if {![info exists commitrow
($curview,$child)]} break
3338 set row
$commitrow($curview,$child)
3339 if {![info exists prev
]} {
3340 lappend ret
[expr {$row + 1}]
3342 if {$row <= $prevrow} {
3343 puts
"oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3345 # see if the line extends the whole way from prevrow to row
3346 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3347 [lsearch
-exact [lindex
$rowidlist \
3348 [expr {int
(($row + $prevrow) / 2)}]] $id] < 0} {
3349 # it doesn't, see where it ends
3350 set r
[expr {$prevrow + $downarrowlen}]
3351 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3352 while {[incr r
-1] > $prevrow &&
3353 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3355 while {[incr r
] <= $row &&
3356 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3360 # see where it starts up again
3361 set r
[expr {$row - $uparrowlen}]
3362 if {[lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {
3363 while {[incr r
] < $row &&
3364 [lsearch
-exact [lindex
$rowidlist $r] $id] < 0} {}
3366 while {[incr r
-1] >= $prevrow &&
3367 [lsearch
-exact [lindex
$rowidlist $r] $id] >= 0} {}
3373 if {$child eq
$id} {
3382 proc drawlineseg
{id row endrow arrowlow
} {
3383 global rowidlist displayorder iddrawn linesegs
3384 global canv colormap linespc curview maxlinelen parentlist
3386 set cols
[list
[lsearch
-exact [lindex
$rowidlist $row] $id]]
3387 set le
[expr {$row + 1}]
3390 set c
[lsearch
-exact [lindex
$rowidlist $le] $id]
3396 set x
[lindex
$displayorder $le]
3401 if {[info exists iddrawn
($x)] ||
$le == $endrow} {
3402 set c
[lsearch
-exact [lindex
$rowidlist [expr {$le+1}]] $id]
3418 if {[info exists linesegs
($id)]} {
3419 set lines
$linesegs($id)
3421 set r0
[lindex
$li 0]
3423 if {$r0 == $le && [lindex
$li 1] - $row <= $maxlinelen} {
3433 set li
[lindex
$lines [expr {$i-1}]]
3434 set r1
[lindex
$li 1]
3435 if {$r1 == $row && $le - [lindex
$li 0] <= $maxlinelen} {
3440 set x
[lindex
$cols [expr {$le - $row}]]
3441 set xp
[lindex
$cols [expr {$le - 1 - $row}]]
3442 set dir
[expr {$xp - $x}]
3444 set ith
[lindex
$lines $i 2]
3445 set coords
[$canv coords
$ith]
3446 set ah
[$canv itemcget
$ith -arrow]
3447 set arrowhigh
[expr {$ah eq
"first" ||
$ah eq
"both"}]
3448 set x2
[lindex
$cols [expr {$le + 1 - $row}]]
3449 if {$x2 ne
{} && $x - $x2 == $dir} {
3450 set coords
[lrange
$coords 0 end-2
]
3453 set coords
[list
[xc
$le $x] [yc
$le]]
3456 set itl
[lindex
$lines [expr {$i-1}] 2]
3457 set al
[$canv itemcget
$itl -arrow]
3458 set arrowlow
[expr {$al eq
"last" ||
$al eq
"both"}]
3459 } elseif
{$arrowlow} {
3460 if {[lsearch
-exact [lindex
$rowidlist [expr {$row-1}]] $id] >= 0 ||
3461 [lsearch
-exact [lindex
$parentlist [expr {$row-1}]] $id] >= 0} {
3465 set arrow
[lindex
{none first last both
} [expr {$arrowhigh + 2*$arrowlow}]]
3466 for {set y
$le} {[incr y
-1] > $row} {} {
3468 set xp
[lindex
$cols [expr {$y - 1 - $row}]]
3469 set ndir
[expr {$xp - $x}]
3470 if {$dir != $ndir ||
$xp < 0} {
3471 lappend coords
[xc
$y $x] [yc
$y]
3477 # join parent line to first child
3478 set ch
[lindex
$displayorder $row]
3479 set xc
[lsearch
-exact [lindex
$rowidlist $row] $ch]
3481 puts
"oops: drawlineseg: child $ch not on row $row"
3482 } elseif
{$xc != $x} {
3483 if {($arrowhigh && $le == $row + 1) ||
$dir == 0} {
3484 set d
[expr {int
(0.5 * $linespc)}]
3487 set x2
[expr {$x1 - $d}]
3489 set x2
[expr {$x1 + $d}]
3492 set y1
[expr {$y2 + $d}]
3493 lappend coords
$x1 $y1 $x2 $y2
3494 } elseif
{$xc < $x - 1} {
3495 lappend coords
[xc
$row [expr {$x-1}]] [yc
$row]
3496 } elseif
{$xc > $x + 1} {
3497 lappend coords
[xc
$row [expr {$x+1}]] [yc
$row]
3501 lappend coords
[xc
$row $x] [yc
$row]
3503 set xn
[xc
$row $xp]
3505 lappend coords
$xn $yn
3509 set t
[$canv create line
$coords -width [linewidth
$id] \
3510 -fill $colormap($id) -tags lines.
$id -arrow $arrow]
3513 set lines
[linsert
$lines $i [list
$row $le $t]]
3515 $canv coords
$ith $coords
3516 if {$arrow ne
$ah} {
3517 $canv itemconf
$ith -arrow $arrow
3519 lset lines
$i 0 $row
3522 set xo
[lsearch
-exact [lindex
$rowidlist [expr {$row - 1}]] $id]
3523 set ndir
[expr {$xo - $xp}]
3524 set clow
[$canv coords
$itl]
3525 if {$dir == $ndir} {
3526 set clow
[lrange
$clow 2 end
]
3528 set coords
[concat
$coords $clow]
3530 lset lines
[expr {$i-1}] 1 $le
3532 # coalesce two pieces
3534 set b
[lindex
$lines [expr {$i-1}] 0]
3535 set e
[lindex
$lines $i 1]
3536 set lines
[lreplace
$lines [expr {$i-1}] $i [list
$b $e $itl]]
3538 $canv coords
$itl $coords
3539 if {$arrow ne
$al} {
3540 $canv itemconf
$itl -arrow $arrow
3544 set linesegs
($id) $lines
3548 proc drawparentlinks
{id row
} {
3549 global rowidlist canv colormap curview parentlist
3550 global idpos linespc
3552 set rowids
[lindex
$rowidlist $row]
3553 set col [lsearch
-exact $rowids $id]
3554 if {$col < 0} return
3555 set olds
[lindex
$parentlist $row]
3556 set row2
[expr {$row + 1}]
3557 set x
[xc
$row $col]
3560 set d
[expr {int
(0.5 * $linespc)}]
3561 set ymid
[expr {$y + $d}]
3562 set ids
[lindex
$rowidlist $row2]
3563 # rmx = right-most X coord used
3566 set i
[lsearch
-exact $ids $p]
3568 puts
"oops, parent $p of $id not in list"
3571 set x2
[xc
$row2 $i]
3575 set j
[lsearch
-exact $rowids $p]
3577 # drawlineseg will do this one for us
3581 # should handle duplicated parents here...
3582 set coords
[list
$x $y]
3584 # if attaching to a vertical segment, draw a smaller
3585 # slant for visual distinctness
3588 lappend coords
[expr {$x2 + $d}] $y $x2 $ymid
3590 lappend coords
[expr {$x2 - $d}] $y $x2 $ymid
3592 } elseif
{$i < $col && $i < $j} {
3593 # segment slants towards us already
3594 lappend coords
[xc
$row $j] $y
3596 if {$i < $col - 1} {
3597 lappend coords
[expr {$x2 + $linespc}] $y
3598 } elseif
{$i > $col + 1} {
3599 lappend coords
[expr {$x2 - $linespc}] $y
3601 lappend coords
$x2 $y2
3604 lappend coords
$x2 $y2
3606 set t
[$canv create line
$coords -width [linewidth
$p] \
3607 -fill $colormap($p) -tags lines.
$p]
3611 if {$rmx > [lindex
$idpos($id) 1]} {
3612 lset idpos
($id) 1 $rmx
3617 proc drawlines
{id
} {
3620 $canv itemconf lines.
$id -width [linewidth
$id]
3623 proc drawcmittext
{id row
col} {
3624 global linespc canv canv2 canv3 canvy0 fgcolor curview
3625 global commitlisted commitinfo rowidlist parentlist
3626 global rowtextx idpos idtags idheads idotherrefs
3627 global linehtag linentag linedtag selectedline
3628 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3630 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3631 set listed
[lindex
$commitlisted $row]
3632 if {$id eq
$nullid} {
3634 } elseif
{$id eq
$nullid2} {
3637 set ofill
[expr {$listed != 0?
"blue": "white"}]
3639 set x
[xc
$row $col]
3641 set orad
[expr {$linespc / 3}]
3643 set t
[$canv create oval
[expr {$x - $orad}] [expr {$y - $orad}] \
3644 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3645 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3646 } elseif
{$listed == 2} {
3647 # triangle pointing left for left-side commits
3648 set t
[$canv create polygon \
3649 [expr {$x - $orad}] $y \
3650 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3651 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3652 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3654 # triangle pointing right for right-side commits
3655 set t
[$canv create polygon \
3656 [expr {$x + $orad - 1}] $y \
3657 [expr {$x - $orad}] [expr {$y - $orad}] \
3658 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3659 -fill $ofill -outline $fgcolor -width 1 -tags circle
]
3662 $canv bind $t <1> {selcanvline
{} %x
%y
}
3663 set rmx
[llength
[lindex
$rowidlist $row]]
3664 set olds
[lindex
$parentlist $row]
3666 set nextids
[lindex
$rowidlist [expr {$row + 1}]]
3668 set i
[lsearch
-exact $nextids $p]
3674 set xt
[xc
$row $rmx]
3675 set rowtextx
($row) $xt
3676 set idpos
($id) [list
$x $xt $y]
3677 if {[info exists idtags
($id)] ||
[info exists idheads
($id)]
3678 ||
[info exists idotherrefs
($id)]} {
3679 set xt
[drawtags
$id $x $xt $y]
3681 set headline
[lindex
$commitinfo($id) 0]
3682 set name
[lindex
$commitinfo($id) 1]
3683 set date [lindex
$commitinfo($id) 2]
3684 set date [formatdate
$date]
3687 set isbold
[ishighlighted
$row]
3689 lappend boldrows
$row
3690 set font mainfontbold
3692 lappend boldnamerows
$row
3693 set nfont mainfontbold
3696 set linehtag
($row) [$canv create text
$xt $y -anchor w
-fill $fgcolor \
3697 -text $headline -font $font -tags text
]
3698 $canv bind $linehtag($row) <Button-3
> "rowmenu %X %Y $id"
3699 set linentag
($row) [$canv2 create text
3 $y -anchor w
-fill $fgcolor \
3700 -text $name -font $nfont -tags text
]
3701 set linedtag
($row) [$canv3 create text
3 $y -anchor w
-fill $fgcolor \
3702 -text $date -font mainfont
-tags text
]
3703 if {[info exists selectedline
] && $selectedline == $row} {
3706 set xr
[expr {$xt + [font measure
$font $headline]}]
3707 if {$xr > $canvxmax} {
3713 proc drawcmitrow
{row
} {
3714 global displayorder rowidlist nrows_drawn
3715 global iddrawn markingmatches
3716 global commitinfo parentlist numcommits
3717 global filehighlight fhighlights findpattern nhighlights
3718 global hlview vhighlights
3719 global highlight_related rhighlights
3721 if {$row >= $numcommits} return
3723 set id
[lindex
$displayorder $row]
3724 if {[info exists hlview
] && ![info exists vhighlights
($row)]} {
3725 askvhighlight
$row $id
3727 if {[info exists filehighlight
] && ![info exists fhighlights
($row)]} {
3728 askfilehighlight
$row $id
3730 if {$findpattern ne
{} && ![info exists nhighlights
($row)]} {
3731 askfindhighlight
$row $id
3733 if {$highlight_related ne
[mc
"None"] && ![info exists rhighlights
($row)]} {
3734 askrelhighlight
$row $id
3736 if {![info exists iddrawn
($id)]} {
3737 set col [lsearch
-exact [lindex
$rowidlist $row] $id]
3739 puts
"oops, row $row id $id not in list"
3742 if {![info exists commitinfo
($id)]} {
3746 drawcmittext
$id $row $col
3750 if {$markingmatches} {
3751 markrowmatches
$row $id
3755 proc drawcommits
{row
{endrow
{}}} {
3756 global numcommits iddrawn displayorder curview need_redisplay
3757 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3762 if {$endrow eq
{}} {
3765 if {$endrow >= $numcommits} {
3766 set endrow
[expr {$numcommits - 1}]
3769 set rl1
[expr {$row - $downarrowlen - 3}]
3773 set ro1
[expr {$row - 3}]
3777 set r2
[expr {$endrow + $uparrowlen + 3}]
3778 if {$r2 > $numcommits} {
3781 for {set r
$rl1} {$r < $r2} {incr r
} {
3782 if {[lindex
$rowidlist $r] ne
{} && [lindex
$rowfinal $r]} {
3786 set rl1
[expr {$r + 1}]
3792 optimize_rows
$ro1 0 $r2
3793 if {$need_redisplay ||
$nrows_drawn > 2000} {
3798 # make the lines join to already-drawn rows either side
3799 set r
[expr {$row - 1}]
3800 if {$r < 0 ||
![info exists iddrawn
([lindex
$displayorder $r])]} {
3803 set er
[expr {$endrow + 1}]
3804 if {$er >= $numcommits ||
3805 ![info exists iddrawn
([lindex
$displayorder $er])]} {
3808 for {} {$r <= $er} {incr r
} {
3809 set id
[lindex
$displayorder $r]
3810 set wasdrawn
[info exists iddrawn
($id)]
3812 if {$r == $er} break
3813 set nextid
[lindex
$displayorder [expr {$r + 1}]]
3814 if {$wasdrawn && [info exists iddrawn
($nextid)]} continue
3815 drawparentlinks
$id $r
3817 set rowids
[lindex
$rowidlist $r]
3818 foreach lid
$rowids {
3819 if {$lid eq
{}} continue
3820 if {[info exists lineend
($lid)] && $lineend($lid) > $r} continue
3822 # see if this is the first child of any of its parents
3823 foreach p
[lindex
$parentlist $r] {
3824 if {[lsearch
-exact $rowids $p] < 0} {
3825 # make this line extend up to the child
3826 set lineend
($p) [drawlineseg
$p $r $er 0]
3830 set lineend
($lid) [drawlineseg
$lid $r $er 1]
3836 proc drawfrac
{f0 f1
} {
3839 set ymax
[lindex
[$canv cget
-scrollregion] 3]
3840 if {$ymax eq
{} ||
$ymax == 0} return
3841 set y0
[expr {int
($f0 * $ymax)}]
3842 set row
[expr {int
(($y0 - 3) / $linespc) - 1}]
3843 set y1
[expr {int
($f1 * $ymax)}]
3844 set endrow
[expr {int
(($y1 - 3) / $linespc) + 1}]
3845 drawcommits
$row $endrow
3848 proc drawvisible
{} {
3850 eval drawfrac
[$canv yview
]
3853 proc clear_display
{} {
3854 global iddrawn linesegs need_redisplay nrows_drawn
3855 global vhighlights fhighlights nhighlights rhighlights
3858 catch
{unset iddrawn
}
3859 catch
{unset linesegs
}
3860 catch
{unset vhighlights
}
3861 catch
{unset fhighlights
}
3862 catch
{unset nhighlights
}
3863 catch
{unset rhighlights
}
3864 set need_redisplay
0
3868 proc findcrossings
{id
} {
3869 global rowidlist parentlist numcommits displayorder
3873 foreach
{s e
} [rowranges
$id] {
3874 if {$e >= $numcommits} {
3875 set e
[expr {$numcommits - 1}]
3877 if {$e <= $s} continue
3878 for {set row
$e} {[incr row
-1] >= $s} {} {
3879 set x
[lsearch
-exact [lindex
$rowidlist $row] $id]
3881 set olds
[lindex
$parentlist $row]
3882 set kid
[lindex
$displayorder $row]
3883 set kidx
[lsearch
-exact [lindex
$rowidlist $row] $kid]
3884 if {$kidx < 0} continue
3885 set nextrow
[lindex
$rowidlist [expr {$row + 1}]]
3887 set px
[lsearch
-exact $nextrow $p]
3888 if {$px < 0} continue
3889 if {($kidx < $x && $x < $px) ||
($px < $x && $x < $kidx)} {
3890 if {[lsearch
-exact $ccross $p] >= 0} continue
3891 if {$x == $px + ($kidx < $px?
-1: 1)} {
3893 } elseif
{[lsearch
-exact $cross $p] < 0} {
3900 return [concat
$ccross {{}} $cross]
3903 proc assigncolor
{id
} {
3904 global colormap colors nextcolor
3905 global commitrow parentlist children children curview
3907 if {[info exists colormap
($id)]} return
3908 set ncolors
[llength
$colors]
3909 if {[info exists children
($curview,$id)]} {
3910 set kids
$children($curview,$id)
3914 if {[llength
$kids] == 1} {
3915 set child
[lindex
$kids 0]
3916 if {[info exists colormap
($child)]
3917 && [llength
[lindex
$parentlist $commitrow($curview,$child)]] == 1} {
3918 set colormap
($id) $colormap($child)
3924 foreach x
[findcrossings
$id] {
3926 # delimiter between corner crossings and other crossings
3927 if {[llength
$badcolors] >= $ncolors - 1} break
3928 set origbad
$badcolors
3930 if {[info exists colormap
($x)]
3931 && [lsearch
-exact $badcolors $colormap($x)] < 0} {
3932 lappend badcolors
$colormap($x)
3935 if {[llength
$badcolors] >= $ncolors} {
3936 set badcolors
$origbad
3938 set origbad
$badcolors
3939 if {[llength
$badcolors] < $ncolors - 1} {
3940 foreach child
$kids {
3941 if {[info exists colormap
($child)]
3942 && [lsearch
-exact $badcolors $colormap($child)] < 0} {
3943 lappend badcolors
$colormap($child)
3945 foreach p
[lindex
$parentlist $commitrow($curview,$child)] {
3946 if {[info exists colormap
($p)]
3947 && [lsearch
-exact $badcolors $colormap($p)] < 0} {
3948 lappend badcolors
$colormap($p)
3952 if {[llength
$badcolors] >= $ncolors} {
3953 set badcolors
$origbad
3956 for {set i
0} {$i <= $ncolors} {incr i
} {
3957 set c
[lindex
$colors $nextcolor]
3958 if {[incr nextcolor
] >= $ncolors} {
3961 if {[lsearch
-exact $badcolors $c]} break
3963 set colormap
($id) $c
3966 proc bindline
{t id
} {
3969 $canv bind $t <Enter
> "lineenter %x %y $id"
3970 $canv bind $t <Motion
> "linemotion %x %y $id"
3971 $canv bind $t <Leave
> "lineleave $id"
3972 $canv bind $t <Button-1
> "lineclick %x %y $id 1"
3975 proc drawtags
{id x xt y1
} {
3976 global idtags idheads idotherrefs mainhead
3977 global linespc lthickness
3978 global canv commitrow rowtextx curview fgcolor bgcolor
3983 if {[info exists idtags
($id)]} {
3984 set marks
$idtags($id)
3985 set ntags
[llength
$marks]
3987 if {[info exists idheads
($id)]} {
3988 set marks
[concat
$marks $idheads($id)]
3989 set nheads
[llength
$idheads($id)]
3991 if {[info exists idotherrefs
($id)]} {
3992 set marks
[concat
$marks $idotherrefs($id)]
3998 set delta
[expr {int
(0.5 * ($linespc - $lthickness))}]
3999 set yt
[expr {$y1 - 0.5 * $linespc}]
4000 set yb
[expr {$yt + $linespc - 1}]
4004 foreach tag
$marks {
4006 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq
$mainhead} {
4007 set wid
[font measure mainfontbold
$tag]
4009 set wid
[font measure mainfont
$tag]
4013 set xt
[expr {$xt + $delta + $wid + $lthickness + $linespc}]
4015 set t
[$canv create line
$x $y1 [lindex
$xvals end
] $y1 \
4016 -width $lthickness -fill black
-tags tag.
$id]
4018 foreach tag
$marks x
$xvals wid
$wvals {
4019 set xl
[expr {$x + $delta}]
4020 set xr
[expr {$x + $delta + $wid + $lthickness}]
4022 if {[incr ntags
-1] >= 0} {
4024 set t
[$canv create polygon
$x [expr {$yt + $delta}] $xl $yt \
4025 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4026 -width 1 -outline black
-fill yellow
-tags tag.
$id]
4027 $canv bind $t <1> [list showtag
$tag 1]
4028 set rowtextx
($commitrow($curview,$id)) [expr {$xr + $linespc}]
4030 # draw a head or other ref
4031 if {[incr nheads
-1] >= 0} {
4033 if {$tag eq
$mainhead} {
4034 set font mainfontbold
4039 set xl
[expr {$xl - $delta/2}]
4040 $canv create polygon
$x $yt $xr $yt $xr $yb $x $yb \
4041 -width 1 -outline black
-fill $col -tags tag.
$id
4042 if {[regexp
{^
(remotes
/.
*/|remotes
/)} $tag match remoteprefix
]} {
4043 set rwid
[font measure mainfont
$remoteprefix]
4044 set xi
[expr {$x + 1}]
4045 set yti
[expr {$yt + 1}]
4046 set xri
[expr {$x + $rwid}]
4047 $canv create polygon
$xi $yti $xri $yti $xri $yb $xi $yb \
4048 -width 0 -fill "#ffddaa" -tags tag.
$id
4051 set t
[$canv create text
$xl $y1 -anchor w
-text $tag -fill $fgcolor \
4052 -font $font -tags [list tag.
$id text
]]
4054 $canv bind $t <1> [list showtag
$tag 1]
4055 } elseif
{$nheads >= 0} {
4056 $canv bind $t <Button-3
> [list headmenu
%X
%Y
$id $tag]
4062 proc xcoord
{i level
ln} {
4063 global canvx0 xspc1 xspc2
4065 set x
[expr {$canvx0 + $i * $xspc1($ln)}]
4066 if {$i > 0 && $i == $level} {
4067 set x
[expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4068 } elseif
{$i > $level} {
4069 set x
[expr {$x + $xspc2 - $xspc1($ln)}]
4074 proc show_status
{msg
} {
4078 $canv create text
3 3 -anchor nw
-text $msg -font mainfont \
4079 -tags text
-fill $fgcolor
4082 # Insert a new commit as the child of the commit on row $row.
4083 # The new commit will be displayed on row $row and the commits
4084 # on that row and below will move down one row.
4085 proc insertrow
{row newcmit
} {
4086 global displayorder parentlist commitlisted children
4087 global commitrow curview rowidlist rowisopt rowfinal numcommits
4089 global selectedline commitidx ordertok
4091 if {$row >= $numcommits} {
4092 puts
"oops, inserting new row $row but only have $numcommits rows"
4095 set p
[lindex
$displayorder $row]
4096 set displayorder
[linsert
$displayorder $row $newcmit]
4097 set parentlist
[linsert
$parentlist $row $p]
4098 set kids
$children($curview,$p)
4099 lappend kids
$newcmit
4100 set children
($curview,$p) $kids
4101 set children
($curview,$newcmit) {}
4102 set commitlisted
[linsert
$commitlisted $row 1]
4103 set l
[llength
$displayorder]
4104 for {set r
$row} {$r < $l} {incr r
} {
4105 set id
[lindex
$displayorder $r]
4106 set commitrow
($curview,$id) $r
4108 incr commitidx
($curview)
4109 set ordertok
($curview,$newcmit) $ordertok($curview,$p)
4111 if {$row < [llength
$rowidlist]} {
4112 set idlist
[lindex
$rowidlist $row]
4113 if {$idlist ne
{}} {
4114 if {[llength
$kids] == 1} {
4115 set col [lsearch
-exact $idlist $p]
4116 lset idlist
$col $newcmit
4118 set col [llength
$idlist]
4119 lappend idlist
$newcmit
4122 set rowidlist
[linsert
$rowidlist $row $idlist]
4123 set rowisopt
[linsert
$rowisopt $row 0]
4124 set rowfinal
[linsert
$rowfinal $row [lindex
$rowfinal $row]]
4129 if {[info exists selectedline
] && $selectedline >= $row} {
4135 # Remove a commit that was inserted with insertrow on row $row.
4136 proc removerow
{row
} {
4137 global displayorder parentlist commitlisted children
4138 global commitrow curview rowidlist rowisopt rowfinal numcommits
4140 global linesegends selectedline commitidx
4142 if {$row >= $numcommits} {
4143 puts
"oops, removing row $row but only have $numcommits rows"
4146 set rp1
[expr {$row + 1}]
4147 set id
[lindex
$displayorder $row]
4148 set p
[lindex
$parentlist $row]
4149 set displayorder
[lreplace
$displayorder $row $row]
4150 set parentlist
[lreplace
$parentlist $row $row]
4151 set commitlisted
[lreplace
$commitlisted $row $row]
4152 set kids
$children($curview,$p)
4153 set i
[lsearch
-exact $kids $id]
4155 set kids
[lreplace
$kids $i $i]
4156 set children
($curview,$p) $kids
4158 set l
[llength
$displayorder]
4159 for {set r
$row} {$r < $l} {incr r
} {
4160 set id
[lindex
$displayorder $r]
4161 set commitrow
($curview,$id) $r
4163 incr commitidx
($curview) -1
4165 if {$row < [llength
$rowidlist]} {
4166 set rowidlist
[lreplace
$rowidlist $row $row]
4167 set rowisopt
[lreplace
$rowisopt $row $row]
4168 set rowfinal
[lreplace
$rowfinal $row $row]
4173 if {[info exists selectedline
] && $selectedline > $row} {
4174 incr selectedline
-1
4179 # Don't change the text pane cursor if it is currently the hand cursor,
4180 # showing that we are over a sha1 ID link.
4181 proc settextcursor
{c
} {
4182 global ctext curtextcursor
4184 if {[$ctext cget
-cursor] == $curtextcursor} {
4185 $ctext config
-cursor $c
4187 set curtextcursor
$c
4190 proc nowbusy
{what
{name
{}}} {
4191 global isbusy busyname statusw
4193 if {[array names isbusy
] eq
{}} {
4194 . config
-cursor watch
4198 set busyname
($what) $name
4200 $statusw conf
-text $name
4204 proc notbusy
{what
} {
4205 global isbusy maincursor textcursor busyname statusw
4209 if {$busyname($what) ne
{} &&
4210 [$statusw cget
-text] eq
$busyname($what)} {
4211 $statusw conf
-text {}
4214 if {[array names isbusy
] eq
{}} {
4215 . config
-cursor $maincursor
4216 settextcursor
$textcursor
4220 proc findmatches
{f
} {
4221 global findtype findstring
4222 if {$findtype == [mc
"Regexp"]} {
4223 set matches
[regexp
-indices -all -inline $findstring $f]
4226 if {$findtype == [mc
"IgnCase"]} {
4227 set f
[string tolower
$f]
4228 set fs
[string tolower
$fs]
4232 set l
[string length
$fs]
4233 while {[set j
[string first
$fs $f $i]] >= 0} {
4234 lappend matches
[list
$j [expr {$j+$l-1}]]
4235 set i
[expr {$j + $l}]
4241 proc dofind
{{dirn
1} {wrap
1}} {
4242 global findstring findstartline findcurline selectedline numcommits
4243 global gdttype filehighlight fh_serial find_dirn findallowwrap
4245 if {[info exists find_dirn
]} {
4246 if {$find_dirn == $dirn} return
4250 if {$findstring eq
{} ||
$numcommits == 0} return
4251 if {![info exists selectedline
]} {
4252 set findstartline
[lindex
[visiblerows
] [expr {$dirn < 0}]]
4254 set findstartline
$selectedline
4256 set findcurline
$findstartline
4257 nowbusy finding
[mc
"Searching"]
4258 if {$gdttype ne
[mc
"containing:"] && ![info exists filehighlight
]} {
4259 after cancel do_file_hl
$fh_serial
4260 do_file_hl
$fh_serial
4263 set findallowwrap
$wrap
4267 proc stopfinding
{} {
4268 global find_dirn findcurline fprogcoord
4270 if {[info exists find_dirn
]} {
4280 global commitdata commitinfo numcommits findpattern findloc
4281 global findstartline findcurline displayorder
4282 global find_dirn gdttype fhighlights fprogcoord
4283 global findallowwrap
4285 if {![info exists find_dirn
]} {
4288 set fldtypes
[list
[mc
"Headline"] [mc
"Author"] [mc
"Date"] [mc
"Committer"] [mc
"CDate"] [mc
"Comments"]]
4291 if {$find_dirn > 0} {
4293 if {$l >= $numcommits} {
4296 if {$l <= $findstartline} {
4297 set lim
[expr {$findstartline + 1}]
4300 set moretodo
$findallowwrap
4307 if {$l >= $findstartline} {
4308 set lim
[expr {$findstartline - 1}]
4311 set moretodo
$findallowwrap
4314 set n
[expr {($lim - $l) * $find_dirn}]
4321 if {$gdttype eq
[mc
"containing:"]} {
4322 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4323 set id
[lindex
$displayorder $l]
4324 # shouldn't happen unless git log doesn't give all the commits...
4325 if {![info exists commitdata
($id)]} continue
4326 if {![doesmatch
$commitdata($id)]} continue
4327 if {![info exists commitinfo
($id)]} {
4330 set info
$commitinfo($id)
4331 foreach f
$info ty
$fldtypes {
4332 if {($findloc eq
[mc
"All fields"] ||
$findloc eq
$ty) &&
4341 for {} {$n > 0} {incr n
-1; incr l
$find_dirn} {
4342 set id
[lindex
$displayorder $l]
4343 if {![info exists fhighlights
($l)]} {
4344 askfilehighlight
$l $id
4347 set findcurline
[expr {$l - $find_dirn}]
4349 } elseif
{$fhighlights($l)} {
4355 if {$found ||
($domore && !$moretodo)} {
4371 set findcurline
[expr {$l - $find_dirn}]
4373 set n
[expr {($findcurline - $findstartline) * $find_dirn - 1}]
4377 set fprogcoord
[expr {$n * 1.0 / $numcommits}]
4382 proc findselectline
{l
} {
4383 global findloc commentend ctext findcurline markingmatches gdttype
4385 set markingmatches
1
4388 if {$findloc == [mc
"All fields"] ||
$findloc == [mc
"Comments"]} {
4389 # highlight the matches in the comments
4390 set f
[$ctext get
1.0 $commentend]
4391 set matches
[findmatches
$f]
4392 foreach match
$matches {
4393 set start
[lindex
$match 0]
4394 set end
[expr {[lindex
$match 1] + 1}]
4395 $ctext tag add found
"1.0 + $start c" "1.0 + $end c"
4401 # mark the bits of a headline or author that match a find string
4402 proc markmatches
{canv l str tag matches font row
} {
4405 set bbox
[$canv bbox
$tag]
4406 set x0
[lindex
$bbox 0]
4407 set y0
[lindex
$bbox 1]
4408 set y1
[lindex
$bbox 3]
4409 foreach match
$matches {
4410 set start
[lindex
$match 0]
4411 set end
[lindex
$match 1]
4412 if {$start > $end} continue
4413 set xoff
[font measure
$font [string range
$str 0 [expr {$start-1}]]]
4414 set xlen
[font measure
$font [string range
$str 0 [expr {$end}]]]
4415 set t
[$canv create rect
[expr {$x0+$xoff}] $y0 \
4416 [expr {$x0+$xlen+2}] $y1 \
4417 -outline {} -tags [list match
$l matches
] -fill yellow
]
4419 if {[info exists selectedline
] && $row == $selectedline} {
4420 $canv raise
$t secsel
4425 proc unmarkmatches
{} {
4426 global markingmatches
4428 allcanvs delete matches
4429 set markingmatches
0
4433 proc selcanvline
{w x y
} {
4434 global canv canvy0 ctext linespc
4436 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4437 if {$ymax == {}} return
4438 set yfrac
[lindex
[$canv yview
] 0]
4439 set y
[expr {$y + $yfrac * $ymax}]
4440 set l
[expr {int
(($y - $canvy0) / $linespc + 0.5)}]
4445 if {![info exists rowtextx
($l)] ||
$x < $rowtextx($l)} return
4451 proc commit_descriptor
{p
} {
4453 if {![info exists commitinfo
($p)]} {
4457 if {[llength
$commitinfo($p)] > 1} {
4458 set l
[lindex
$commitinfo($p) 0]
4463 # append some text to the ctext widget, and make any SHA1 ID
4464 # that we know about be a clickable link.
4465 proc appendwithlinks
{text tags
} {
4466 global ctext commitrow linknum curview pendinglinks
4468 set start
[$ctext index
"end - 1c"]
4469 $ctext insert end
$text $tags
4470 set links
[regexp
-indices -all -inline {[0-9a-f]{40}} $text]
4474 set linkid
[string range
$text $s $e]
4476 $ctext tag delete link
$linknum
4477 $ctext tag add link
$linknum "$start + $s c" "$start + $e c"
4478 setlink
$linkid link
$linknum
4483 proc setlink
{id lk
} {
4484 global curview commitrow ctext pendinglinks commitinterest
4486 if {[info exists commitrow
($curview,$id)]} {
4487 $ctext tag conf
$lk -foreground blue
-underline 1
4488 $ctext tag
bind $lk <1> [list selectline
$commitrow($curview,$id) 1]
4489 $ctext tag
bind $lk <Enter
> {linkcursor
%W
1}
4490 $ctext tag
bind $lk <Leave
> {linkcursor
%W
-1}
4492 lappend pendinglinks
($id) $lk
4493 lappend commitinterest
($id) {makelink
%I
}
4497 proc makelink
{id
} {
4500 if {![info exists pendinglinks
($id)]} return
4501 foreach lk
$pendinglinks($id) {
4504 unset pendinglinks
($id)
4507 proc linkcursor
{w inc
} {
4508 global linkentercount curtextcursor
4510 if {[incr linkentercount
$inc] > 0} {
4511 $w configure
-cursor hand2
4513 $w configure
-cursor $curtextcursor
4514 if {$linkentercount < 0} {
4515 set linkentercount
0
4520 proc viewnextline
{dir
} {
4524 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4525 set wnow
[$canv yview
]
4526 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4527 set newtop
[expr {$wtop + $dir * $linespc}]
4530 } elseif
{$newtop > $ymax} {
4533 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4536 # add a list of tag or branch names at position pos
4537 # returns the number of names inserted
4538 proc appendrefs
{pos ids var
} {
4539 global ctext commitrow linknum curview
$var maxrefs
4541 if {[catch
{$ctext index
$pos}]} {
4544 $ctext conf
-state normal
4545 $ctext delete
$pos "$pos lineend"
4548 foreach tag
[set $var\
($id\
)] {
4549 lappend tags
[list
$tag $id]
4552 if {[llength
$tags] > $maxrefs} {
4553 $ctext insert
$pos "many ([llength $tags])"
4555 set tags
[lsort
-index 0 -decreasing $tags]
4558 set id
[lindex
$ti 1]
4561 $ctext tag delete
$lk
4562 $ctext insert
$pos $sep
4563 $ctext insert
$pos [lindex
$ti 0] $lk
4568 $ctext conf
-state disabled
4569 return [llength
$tags]
4572 # called when we have finished computing the nearby tags
4573 proc dispneartags
{delay
} {
4574 global selectedline currentid showneartags tagphase
4576 if {![info exists selectedline
] ||
!$showneartags} return
4577 after cancel dispnexttag
4579 after
200 dispnexttag
4582 after idle dispnexttag
4587 proc dispnexttag
{} {
4588 global selectedline currentid showneartags tagphase ctext
4590 if {![info exists selectedline
] ||
!$showneartags} return
4591 switch
-- $tagphase {
4593 set dtags
[desctags
$currentid]
4595 appendrefs precedes
$dtags idtags
4599 set atags
[anctags
$currentid]
4601 appendrefs follows
$atags idtags
4605 set dheads
[descheads
$currentid]
4606 if {$dheads ne
{}} {
4607 if {[appendrefs branch
$dheads idheads
] > 1
4608 && [$ctext get
"branch -3c"] eq
"h"} {
4609 # turn "Branch" into "Branches"
4610 $ctext conf
-state normal
4611 $ctext insert
"branch -2c" "es"
4612 $ctext conf
-state disabled
4617 if {[incr tagphase
] <= 2} {
4618 after idle dispnexttag
4622 proc make_secsel
{l
} {
4623 global linehtag linentag linedtag canv canv2 canv3
4625 if {![info exists linehtag
($l)]} return
4627 set t
[eval $canv create rect
[$canv bbox
$linehtag($l)] -outline {{}} \
4628 -tags secsel
-fill [$canv cget
-selectbackground]]
4630 $canv2 delete secsel
4631 set t
[eval $canv2 create rect
[$canv2 bbox
$linentag($l)] -outline {{}} \
4632 -tags secsel
-fill [$canv2 cget
-selectbackground]]
4634 $canv3 delete secsel
4635 set t
[eval $canv3 create rect
[$canv3 bbox
$linedtag($l)] -outline {{}} \
4636 -tags secsel
-fill [$canv3 cget
-selectbackground]]
4640 proc selectline
{l isnew
} {
4641 global canv ctext commitinfo selectedline
4643 global canvy0 linespc parentlist children curview
4644 global currentid sha1entry
4645 global commentend idtags linknum
4646 global mergemax numcommits pending_select
4647 global cmitmode showneartags allcommits
4649 catch
{unset pending_select
}
4654 if {$l < 0 ||
$l >= $numcommits} return
4655 set y
[expr {$canvy0 + $l * $linespc}]
4656 set ymax
[lindex
[$canv cget
-scrollregion] 3]
4657 set ytop
[expr {$y - $linespc - 1}]
4658 set ybot
[expr {$y + $linespc + 1}]
4659 set wnow
[$canv yview
]
4660 set wtop
[expr {[lindex
$wnow 0] * $ymax}]
4661 set wbot
[expr {[lindex
$wnow 1] * $ymax}]
4662 set wh
[expr {$wbot - $wtop}]
4664 if {$ytop < $wtop} {
4665 if {$ybot < $wtop} {
4666 set newtop
[expr {$y - $wh / 2.0}]
4669 if {$newtop > $wtop - $linespc} {
4670 set newtop
[expr {$wtop - $linespc}]
4673 } elseif
{$ybot > $wbot} {
4674 if {$ytop > $wbot} {
4675 set newtop
[expr {$y - $wh / 2.0}]
4677 set newtop
[expr {$ybot - $wh}]
4678 if {$newtop < $wtop + $linespc} {
4679 set newtop
[expr {$wtop + $linespc}]
4683 if {$newtop != $wtop} {
4687 allcanvs yview moveto
[expr {$newtop * 1.0 / $ymax}]
4694 addtohistory
[list selectline
$l 0]
4699 set id
[lindex
$displayorder $l]
4701 $sha1entry delete
0 end
4702 $sha1entry insert
0 $id
4703 $sha1entry selection from
0
4704 $sha1entry selection to end
4707 $ctext conf
-state normal
4710 set info
$commitinfo($id)
4711 set date [formatdate
[lindex
$info 2]]
4712 $ctext insert end
"[mc "Author
"]: [lindex $info 1] $date\n"
4713 set date [formatdate
[lindex
$info 4]]
4714 $ctext insert end
"[mc "Committer
"]: [lindex $info 3] $date\n"
4715 if {[info exists idtags
($id)]} {
4716 $ctext insert end
[mc
"Tags:"]
4717 foreach tag
$idtags($id) {
4718 $ctext insert end
" $tag"
4720 $ctext insert end
"\n"
4724 set olds
[lindex
$parentlist $l]
4725 if {[llength
$olds] > 1} {
4728 if {$np >= $mergemax} {
4733 $ctext insert end
"[mc "Parent
"]: " $tag
4734 appendwithlinks
[commit_descriptor
$p] {}
4739 append headers
"[mc "Parent
"]: [commit_descriptor $p]"
4743 foreach c
$children($curview,$id) {
4744 append headers
"[mc "Child
"]: [commit_descriptor $c]"
4747 # make anything that looks like a SHA1 ID be a clickable link
4748 appendwithlinks
$headers {}
4749 if {$showneartags} {
4750 if {![info exists allcommits
]} {
4753 $ctext insert end
"[mc "Branch
"]: "
4754 $ctext mark
set branch
"end -1c"
4755 $ctext mark gravity branch left
4756 $ctext insert end
"\n[mc "Follows
"]: "
4757 $ctext mark
set follows
"end -1c"
4758 $ctext mark gravity follows left
4759 $ctext insert end
"\n[mc "Precedes
"]: "
4760 $ctext mark
set precedes
"end -1c"
4761 $ctext mark gravity precedes left
4762 $ctext insert end
"\n"
4765 $ctext insert end
"\n"
4766 set comment
[lindex
$info 5]
4767 if {[string first
"\r" $comment] >= 0} {
4768 set comment
[string map
{"\r" "\n "} $comment]
4770 appendwithlinks
$comment {comment
}
4772 $ctext tag remove found
1.0 end
4773 $ctext conf
-state disabled
4774 set commentend
[$ctext index
"end - 1c"]
4776 init_flist
[mc
"Comments"]
4777 if {$cmitmode eq
"tree"} {
4779 } elseif
{[llength
$olds] <= 1} {
4786 proc selfirstline
{} {
4791 proc sellastline
{} {
4794 set l
[expr {$numcommits - 1}]
4798 proc selnextline
{dir
} {
4801 if {![info exists selectedline
]} return
4802 set l
[expr {$selectedline + $dir}]
4807 proc selnextpage
{dir
} {
4808 global canv linespc selectedline numcommits
4810 set lpp
[expr {([winfo height
$canv] - 2) / $linespc}]
4814 allcanvs yview scroll
[expr {$dir * $lpp}] units
4816 if {![info exists selectedline
]} return
4817 set l
[expr {$selectedline + $dir * $lpp}]
4820 } elseif
{$l >= $numcommits} {
4821 set l
[expr $numcommits - 1]
4827 proc unselectline
{} {
4828 global selectedline currentid
4830 catch
{unset selectedline
}
4831 catch
{unset currentid
}
4832 allcanvs delete secsel
4836 proc reselectline
{} {
4839 if {[info exists selectedline
]} {
4840 selectline
$selectedline 0
4844 proc addtohistory
{cmd
} {
4845 global
history historyindex curview
4847 set elt
[list
$curview $cmd]
4848 if {$historyindex > 0
4849 && [lindex
$history [expr {$historyindex - 1}]] == $elt} {
4853 if {$historyindex < [llength
$history]} {
4854 set history [lreplace
$history $historyindex end
$elt]
4856 lappend
history $elt
4859 if {$historyindex > 1} {
4860 .tf.bar.leftbut conf
-state normal
4862 .tf.bar.leftbut conf
-state disabled
4864 .tf.bar.rightbut conf
-state disabled
4870 set view
[lindex
$elt 0]
4871 set cmd
[lindex
$elt 1]
4872 if {$curview != $view} {
4879 global
history historyindex
4882 if {$historyindex > 1} {
4883 incr historyindex
-1
4884 godo
[lindex
$history [expr {$historyindex - 1}]]
4885 .tf.bar.rightbut conf
-state normal
4887 if {$historyindex <= 1} {
4888 .tf.bar.leftbut conf
-state disabled
4893 global
history historyindex
4896 if {$historyindex < [llength
$history]} {
4897 set cmd
[lindex
$history $historyindex]
4900 .tf.bar.leftbut conf
-state normal
4902 if {$historyindex >= [llength
$history]} {
4903 .tf.bar.rightbut conf
-state disabled
4908 global treefilelist treeidlist diffids diffmergeid treepending
4909 global nullid nullid2
4912 catch
{unset diffmergeid
}
4913 if {![info exists treefilelist
($id)]} {
4914 if {![info exists treepending
]} {
4915 if {$id eq
$nullid} {
4916 set cmd
[list | git ls-files
]
4917 } elseif
{$id eq
$nullid2} {
4918 set cmd
[list | git ls-files
--stage -t]
4920 set cmd
[list | git ls-tree
-r $id]
4922 if {[catch
{set gtf
[open
$cmd r
]}]} {
4926 set treefilelist
($id) {}
4927 set treeidlist
($id) {}
4928 fconfigure
$gtf -blocking 0
4929 filerun
$gtf [list gettreeline
$gtf $id]
4936 proc gettreeline
{gtf id
} {
4937 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4940 while {[incr
nl] <= 1000 && [gets
$gtf line
] >= 0} {
4941 if {$diffids eq
$nullid} {
4944 if {$diffids ne
$nullid2 && [lindex
$line 1] ne
"blob"} continue
4945 set i
[string first
"\t" $line]
4946 if {$i < 0} continue
4947 set sha1
[lindex
$line 2]
4948 set fname
[string range
$line [expr {$i+1}] end
]
4949 if {[string index
$fname 0] eq
"\""} {
4950 set fname
[lindex
$fname 0]
4952 lappend treeidlist
($id) $sha1
4954 lappend treefilelist
($id) $fname
4957 return [expr {$nl >= 1000?
2: 1}]
4961 if {$cmitmode ne
"tree"} {
4962 if {![info exists diffmergeid
]} {
4963 gettreediffs
$diffids
4965 } elseif
{$id ne
$diffids} {
4974 global treefilelist treeidlist diffids nullid nullid2
4975 global ctext commentend
4977 set i
[lsearch
-exact $treefilelist($diffids) $f]
4979 puts
"oops, $f not in list for id $diffids"
4982 if {$diffids eq
$nullid} {
4983 if {[catch
{set bf
[open
$f r
]} err
]} {
4984 puts
"oops, can't read $f: $err"
4988 set blob
[lindex
$treeidlist($diffids) $i]
4989 if {[catch
{set bf
[open
[concat | git cat-file blob
$blob] r
]} err
]} {
4990 puts
"oops, error reading blob $blob: $err"
4994 fconfigure
$bf -blocking 0
4995 filerun
$bf [list getblobline
$bf $diffids]
4996 $ctext config
-state normal
4997 clear_ctext
$commentend
4998 $ctext insert end
"\n"
4999 $ctext insert end
"$f\n" filesep
5000 $ctext config
-state disabled
5001 $ctext yview
$commentend
5005 proc getblobline
{bf id
} {
5006 global diffids cmitmode ctext
5008 if {$id ne
$diffids ||
$cmitmode ne
"tree"} {
5012 $ctext config
-state normal
5014 while {[incr
nl] <= 1000 && [gets
$bf line
] >= 0} {
5015 $ctext insert end
"$line\n"
5018 # delete last newline
5019 $ctext delete
"end - 2c" "end - 1c"
5023 $ctext config
-state disabled
5024 return [expr {$nl >= 1000?
2: 1}]
5027 proc mergediff
{id l
} {
5028 global diffmergeid mdifffd
5031 global limitdiffs viewfiles curview
5035 # this doesn't seem to actually affect anything...
5036 set cmd
[concat | git diff-tree
--no-commit-id --cc $id]
5037 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5038 set cmd
[concat
$cmd -- $viewfiles($curview)]
5040 if {[catch
{set mdf
[open
$cmd r
]} err
]} {
5041 error_popup
"[mc "Error getting merge diffs
:"] $err"
5044 fconfigure
$mdf -blocking 0
5045 set mdifffd
($id) $mdf
5046 set np
[llength
[lindex
$parentlist $l]]
5048 filerun
$mdf [list getmergediffline
$mdf $id $np]
5051 proc getmergediffline
{mdf id np
} {
5052 global diffmergeid ctext cflist mergemax
5053 global difffilestart mdifffd
5055 $ctext conf
-state normal
5057 while {[incr nr
] <= 1000 && [gets
$mdf line
] >= 0} {
5058 if {![info exists diffmergeid
] ||
$id != $diffmergeid
5059 ||
$mdf != $mdifffd($id)} {
5063 if {[regexp
{^
diff --cc (.
*)} $line match fname
]} {
5064 # start of a new file
5065 $ctext insert end
"\n"
5066 set here
[$ctext index
"end - 1c"]
5067 lappend difffilestart
$here
5068 add_flist
[list
$fname]
5069 set l
[expr {(78 - [string length
$fname]) / 2}]
5070 set pad
[string range
"----------------------------------------" 1 $l]
5071 $ctext insert end
"$pad $fname $pad\n" filesep
5072 } elseif
{[regexp
{^@@
} $line]} {
5073 $ctext insert end
"$line\n" hunksep
5074 } elseif
{[regexp
{^
[0-9a-f]{40}$
} $line] ||
[regexp
{^index
} $line]} {
5077 # parse the prefix - one ' ', '-' or '+' for each parent
5082 for {set j
0} {$j < $np} {incr j
} {
5083 set c
[string range
$line $j $j]
5086 } elseif
{$c == "-"} {
5088 } elseif
{$c == "+"} {
5097 if {!$isbad && $minuses ne
{} && $pluses eq
{}} {
5098 # line doesn't appear in result, parents in $minuses have the line
5099 set num
[lindex
$minuses 0]
5100 } elseif
{!$isbad && $pluses ne
{} && $minuses eq
{}} {
5101 # line appears in result, parents in $pluses don't have the line
5102 lappend tags mresult
5103 set num
[lindex
$spaces 0]
5106 if {$num >= $mergemax} {
5111 $ctext insert end
"$line\n" $tags
5114 $ctext conf
-state disabled
5119 return [expr {$nr >= 1000?
2: 1}]
5122 proc startdiff
{ids
} {
5123 global treediffs diffids treepending diffmergeid nullid nullid2
5127 catch
{unset diffmergeid
}
5128 if {![info exists treediffs
($ids)] ||
5129 [lsearch
-exact $ids $nullid] >= 0 ||
5130 [lsearch
-exact $ids $nullid2] >= 0} {
5131 if {![info exists treepending
]} {
5139 proc path_filter
{filter name
} {
5141 set l
[string length
$p]
5142 if {[string index
$p end
] eq
"/"} {
5143 if {[string compare
-length $l $p $name] == 0} {
5147 if {[string compare
-length $l $p $name] == 0 &&
5148 ([string length
$name] == $l ||
5149 [string index
$name $l] eq
"/")} {
5157 proc addtocflist
{ids
} {
5160 add_flist
$treediffs($ids)
5164 proc diffcmd
{ids flags
} {
5165 global nullid nullid2
5167 set i
[lsearch
-exact $ids $nullid]
5168 set j
[lsearch
-exact $ids $nullid2]
5170 if {[llength
$ids] > 1 && $j < 0} {
5171 # comparing working directory with some specific revision
5172 set cmd
[concat | git diff-index
$flags]
5174 lappend cmd
-R [lindex
$ids 1]
5176 lappend cmd
[lindex
$ids 0]
5179 # comparing working directory with index
5180 set cmd
[concat | git diff-files
$flags]
5185 } elseif
{$j >= 0} {
5186 set cmd
[concat | git diff-index
--cached $flags]
5187 if {[llength
$ids] > 1} {
5188 # comparing index with specific revision
5190 lappend cmd
-R [lindex
$ids 1]
5192 lappend cmd
[lindex
$ids 0]
5195 # comparing index with HEAD
5199 set cmd
[concat | git diff-tree
-r $flags $ids]
5204 proc gettreediffs
{ids
} {
5205 global treediff treepending
5207 set treepending
$ids
5209 if {[catch
{set gdtf
[open
[diffcmd
$ids {--no-commit-id}] r
]}]} return
5210 fconfigure
$gdtf -blocking 0
5211 filerun
$gdtf [list gettreediffline
$gdtf $ids]
5214 proc gettreediffline
{gdtf ids
} {
5215 global treediff treediffs treepending diffids diffmergeid
5216 global cmitmode viewfiles curview limitdiffs
5219 while {[incr nr
] <= 1000 && [gets
$gdtf line
] >= 0} {
5220 set i
[string first
"\t" $line]
5222 set file [string range
$line [expr {$i+1}] end
]
5223 if {[string index
$file 0] eq
"\""} {
5224 set file [lindex
$file 0]
5226 lappend treediff
$file
5230 return [expr {$nr >= 1000?
2: 1}]
5233 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5235 foreach f
$treediff {
5236 if {[path_filter
$viewfiles($curview) $f]} {
5240 set treediffs
($ids) $flist
5242 set treediffs
($ids) $treediff
5245 if {$cmitmode eq
"tree"} {
5247 } elseif
{$ids != $diffids} {
5248 if {![info exists diffmergeid
]} {
5249 gettreediffs
$diffids
5257 # empty string or positive integer
5258 proc diffcontextvalidate
{v
} {
5259 return [regexp
{^
(|
[1-9][0-9]*)$
} $v]
5262 proc diffcontextchange
{n1 n2 op
} {
5263 global diffcontextstring diffcontext
5265 if {[string is integer
-strict $diffcontextstring]} {
5266 if {$diffcontextstring > 0} {
5267 set diffcontext
$diffcontextstring
5273 proc getblobdiffs
{ids
} {
5274 global blobdifffd diffids env
5275 global diffinhdr treediffs
5277 global limitdiffs viewfiles curview
5279 set cmd
[diffcmd
$ids "-p -C --no-commit-id -U$diffcontext"]
5280 if {$limitdiffs && $viewfiles($curview) ne
{}} {
5281 set cmd
[concat
$cmd -- $viewfiles($curview)]
5283 if {[catch
{set bdf
[open
$cmd r
]} err
]} {
5284 puts
"error getting diffs: $err"
5288 fconfigure
$bdf -blocking 0
5289 set blobdifffd
($ids) $bdf
5290 filerun
$bdf [list getblobdiffline
$bdf $diffids]
5293 proc setinlist
{var i val
} {
5296 while {[llength
[set $var]] < $i} {
5299 if {[llength
[set $var]] == $i} {
5306 proc makediffhdr
{fname ids
} {
5307 global ctext curdiffstart treediffs
5309 set i
[lsearch
-exact $treediffs($ids) $fname]
5311 setinlist difffilestart
$i $curdiffstart
5313 set l
[expr {(78 - [string length
$fname]) / 2}]
5314 set pad
[string range
"----------------------------------------" 1 $l]
5315 $ctext insert
$curdiffstart "$pad $fname $pad" filesep
5318 proc getblobdiffline
{bdf ids
} {
5319 global diffids blobdifffd ctext curdiffstart
5320 global diffnexthead diffnextnote difffilestart
5321 global diffinhdr treediffs
5324 $ctext conf
-state normal
5325 while {[incr nr
] <= 1000 && [gets
$bdf line
] >= 0} {
5326 if {$ids != $diffids ||
$bdf != $blobdifffd($ids)} {
5330 if {![string compare
-length 11 "diff --git " $line]} {
5331 # trim off "diff --git "
5332 set line
[string range
$line 11 end
]
5334 # start of a new file
5335 $ctext insert end
"\n"
5336 set curdiffstart
[$ctext index
"end - 1c"]
5337 $ctext insert end
"\n" filesep
5338 # If the name hasn't changed the length will be odd,
5339 # the middle char will be a space, and the two bits either
5340 # side will be a/name and b/name, or "a/name" and "b/name".
5341 # If the name has changed we'll get "rename from" and
5342 # "rename to" or "copy from" and "copy to" lines following this,
5343 # and we'll use them to get the filenames.
5344 # This complexity is necessary because spaces in the filename(s)
5345 # don't get escaped.
5346 set l
[string length
$line]
5347 set i
[expr {$l / 2}]
5348 if {!(($l & 1) && [string index
$line $i] eq
" " &&
5349 [string range
$line 2 [expr {$i - 1}]] eq \
5350 [string range
$line [expr {$i + 3}] end
])} {
5353 # unescape if quoted and chop off the a/ from the front
5354 if {[string index
$line 0] eq
"\""} {
5355 set fname
[string range
[lindex
$line 0] 2 end
]
5357 set fname
[string range
$line 2 [expr {$i - 1}]]
5359 makediffhdr
$fname $ids
5361 } elseif
{[regexp
{^@@
-([0-9]+)(,[0-9]+)? \
+([0-9]+)(,[0-9]+)? @@
(.
*)} \
5362 $line match f1l f1c f2l f2c rest
]} {
5363 $ctext insert end
"$line\n" hunksep
5366 } elseif
{$diffinhdr} {
5367 if {![string compare
-length 12 "rename from " $line]} {
5368 set fname
[string range
$line [expr 6 + [string first
" from " $line] ] end
]
5369 if {[string index
$fname 0] eq
"\""} {
5370 set fname
[lindex
$fname 0]
5372 set i
[lsearch
-exact $treediffs($ids) $fname]
5374 setinlist difffilestart
$i $curdiffstart
5376 } elseif
{![string compare
-length 10 $line "rename to "] ||
5377 ![string compare
-length 8 $line "copy to "]} {
5378 set fname
[string range
$line [expr 4 + [string first
" to " $line] ] end
]
5379 if {[string index
$fname 0] eq
"\""} {
5380 set fname
[lindex
$fname 0]
5382 makediffhdr
$fname $ids
5383 } elseif
{[string compare
-length 3 $line "---"] == 0} {
5386 } elseif
{[string compare
-length 3 $line "+++"] == 0} {
5390 $ctext insert end
"$line\n" filesep
5393 set x
[string range
$line 0 0]
5394 if {$x == "-" ||
$x == "+"} {
5395 set tag
[expr {$x == "+"}]
5396 $ctext insert end
"$line\n" d
$tag
5397 } elseif
{$x == " "} {
5398 $ctext insert end
"$line\n"
5400 # "\ No newline at end of file",
5401 # or something else we don't recognize
5402 $ctext insert end
"$line\n" hunksep
5406 $ctext conf
-state disabled
5411 return [expr {$nr >= 1000?
2: 1}]
5414 proc changediffdisp
{} {
5415 global ctext diffelide
5417 $ctext tag conf d0
-elide [lindex
$diffelide 0]
5418 $ctext tag conf d1
-elide [lindex
$diffelide 1]
5422 global difffilestart ctext
5423 set prev
[lindex
$difffilestart 0]
5424 set here
[$ctext index @
0,0]
5425 foreach loc
$difffilestart {
5426 if {[$ctext compare
$loc >= $here]} {
5436 global difffilestart ctext
5437 set here
[$ctext index @
0,0]
5438 foreach loc
$difffilestart {
5439 if {[$ctext compare
$loc > $here]} {
5446 proc clear_ctext
{{first
1.0}} {
5447 global ctext smarktop smarkbot
5450 set l
[lindex
[split $first .
] 0]
5451 if {![info exists smarktop
] ||
[$ctext compare
$first < $smarktop.0]} {
5454 if {![info exists smarkbot
] ||
[$ctext compare
$first < $smarkbot.0]} {
5457 $ctext delete
$first end
5458 if {$first eq
"1.0"} {
5459 catch
{unset pendinglinks
}
5463 proc settabs
{{firstab
{}}} {
5464 global firsttabstop tabstop ctext have_tk85
5466 if {$firstab ne
{} && $have_tk85} {
5467 set firsttabstop
$firstab
5469 set w
[font measure textfont
"0"]
5470 if {$firsttabstop != 0} {
5471 $ctext conf
-tabs [list
[expr {($firsttabstop + $tabstop) * $w}] \
5472 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5473 } elseif
{$have_tk85 ||
$tabstop != 8} {
5474 $ctext conf
-tabs [expr {$tabstop * $w}]
5476 $ctext conf
-tabs {}
5480 proc incrsearch
{name ix op
} {
5481 global ctext searchstring searchdirn
5483 $ctext tag remove found
1.0 end
5484 if {[catch
{$ctext index anchor
}]} {
5485 # no anchor set, use start of selection, or of visible area
5486 set sel
[$ctext tag ranges sel
]
5488 $ctext mark
set anchor
[lindex
$sel 0]
5489 } elseif
{$searchdirn eq
"-forwards"} {
5490 $ctext mark
set anchor @
0,0
5492 $ctext mark
set anchor @
0,[winfo height
$ctext]
5495 if {$searchstring ne
{}} {
5496 set here
[$ctext search
$searchdirn -- $searchstring anchor
]
5505 global sstring ctext searchstring searchdirn
5508 $sstring icursor end
5509 set searchdirn
-forwards
5510 if {$searchstring ne
{}} {
5511 set sel
[$ctext tag ranges sel
]
5513 set start
"[lindex $sel 0] + 1c"
5514 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5517 set match
[$ctext search
-count mlen
-- $searchstring $start]
5518 $ctext tag remove sel
1.0 end
5524 set mend
"$match + $mlen c"
5525 $ctext tag add sel
$match $mend
5526 $ctext mark
unset anchor
5530 proc dosearchback
{} {
5531 global sstring ctext searchstring searchdirn
5534 $sstring icursor end
5535 set searchdirn
-backwards
5536 if {$searchstring ne
{}} {
5537 set sel
[$ctext tag ranges sel
]
5539 set start
[lindex
$sel 0]
5540 } elseif
{[catch
{set start
[$ctext index anchor
]}]} {
5541 set start @
0,[winfo height
$ctext]
5543 set match
[$ctext search
-backwards -count ml
-- $searchstring $start]
5544 $ctext tag remove sel
1.0 end
5550 set mend
"$match + $ml c"
5551 $ctext tag add sel
$match $mend
5552 $ctext mark
unset anchor
5556 proc searchmark
{first last
} {
5557 global ctext searchstring
5561 set match
[$ctext search
-count mlen
-- $searchstring $mend $last.end
]
5562 if {$match eq
{}} break
5563 set mend
"$match + $mlen c"
5564 $ctext tag add found
$match $mend
5568 proc searchmarkvisible
{doall
} {
5569 global ctext smarktop smarkbot
5571 set topline
[lindex
[split [$ctext index @
0,0] .
] 0]
5572 set botline
[lindex
[split [$ctext index @
0,[winfo height
$ctext]] .
] 0]
5573 if {$doall ||
$botline < $smarktop ||
$topline > $smarkbot} {
5574 # no overlap with previous
5575 searchmark
$topline $botline
5576 set smarktop
$topline
5577 set smarkbot
$botline
5579 if {$topline < $smarktop} {
5580 searchmark
$topline [expr {$smarktop-1}]
5581 set smarktop
$topline
5583 if {$botline > $smarkbot} {
5584 searchmark
[expr {$smarkbot+1}] $botline
5585 set smarkbot
$botline
5590 proc scrolltext
{f0 f1
} {
5593 .bleft.sb
set $f0 $f1
5594 if {$searchstring ne
{}} {
5600 global linespc charspc canvx0 canvy0
5601 global xspc1 xspc2 lthickness
5603 set linespc
[font metrics mainfont
-linespace]
5604 set charspc
[font measure mainfont
"m"]
5605 set canvy0
[expr {int
(3 + 0.5 * $linespc)}]
5606 set canvx0
[expr {int
(3 + 0.5 * $linespc)}]
5607 set lthickness
[expr {int
($linespc / 9) + 1}]
5608 set xspc1
(0) $linespc
5616 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5617 if {$ymax eq
{} ||
$ymax == 0} return
5618 set span
[$canv yview
]
5621 allcanvs yview moveto
[lindex
$span 0]
5623 if {[info exists selectedline
]} {
5624 selectline
$selectedline 0
5625 allcanvs yview moveto
[lindex
$span 0]
5629 proc parsefont
{f n
} {
5632 set fontattr
($f,family
) [lindex
$n 0]
5634 if {$s eq
{} ||
$s == 0} {
5637 set s
[expr {int
(-$s / [winfo fpixels .
1p
] + 0.5)}]
5639 set fontattr
($f,size
) $s
5640 set fontattr
($f,weight
) normal
5641 set fontattr
($f,slant
) roman
5642 foreach style
[lrange
$n 2 end
] {
5645 "bold" {set fontattr
($f,weight
) $style}
5647 "italic" {set fontattr
($f,slant
) $style}
5652 proc fontflags
{f
{isbold
0}} {
5655 return [list
-family $fontattr($f,family
) -size $fontattr($f,size
) \
5656 -weight [expr {$isbold?
"bold": $fontattr($f,weight
)}] \
5657 -slant $fontattr($f,slant
)]
5663 set n
[list
$fontattr($f,family
) $fontattr($f,size
)]
5664 if {$fontattr($f,weight
) eq
"bold"} {
5667 if {$fontattr($f,slant
) eq
"italic"} {
5673 proc incrfont
{inc
} {
5674 global mainfont textfont ctext canv phase cflist showrefstop
5675 global stopped entries fontattr
5678 set s
$fontattr(mainfont
,size
)
5683 set fontattr
(mainfont
,size
) $s
5684 font config mainfont
-size $s
5685 font config mainfontbold
-size $s
5686 set mainfont
[fontname mainfont
]
5687 set s
$fontattr(textfont
,size
)
5692 set fontattr
(textfont
,size
) $s
5693 font config textfont
-size $s
5694 font config textfontbold
-size $s
5695 set textfont
[fontname textfont
]
5702 global sha1entry sha1string
5703 if {[string length
$sha1string] == 40} {
5704 $sha1entry delete
0 end
5708 proc sha1change
{n1 n2 op
} {
5709 global sha1string currentid sha1but
5710 if {$sha1string == {}
5711 ||
([info exists currentid
] && $sha1string == $currentid)} {
5716 if {[$sha1but cget
-state] == $state} return
5717 if {$state == "normal"} {
5718 $sha1but conf
-state normal
-relief raised
-text "[mc "Goto
:"] "
5720 $sha1but conf
-state disabled
-relief flat
-text "[mc "SHA1 ID
:"] "
5724 proc gotocommit
{} {
5725 global sha1string currentid commitrow tagids headids
5726 global displayorder numcommits curview
5728 if {$sha1string == {}
5729 ||
([info exists currentid
] && $sha1string == $currentid)} return
5730 if {[info exists tagids
($sha1string)]} {
5731 set id
$tagids($sha1string)
5732 } elseif
{[info exists headids
($sha1string)]} {
5733 set id
$headids($sha1string)
5735 set id
[string tolower
$sha1string]
5736 if {[regexp
{^
[0-9a-f]{4,39}$
} $id]} {
5738 foreach i
$displayorder {
5739 if {[string match
$id* $i]} {
5743 if {$matches ne
{}} {
5744 if {[llength
$matches] > 1} {
5745 error_popup
[mc
"Short SHA1 id %s is ambiguous" $id]
5748 set id
[lindex
$matches 0]
5752 if {[info exists commitrow
($curview,$id)]} {
5753 selectline
$commitrow($curview,$id) 1
5756 if {[regexp
{^
[0-9a-fA-F]{4,}$
} $sha1string]} {
5757 set msg
[mc
"SHA1 id %s is not known" $sha1string]
5759 set msg
[mc
"Tag/Head %s is not known" $sha1string]
5764 proc lineenter
{x y id
} {
5765 global hoverx hovery hoverid hovertimer
5766 global commitinfo canv
5768 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5772 if {[info exists hovertimer
]} {
5773 after cancel
$hovertimer
5775 set hovertimer
[after
500 linehover
]
5779 proc linemotion
{x y id
} {
5780 global hoverx hovery hoverid hovertimer
5782 if {[info exists hoverid
] && $id == $hoverid} {
5785 if {[info exists hovertimer
]} {
5786 after cancel
$hovertimer
5788 set hovertimer
[after
500 linehover
]
5792 proc lineleave
{id
} {
5793 global hoverid hovertimer canv
5795 if {[info exists hoverid
] && $id == $hoverid} {
5797 if {[info exists hovertimer
]} {
5798 after cancel
$hovertimer
5806 global hoverx hovery hoverid hovertimer
5807 global canv linespc lthickness
5810 set text
[lindex
$commitinfo($hoverid) 0]
5811 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5812 if {$ymax == {}} return
5813 set yfrac
[lindex
[$canv yview
] 0]
5814 set x
[expr {$hoverx + 2 * $linespc}]
5815 set y
[expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5816 set x0
[expr {$x - 2 * $lthickness}]
5817 set y0
[expr {$y - 2 * $lthickness}]
5818 set x1
[expr {$x + [font measure mainfont
$text] + 2 * $lthickness}]
5819 set y1
[expr {$y + $linespc + 2 * $lthickness}]
5820 set t
[$canv create rectangle
$x0 $y0 $x1 $y1 \
5821 -fill \
#ffff80 -outline black -width 1 -tags hover]
5823 set t
[$canv create text
$x $y -anchor nw
-text $text -tags hover \
5828 proc clickisonarrow
{id y
} {
5831 set ranges
[rowranges
$id]
5832 set thresh
[expr {2 * $lthickness + 6}]
5833 set n
[expr {[llength
$ranges] - 1}]
5834 for {set i
1} {$i < $n} {incr i
} {
5835 set row
[lindex
$ranges $i]
5836 if {abs
([yc
$row] - $y) < $thresh} {
5843 proc arrowjump
{id n y
} {
5846 # 1 <-> 2, 3 <-> 4, etc...
5847 set n
[expr {(($n - 1) ^
1) + 1}]
5848 set row
[lindex
[rowranges
$id] $n]
5850 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5851 if {$ymax eq
{} ||
$ymax <= 0} return
5852 set view
[$canv yview
]
5853 set yspan
[expr {[lindex
$view 1] - [lindex
$view 0]}]
5854 set yfrac
[expr {$yt / $ymax - $yspan / 2}]
5858 allcanvs yview moveto
$yfrac
5861 proc lineclick
{x y id isnew
} {
5862 global ctext commitinfo children canv thickerline curview commitrow
5864 if {![info exists commitinfo
($id)] && ![getcommit
$id]} return
5869 # draw this line thicker than normal
5873 set ymax
[lindex
[$canv cget
-scrollregion] 3]
5874 if {$ymax eq
{}} return
5875 set yfrac
[lindex
[$canv yview
] 0]
5876 set y
[expr {$y + $yfrac * $ymax}]
5878 set dirn
[clickisonarrow
$id $y]
5880 arrowjump
$id $dirn $y
5885 addtohistory
[list lineclick
$x $y $id 0]
5887 # fill the details pane with info about this line
5888 $ctext conf
-state normal
5891 $ctext insert end
"[mc "Parent
"]:\t"
5892 $ctext insert end
$id link0
5894 set info
$commitinfo($id)
5895 $ctext insert end
"\n\t[lindex $info 0]\n"
5896 $ctext insert end
"\t[mc "Author
"]:\t[lindex $info 1]\n"
5897 set date [formatdate
[lindex
$info 2]]
5898 $ctext insert end
"\t[mc "Date
"]:\t$date\n"
5899 set kids
$children($curview,$id)
5901 $ctext insert end
"\n[mc "Children
"]:"
5903 foreach child
$kids {
5905 if {![info exists commitinfo
($child)] && ![getcommit
$child]} continue
5906 set info
$commitinfo($child)
5907 $ctext insert end
"\n\t"
5908 $ctext insert end
$child link
$i
5909 setlink
$child link
$i
5910 $ctext insert end
"\n\t[lindex $info 0]"
5911 $ctext insert end
"\n\t[mc "Author
"]:\t[lindex $info 1]"
5912 set date [formatdate
[lindex
$info 2]]
5913 $ctext insert end
"\n\t[mc "Date
"]:\t$date\n"
5916 $ctext conf
-state disabled
5920 proc normalline
{} {
5922 if {[info exists thickerline
]} {
5930 global commitrow curview
5931 if {[info exists commitrow
($curview,$id)]} {
5932 selectline
$commitrow($curview,$id) 1
5938 if {![info exists startmstime
]} {
5939 set startmstime
[clock clicks
-milliseconds]
5941 return [format
"%.3f" [expr {([clock click
-milliseconds] - $startmstime) / 1000.0}]]
5944 proc rowmenu
{x y id
} {
5945 global rowctxmenu commitrow selectedline rowmenuid curview
5946 global nullid nullid2 fakerowmenu mainhead
5950 if {![info exists selectedline
]
5951 ||
$commitrow($curview,$id) eq
$selectedline} {
5956 if {$id ne
$nullid && $id ne
$nullid2} {
5957 set menu
$rowctxmenu
5958 $menu entryconfigure
7 -label [mc
"Reset %s branch to here" $mainhead]
5960 set menu
$fakerowmenu
5962 $menu entryconfigure
[mc
"Diff this -> selected"] -state $state
5963 $menu entryconfigure
[mc
"Diff selected -> this"] -state $state
5964 $menu entryconfigure
[mc
"Make patch"] -state $state
5965 tk_popup
$menu $x $y
5968 proc diffvssel
{dirn
} {
5969 global rowmenuid selectedline displayorder
5971 if {![info exists selectedline
]} return
5973 set oldid
[lindex
$displayorder $selectedline]
5974 set newid
$rowmenuid
5976 set oldid
$rowmenuid
5977 set newid
[lindex
$displayorder $selectedline]
5979 addtohistory
[list doseldiff
$oldid $newid]
5980 doseldiff
$oldid $newid
5983 proc doseldiff
{oldid newid
} {
5987 $ctext conf
-state normal
5989 init_flist
[mc
"Top"]
5990 $ctext insert end
"[mc "From
"] "
5991 $ctext insert end
$oldid link0
5992 setlink
$oldid link0
5993 $ctext insert end
"\n "
5994 $ctext insert end
[lindex
$commitinfo($oldid) 0]
5995 $ctext insert end
"\n\n[mc "To
"] "
5996 $ctext insert end
$newid link1
5997 setlink
$newid link1
5998 $ctext insert end
"\n "
5999 $ctext insert end
[lindex
$commitinfo($newid) 0]
6000 $ctext insert end
"\n"
6001 $ctext conf
-state disabled
6002 $ctext tag remove found
1.0 end
6003 startdiff
[list
$oldid $newid]
6007 global rowmenuid currentid commitinfo patchtop patchnum
6009 if {![info exists currentid
]} return
6010 set oldid
$currentid
6011 set oldhead
[lindex
$commitinfo($oldid) 0]
6012 set newid
$rowmenuid
6013 set newhead
[lindex
$commitinfo($newid) 0]
6016 catch
{destroy
$top}
6018 label
$top.title
-text [mc
"Generate patch"]
6019 grid
$top.title
- -pady 10
6020 label
$top.from
-text [mc
"From:"]
6021 entry
$top.fromsha1
-width 40 -relief flat
6022 $top.fromsha1 insert
0 $oldid
6023 $top.fromsha1 conf
-state readonly
6024 grid
$top.from
$top.fromsha1
-sticky w
6025 entry
$top.fromhead
-width 60 -relief flat
6026 $top.fromhead insert
0 $oldhead
6027 $top.fromhead conf
-state readonly
6028 grid x
$top.fromhead
-sticky w
6029 label
$top.to
-text [mc
"To:"]
6030 entry
$top.tosha1
-width 40 -relief flat
6031 $top.tosha1 insert
0 $newid
6032 $top.tosha1 conf
-state readonly
6033 grid
$top.to
$top.tosha1
-sticky w
6034 entry
$top.tohead
-width 60 -relief flat
6035 $top.tohead insert
0 $newhead
6036 $top.tohead conf
-state readonly
6037 grid x
$top.tohead
-sticky w
6038 button
$top.
rev -text [mc
"Reverse"] -command mkpatchrev
-padx 5
6039 grid
$top.
rev x
-pady 10
6040 label
$top.flab
-text [mc
"Output file:"]
6041 entry
$top.fname
-width 60
6042 $top.fname insert
0 [file normalize
"patch$patchnum.patch"]
6044 grid
$top.flab
$top.fname
-sticky w
6046 button
$top.buts.gen
-text [mc
"Generate"] -command mkpatchgo
6047 button
$top.buts.can
-text [mc
"Cancel"] -command mkpatchcan
6048 grid
$top.buts.gen
$top.buts.can
6049 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6050 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6051 grid
$top.buts
- -pady 10 -sticky ew
6055 proc mkpatchrev
{} {
6058 set oldid
[$patchtop.fromsha1 get
]
6059 set oldhead
[$patchtop.fromhead get
]
6060 set newid
[$patchtop.tosha1 get
]
6061 set newhead
[$patchtop.tohead get
]
6062 foreach e
[list fromsha1 fromhead tosha1 tohead
] \
6063 v
[list
$newid $newhead $oldid $oldhead] {
6064 $patchtop.
$e conf
-state normal
6065 $patchtop.
$e delete
0 end
6066 $patchtop.
$e insert
0 $v
6067 $patchtop.
$e conf
-state readonly
6072 global patchtop nullid nullid2
6074 set oldid
[$patchtop.fromsha1 get
]
6075 set newid
[$patchtop.tosha1 get
]
6076 set fname
[$patchtop.fname get
]
6077 set cmd
[diffcmd
[list
$oldid $newid] -p]
6078 # trim off the initial "|"
6079 set cmd
[lrange
$cmd 1 end
]
6080 lappend cmd
>$fname &
6081 if {[catch
{eval exec $cmd} err
]} {
6082 error_popup
"[mc "Error creating
patch:"] $err"
6084 catch
{destroy
$patchtop}
6088 proc mkpatchcan
{} {
6091 catch
{destroy
$patchtop}
6096 global rowmenuid mktagtop commitinfo
6100 catch
{destroy
$top}
6102 label
$top.title
-text [mc
"Create tag"]
6103 grid
$top.title
- -pady 10
6104 label
$top.id
-text [mc
"ID:"]
6105 entry
$top.sha1
-width 40 -relief flat
6106 $top.sha1 insert
0 $rowmenuid
6107 $top.sha1 conf
-state readonly
6108 grid
$top.id
$top.sha1
-sticky w
6109 entry
$top.
head -width 60 -relief flat
6110 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6111 $top.
head conf
-state readonly
6112 grid x
$top.
head -sticky w
6113 label
$top.tlab
-text [mc
"Tag name:"]
6114 entry
$top.tag
-width 60
6115 grid
$top.tlab
$top.tag
-sticky w
6117 button
$top.buts.gen
-text [mc
"Create"] -command mktaggo
6118 button
$top.buts.can
-text [mc
"Cancel"] -command mktagcan
6119 grid
$top.buts.gen
$top.buts.can
6120 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6121 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6122 grid
$top.buts
- -pady 10 -sticky ew
6127 global mktagtop env tagids idtags
6129 set id
[$mktagtop.sha1 get
]
6130 set tag
[$mktagtop.tag get
]
6132 error_popup
[mc
"No tag name specified"]
6135 if {[info exists tagids
($tag)]} {
6136 error_popup
[mc
"Tag \"%s\" already exists" $tag]
6141 set fname
[file join $dir "refs/tags" $tag]
6142 set f
[open
$fname w
]
6146 error_popup
"[mc "Error creating tag
:"] $err"
6150 set tagids
($tag) $id
6151 lappend idtags
($id) $tag
6158 proc redrawtags
{id
} {
6159 global canv linehtag commitrow idpos selectedline curview
6160 global canvxmax iddrawn
6162 if {![info exists commitrow
($curview,$id)]} return
6163 if {![info exists iddrawn
($id)]} return
6164 drawcommits
$commitrow($curview,$id)
6165 $canv delete tag.
$id
6166 set xt
[eval drawtags
$id $idpos($id)]
6167 $canv coords
$linehtag($commitrow($curview,$id)) $xt [lindex
$idpos($id) 2]
6168 set text
[$canv itemcget
$linehtag($commitrow($curview,$id)) -text]
6169 set xr
[expr {$xt + [font measure mainfont
$text]}]
6170 if {$xr > $canvxmax} {
6174 if {[info exists selectedline
]
6175 && $selectedline == $commitrow($curview,$id)} {
6176 selectline
$selectedline 0
6183 catch
{destroy
$mktagtop}
6192 proc writecommit
{} {
6193 global rowmenuid wrcomtop commitinfo wrcomcmd
6195 set top .writecommit
6197 catch
{destroy
$top}
6199 label
$top.title
-text [mc
"Write commit to file"]
6200 grid
$top.title
- -pady 10
6201 label
$top.id
-text [mc
"ID:"]
6202 entry
$top.sha1
-width 40 -relief flat
6203 $top.sha1 insert
0 $rowmenuid
6204 $top.sha1 conf
-state readonly
6205 grid
$top.id
$top.sha1
-sticky w
6206 entry
$top.
head -width 60 -relief flat
6207 $top.
head insert
0 [lindex
$commitinfo($rowmenuid) 0]
6208 $top.
head conf
-state readonly
6209 grid x
$top.
head -sticky w
6210 label
$top.clab
-text [mc
"Command:"]
6211 entry
$top.cmd
-width 60 -textvariable wrcomcmd
6212 grid
$top.clab
$top.cmd
-sticky w
-pady 10
6213 label
$top.flab
-text [mc
"Output file:"]
6214 entry
$top.fname
-width 60
6215 $top.fname insert
0 [file normalize
"commit-[string range $rowmenuid 0 6]"]
6216 grid
$top.flab
$top.fname
-sticky w
6218 button
$top.buts.gen
-text [mc
"Write"] -command wrcomgo
6219 button
$top.buts.can
-text [mc
"Cancel"] -command wrcomcan
6220 grid
$top.buts.gen
$top.buts.can
6221 grid columnconfigure
$top.buts
0 -weight 1 -uniform a
6222 grid columnconfigure
$top.buts
1 -weight 1 -uniform a
6223 grid
$top.buts
- -pady 10 -sticky ew
6230 set id
[$wrcomtop.sha1 get
]
6231 set cmd
"echo $id | [$wrcomtop.cmd get]"
6232 set fname
[$wrcomtop.fname get
]
6233 if {[catch
{exec sh
-c $cmd >$fname &} err
]} {
6234 error_popup
"[mc "Error writing commit
:"] $err"
6236 catch
{destroy
$wrcomtop}
6243 catch
{destroy
$wrcomtop}
6248 global rowmenuid mkbrtop
6251 catch
{destroy
$top}
6253 label
$top.title
-text [mc
"Create new branch"]
6254 grid
$top.title
- -pady 10
6255 label
$top.id
-text [mc
"ID:"]
6256 entry
$top.sha1
-width 40 -relief flat
6257 $top.sha1 insert
0 $rowmenuid
6258 $top.sha1 conf
-state readonly
6259 grid
$top.id
$top.sha1
-sticky w
6260 label
$top.nlab
-text [mc
"Name:"]
6261 entry
$top.name
-width 40
6262 grid
$top.nlab
$top.name
-sticky w
6264 button
$top.buts.go
-text [mc
"Create"] -command [list mkbrgo
$top]
6265 button
$top.buts.can
-text [mc
"Cancel"] -command "catch {destroy $top}"
6266 grid
$top.buts.go
$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
6274 global headids idheads
6276 set name
[$top.name get
]
6277 set id
[$top.sha1 get
]
6279 error_popup
[mc
"Please specify a name for the new branch"]
6282 catch
{destroy
$top}
6286 exec git branch
$name $id
6291 set headids
($name) $id
6292 lappend idheads
($id) $name
6301 proc cherrypick
{} {
6302 global rowmenuid curview commitrow
6305 set oldhead
[exec git rev-parse HEAD
]
6306 set dheads
[descheads
$rowmenuid]
6307 if {$dheads ne
{} && [lsearch
-exact $dheads $oldhead] >= 0} {
6308 set ok
[confirm_popup
[mc
"Commit %s is already\
6309 included in branch %s -- really re-apply it?" \
6310 [string range
$rowmenuid 0 7] $mainhead]]
6313 nowbusy cherrypick
[mc
"Cherry-picking"]
6315 # Unfortunately git-cherry-pick writes stuff to stderr even when
6316 # no error occurs, and exec takes that as an indication of error...
6317 if {[catch
{exec sh
-c "git cherry-pick -r $rowmenuid 2>&1"} err
]} {
6322 set newhead
[exec git rev-parse HEAD
]
6323 if {$newhead eq
$oldhead} {
6325 error_popup
[mc
"No changes committed"]
6328 addnewchild
$newhead $oldhead
6329 if {[info exists commitrow
($curview,$oldhead)]} {
6330 insertrow
$commitrow($curview,$oldhead) $newhead
6331 if {$mainhead ne
{}} {
6332 movehead
$newhead $mainhead
6333 movedhead
$newhead $mainhead
6342 global mainheadid mainhead rowmenuid confirm_ok resettype
6345 set w
".confirmreset"
6348 wm title
$w [mc
"Confirm reset"]
6349 message
$w.m
-text \
6350 [mc
"Reset branch %s to %s?" $mainhead [string range
$rowmenuid 0 7]] \
6351 -justify center
-aspect 1000
6352 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
6353 frame
$w.f
-relief sunken
-border 2
6354 message
$w.f.rt
-text [mc
"Reset type:"] -aspect 1000
6355 grid
$w.f.rt
-sticky w
6357 radiobutton
$w.f.soft
-value soft
-variable resettype
-justify left \
6358 -text [mc
"Soft: Leave working tree and index untouched"]
6359 grid
$w.f.soft
-sticky w
6360 radiobutton
$w.f.mixed
-value mixed
-variable resettype
-justify left \
6361 -text [mc
"Mixed: Leave working tree untouched, reset index"]
6362 grid
$w.f.mixed
-sticky w
6363 radiobutton
$w.f.hard
-value hard
-variable resettype
-justify left \
6364 -text [mc
"Hard: Reset working tree and index\n(discard ALL local changes)"]
6365 grid
$w.f.hard
-sticky w
6366 pack
$w.f
-side top
-fill x
6367 button
$w.ok
-text [mc OK
] -command "set confirm_ok 1; destroy $w"
6368 pack
$w.ok
-side left
-fill x
-padx 20 -pady 20
6369 button
$w.cancel
-text [mc Cancel
] -command "destroy $w"
6370 pack
$w.cancel
-side right
-fill x
-padx 20 -pady 20
6371 bind $w <Visibility
> "grab $w; focus $w"
6373 if {!$confirm_ok} return
6374 if {[catch
{set fd
[open \
6375 [list | sh
-c "git reset --$resettype $rowmenuid 2>&1"] r
]} err
]} {
6379 filerun
$fd [list readresetstat
$fd]
6380 nowbusy
reset [mc
"Resetting"]
6384 proc readresetstat
{fd
} {
6385 global mainhead mainheadid showlocalchanges rprogcoord
6387 if {[gets
$fd line
] >= 0} {
6388 if {[regexp
{([0-9]+)% \
(([0-9]+)/([0-9]+)\
)} $line match p m n
]} {
6389 set rprogcoord
[expr {1.0 * $m / $n}]
6397 if {[catch
{close
$fd} err
]} {
6400 set oldhead
$mainheadid
6401 set newhead
[exec git rev-parse HEAD
]
6402 if {$newhead ne
$oldhead} {
6403 movehead
$newhead $mainhead
6404 movedhead
$newhead $mainhead
6405 set mainheadid
$newhead
6409 if {$showlocalchanges} {
6415 # context menu for a head
6416 proc headmenu
{x y id
head} {
6417 global headmenuid headmenuhead headctxmenu mainhead
6421 set headmenuhead
$head
6423 if {$head eq
$mainhead} {
6426 $headctxmenu entryconfigure
0 -state $state
6427 $headctxmenu entryconfigure
1 -state $state
6428 tk_popup
$headctxmenu $x $y
6432 global headmenuid headmenuhead mainhead headids
6433 global showlocalchanges mainheadid
6435 # check the tree is clean first??
6436 set oldmainhead
$mainhead
6437 nowbusy checkout
[mc
"Checking out"]
6441 exec git checkout
-q $headmenuhead
6447 set mainhead
$headmenuhead
6448 set mainheadid
$headmenuid
6449 if {[info exists headids
($oldmainhead)]} {
6450 redrawtags
$headids($oldmainhead)
6452 redrawtags
$headmenuid
6454 if {$showlocalchanges} {
6460 global headmenuid headmenuhead mainhead
6463 set head $headmenuhead
6465 # this check shouldn't be needed any more...
6466 if {$head eq
$mainhead} {
6467 error_popup
[mc
"Cannot delete the currently checked-out branch"]
6470 set dheads
[descheads
$id]
6471 if {[llength
$dheads] == 1 && $idheads($dheads) eq
$head} {
6472 # the stuff on this branch isn't on any other branch
6473 if {![confirm_popup
[mc
"The commits on branch %s aren't on any other\
6474 branch.\nReally delete branch %s?" $head $head]]} return
6478 if {[catch
{exec git branch
-D $head} err
]} {
6483 removehead
$id $head
6484 removedhead
$id $head
6491 # Display a list of tags and heads
6493 global showrefstop bgcolor fgcolor selectbgcolor
6494 global bglist fglist reflistfilter reflist maincursor
6497 set showrefstop
$top
6498 if {[winfo exists
$top]} {
6504 wm title
$top [mc
"Tags and heads: %s" [file tail [pwd]]]
6505 text
$top.list
-background $bgcolor -foreground $fgcolor \
6506 -selectbackground $selectbgcolor -font mainfont \
6507 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6508 -width 30 -height 20 -cursor $maincursor \
6509 -spacing1 1 -spacing3 1 -state disabled
6510 $top.list tag configure highlight
-background $selectbgcolor
6511 lappend bglist
$top.list
6512 lappend fglist
$top.list
6513 scrollbar
$top.ysb
-command "$top.list yview" -orient vertical
6514 scrollbar
$top.xsb
-command "$top.list xview" -orient horizontal
6515 grid
$top.list
$top.ysb
-sticky nsew
6516 grid
$top.xsb x
-sticky ew
6518 label
$top.f.l
-text "[mc "Filter
"]: "
6519 entry
$top.f.e
-width 20 -textvariable reflistfilter
6520 set reflistfilter
"*"
6521 trace add variable reflistfilter
write reflistfilter_change
6522 pack
$top.f.e
-side right
-fill x
-expand 1
6523 pack
$top.f.l
-side left
6524 grid
$top.f
- -sticky ew
-pady 2
6525 button
$top.close
-command [list destroy
$top] -text [mc
"Close"]
6527 grid columnconfigure
$top 0 -weight 1
6528 grid rowconfigure
$top 0 -weight 1
6529 bind $top.list
<1> {break}
6530 bind $top.list
<B1-Motion
> {break}
6531 bind $top.list
<ButtonRelease-1
> {sel_reflist
%W
%x
%y
; break}
6536 proc sel_reflist
{w x y
} {
6537 global showrefstop reflist headids tagids otherrefids
6539 if {![winfo exists
$showrefstop]} return
6540 set l
[lindex
[split [$w index
"@$x,$y"] "."] 0]
6541 set ref
[lindex
$reflist [expr {$l-1}]]
6542 set n
[lindex
$ref 0]
6543 switch
-- [lindex
$ref 1] {
6544 "H" {selbyid
$headids($n)}
6545 "T" {selbyid
$tagids($n)}
6546 "o" {selbyid
$otherrefids($n)}
6548 $showrefstop.list tag add highlight
$l.0 "$l.0 lineend"
6551 proc unsel_reflist
{} {
6554 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6555 $showrefstop.list tag remove highlight
0.0 end
6558 proc reflistfilter_change
{n1 n2 op
} {
6559 global reflistfilter
6561 after cancel refill_reflist
6562 after
200 refill_reflist
6565 proc refill_reflist
{} {
6566 global reflist reflistfilter showrefstop headids tagids otherrefids
6567 global commitrow curview commitinterest
6569 if {![info exists showrefstop
] ||
![winfo exists
$showrefstop]} return
6571 foreach n
[array names headids
] {
6572 if {[string match
$reflistfilter $n]} {
6573 if {[info exists commitrow
($curview,$headids($n))]} {
6574 lappend refs
[list
$n H
]
6576 set commitinterest
($headids($n)) {run refill_reflist
}
6580 foreach n
[array names tagids
] {
6581 if {[string match
$reflistfilter $n]} {
6582 if {[info exists commitrow
($curview,$tagids($n))]} {
6583 lappend refs
[list
$n T
]
6585 set commitinterest
($tagids($n)) {run refill_reflist
}
6589 foreach n
[array names otherrefids
] {
6590 if {[string match
$reflistfilter $n]} {
6591 if {[info exists commitrow
($curview,$otherrefids($n))]} {
6592 lappend refs
[list
$n o
]
6594 set commitinterest
($otherrefids($n)) {run refill_reflist
}
6598 set refs
[lsort
-index 0 $refs]
6599 if {$refs eq
$reflist} return
6601 # Update the contents of $showrefstop.list according to the
6602 # differences between $reflist (old) and $refs (new)
6603 $showrefstop.list conf
-state normal
6604 $showrefstop.list insert end
"\n"
6607 while {$i < [llength
$reflist] ||
$j < [llength
$refs]} {
6608 if {$i < [llength
$reflist]} {
6609 if {$j < [llength
$refs]} {
6610 set cmp [string compare
[lindex
$reflist $i 0] \
6611 [lindex
$refs $j 0]]
6613 set cmp [string compare
[lindex
$reflist $i 1] \
6614 [lindex
$refs $j 1]]
6624 $showrefstop.list delete
"[expr {$j+1}].0" "[expr {$j+2}].0"
6632 set l
[expr {$j + 1}]
6633 $showrefstop.list image create
$l.0 -align baseline \
6634 -image reficon-
[lindex
$refs $j 1] -padx 2
6635 $showrefstop.list insert
$l.1 "[lindex $refs $j 0]\n"
6641 # delete last newline
6642 $showrefstop.list delete end-2c end-1c
6643 $showrefstop.list conf
-state disabled
6646 # Stuff for finding nearby tags
6647 proc getallcommits
{} {
6648 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6649 global idheads idtags idotherrefs allparents tagobjid
6651 if {![info exists allcommits
]} {
6657 set allccache
[file join [gitdir
] "gitk.cache"]
6659 set f
[open
$allccache r
]
6668 set cmd
[list | git rev-list
--parents]
6669 set allcupdate
[expr {$seeds ne
{}}]
6673 set refs
[concat
[array names idheads
] [array names idtags
] \
6674 [array names idotherrefs
]]
6677 foreach name
[array names tagobjid
] {
6678 lappend tagobjs
$tagobjid($name)
6680 foreach id
[lsort
-unique $refs] {
6681 if {![info exists allparents
($id)] &&
6682 [lsearch
-exact $tagobjs $id] < 0} {
6693 set fd
[open
[concat
$cmd $ids] r
]
6694 fconfigure
$fd -blocking 0
6697 filerun
$fd [list getallclines
$fd]
6703 # Since most commits have 1 parent and 1 child, we group strings of
6704 # such commits into "arcs" joining branch/merge points (BMPs), which
6705 # are commits that either don't have 1 parent or don't have 1 child.
6707 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6708 # arcout(id) - outgoing arcs for BMP
6709 # arcids(a) - list of IDs on arc including end but not start
6710 # arcstart(a) - BMP ID at start of arc
6711 # arcend(a) - BMP ID at end of arc
6712 # growing(a) - arc a is still growing
6713 # arctags(a) - IDs out of arcids (excluding end) that have tags
6714 # archeads(a) - IDs out of arcids (excluding end) that have heads
6715 # The start of an arc is at the descendent end, so "incoming" means
6716 # coming from descendents, and "outgoing" means going towards ancestors.
6718 proc getallclines
{fd
} {
6719 global allparents allchildren idtags idheads nextarc
6720 global arcnos arcids arctags arcout arcend arcstart archeads growing
6721 global seeds allcommits cachedarcs allcupdate
6724 while {[incr nid
] <= 1000 && [gets
$fd line
] >= 0} {
6725 set id
[lindex
$line 0]
6726 if {[info exists allparents
($id)]} {
6731 set olds
[lrange
$line 1 end
]
6732 set allparents
($id) $olds
6733 if {![info exists allchildren
($id)]} {
6734 set allchildren
($id) {}
6739 if {[llength
$olds] == 1 && [llength
$a] == 1} {
6740 lappend arcids
($a) $id
6741 if {[info exists idtags
($id)]} {
6742 lappend arctags
($a) $id
6744 if {[info exists idheads
($id)]} {
6745 lappend archeads
($a) $id
6747 if {[info exists allparents
($olds)]} {
6748 # seen parent already
6749 if {![info exists arcout
($olds)]} {
6752 lappend arcids
($a) $olds
6753 set arcend
($a) $olds
6756 lappend allchildren
($olds) $id
6757 lappend arcnos
($olds) $a
6761 foreach a
$arcnos($id) {
6762 lappend arcids
($a) $id
6769 lappend allchildren
($p) $id
6770 set a
[incr nextarc
]
6771 set arcstart
($a) $id
6778 if {[info exists allparents
($p)]} {
6779 # seen it already, may need to make a new branch
6780 if {![info exists arcout
($p)]} {
6783 lappend arcids
($a) $p
6787 lappend arcnos
($p) $a
6792 global cached_dheads cached_dtags cached_atags
6793 catch
{unset cached_dheads
}
6794 catch
{unset cached_dtags
}
6795 catch
{unset cached_atags
}
6798 return [expr {$nid >= 1000?
2: 1}]
6802 fconfigure
$fd -blocking 1
6805 # got an error reading the list of commits
6806 # if we were updating, try rereading the whole thing again
6812 error_popup
"[mc "Error reading commit topology information
;\
6813 branch and preceding
/following tag information\
6814 will be incomplete.
"]\n($err)"
6817 if {[incr allcommits
-1] == 0} {
6827 proc recalcarc
{a
} {
6828 global arctags archeads arcids idtags idheads
6832 foreach id
[lrange
$arcids($a) 0 end-1
] {
6833 if {[info exists idtags
($id)]} {
6836 if {[info exists idheads
($id)]} {
6841 set archeads
($a) $ah
6845 global arcnos arcids nextarc arctags archeads idtags idheads
6846 global arcstart arcend arcout allparents growing
6849 if {[llength
$a] != 1} {
6850 puts
"oops splitarc called but [llength $a] arcs already"
6854 set i
[lsearch
-exact $arcids($a) $p]
6856 puts
"oops splitarc $p not in arc $a"
6859 set na
[incr nextarc
]
6860 if {[info exists arcend
($a)]} {
6861 set arcend
($na) $arcend($a)
6863 set l
[lindex
$allparents([lindex
$arcids($a) end
]) 0]
6864 set j
[lsearch
-exact $arcnos($l) $a]
6865 set arcnos
($l) [lreplace
$arcnos($l) $j $j $na]
6867 set tail [lrange
$arcids($a) [expr {$i+1}] end
]
6868 set arcids
($a) [lrange
$arcids($a) 0 $i]
6870 set arcstart
($na) $p
6872 set arcids
($na) $tail
6873 if {[info exists growing
($a)]} {
6879 if {[llength
$arcnos($id)] == 1} {
6882 set j
[lsearch
-exact $arcnos($id) $a]
6883 set arcnos
($id) [lreplace
$arcnos($id) $j $j $na]
6887 # reconstruct tags and heads lists
6888 if {$arctags($a) ne
{} ||
$archeads($a) ne
{}} {
6893 set archeads
($na) {}
6897 # Update things for a new commit added that is a child of one
6898 # existing commit. Used when cherry-picking.
6899 proc addnewchild
{id p
} {
6900 global allparents allchildren idtags nextarc
6901 global arcnos arcids arctags arcout arcend arcstart archeads growing
6902 global seeds allcommits
6904 if {![info exists allcommits
] ||
![info exists arcnos
($p)]} return
6905 set allparents
($id) [list
$p]
6906 set allchildren
($id) {}
6909 lappend allchildren
($p) $id
6910 set a
[incr nextarc
]
6911 set arcstart
($a) $id
6914 set arcids
($a) [list
$p]
6916 if {![info exists arcout
($p)]} {
6919 lappend arcnos
($p) $a
6920 set arcout
($id) [list
$a]
6923 # This implements a cache for the topology information.
6924 # The cache saves, for each arc, the start and end of the arc,
6925 # the ids on the arc, and the outgoing arcs from the end.
6926 proc readcache
{f
} {
6927 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6928 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6933 if {$lim - $a > 500} {
6934 set lim
[expr {$a + 500}]
6938 # finish reading the cache and setting up arctags, etc.
6940 if {$line ne
"1"} {error
"bad final version"}
6942 foreach id
[array names idtags
] {
6943 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6944 [llength
$allparents($id)] == 1} {
6945 set a
[lindex
$arcnos($id) 0]
6946 if {$arctags($a) eq
{}} {
6951 foreach id
[array names idheads
] {
6952 if {[info exists arcnos
($id)] && [llength
$arcnos($id)] == 1 &&
6953 [llength
$allparents($id)] == 1} {
6954 set a
[lindex
$arcnos($id) 0]
6955 if {$archeads($a) eq
{}} {
6960 foreach id
[lsort
-unique $possible_seeds] {
6961 if {$arcnos($id) eq
{}} {
6967 while {[incr a
] <= $lim} {
6969 if {[llength
$line] != 3} {error
"bad line"}
6970 set s
[lindex
$line 0]
6972 lappend arcout
($s) $a
6973 if {![info exists arcnos
($s)]} {
6974 lappend possible_seeds
$s
6977 set e
[lindex
$line 1]
6982 if {![info exists arcout
($e)]} {
6986 set arcids
($a) [lindex
$line 2]
6987 foreach id
$arcids($a) {
6988 lappend allparents
($s) $id
6990 lappend arcnos
($id) $a
6992 if {![info exists allparents
($s)]} {
6993 set allparents
($s) {}
6998 set nextarc
[expr {$a - 1}]
7011 global nextarc cachedarcs possible_seeds
7015 if {[llength
$line] != 2 ||
[lindex
$line 0] ne
"1"} {error
"bad version"}
7016 # make sure it's an integer
7017 set cachedarcs
[expr {int
([lindex
$line 1])}]
7018 if {$cachedarcs < 0} {error
"bad number of arcs"}
7020 set possible_seeds
{}
7028 proc dropcache
{err
} {
7029 global allcwait nextarc cachedarcs seeds
7031 #puts "dropping cache ($err)"
7032 foreach v
{arcnos arcout arcids arcstart arcend growing \
7033 arctags archeads allparents allchildren
} {
7044 proc writecache
{f
} {
7045 global cachearc cachedarcs allccache
7046 global arcstart arcend arcnos arcids arcout
7050 if {$lim - $a > 1000} {
7051 set lim
[expr {$a + 1000}]
7054 while {[incr a
] <= $lim} {
7055 if {[info exists arcend
($a)]} {
7056 puts
$f [list
$arcstart($a) $arcend($a) $arcids($a)]
7058 puts
$f [list
$arcstart($a) {} $arcids($a)]
7063 catch
{file delete
$allccache}
7064 #puts "writing cache failed ($err)"
7067 set cachearc
[expr {$a - 1}]
7068 if {$a > $cachedarcs} {
7077 global nextarc cachedarcs cachearc allccache
7079 if {$nextarc == $cachedarcs} return
7081 set cachedarcs
$nextarc
7083 set f
[open
$allccache w
]
7084 puts
$f [list
1 $cachedarcs]
7089 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7090 # or 0 if neither is true.
7091 proc anc_or_desc
{a b
} {
7092 global arcout arcstart arcend arcnos cached_isanc
7094 if {$arcnos($a) eq
$arcnos($b)} {
7095 # Both are on the same arc(s); either both are the same BMP,
7096 # or if one is not a BMP, the other is also not a BMP or is
7097 # the BMP at end of the arc (and it only has 1 incoming arc).
7098 # Or both can be BMPs with no incoming arcs.
7099 if {$a eq
$b ||
$arcnos($a) eq
{}} {
7102 # assert {[llength $arcnos($a)] == 1}
7103 set arc
[lindex
$arcnos($a) 0]
7104 set i
[lsearch
-exact $arcids($arc) $a]
7105 set j
[lsearch
-exact $arcids($arc) $b]
7106 if {$i < 0 ||
$i > $j} {
7113 if {![info exists arcout
($a)]} {
7114 set arc
[lindex
$arcnos($a) 0]
7115 if {[info exists arcend
($arc)]} {
7116 set aend
$arcend($arc)
7120 set a
$arcstart($arc)
7124 if {![info exists arcout
($b)]} {
7125 set arc
[lindex
$arcnos($b) 0]
7126 if {[info exists arcend
($arc)]} {
7127 set bend
$arcend($arc)
7131 set b
$arcstart($arc)
7141 if {[info exists cached_isanc
($a,$bend)]} {
7142 if {$cached_isanc($a,$bend)} {
7146 if {[info exists cached_isanc
($b,$aend)]} {
7147 if {$cached_isanc($b,$aend)} {
7150 if {[info exists cached_isanc
($a,$bend)]} {
7155 set todo
[list
$a $b]
7158 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7159 set x
[lindex
$todo $i]
7160 if {$anc($x) eq
{}} {
7163 foreach arc
$arcnos($x) {
7164 set xd
$arcstart($arc)
7166 set cached_isanc
($a,$bend) 1
7167 set cached_isanc
($b,$aend) 0
7169 } elseif
{$xd eq
$aend} {
7170 set cached_isanc
($b,$aend) 1
7171 set cached_isanc
($a,$bend) 0
7174 if {![info exists anc
($xd)]} {
7175 set anc
($xd) $anc($x)
7177 } elseif
{$anc($xd) ne
$anc($x)} {
7182 set cached_isanc
($a,$bend) 0
7183 set cached_isanc
($b,$aend) 0
7187 # This identifies whether $desc has an ancestor that is
7188 # a growing tip of the graph and which is not an ancestor of $anc
7189 # and returns 0 if so and 1 if not.
7190 # If we subsequently discover a tag on such a growing tip, and that
7191 # turns out to be a descendent of $anc (which it could, since we
7192 # don't necessarily see children before parents), then $desc
7193 # isn't a good choice to display as a descendent tag of
7194 # $anc (since it is the descendent of another tag which is
7195 # a descendent of $anc). Similarly, $anc isn't a good choice to
7196 # display as a ancestor tag of $desc.
7198 proc is_certain
{desc anc
} {
7199 global arcnos arcout arcstart arcend growing problems
7202 if {[llength
$arcnos($anc)] == 1} {
7203 # tags on the same arc are certain
7204 if {$arcnos($desc) eq
$arcnos($anc)} {
7207 if {![info exists arcout
($anc)]} {
7208 # if $anc is partway along an arc, use the start of the arc instead
7209 set a
[lindex
$arcnos($anc) 0]
7210 set anc
$arcstart($a)
7213 if {[llength
$arcnos($desc)] > 1 ||
[info exists arcout
($desc)]} {
7216 set a
[lindex
$arcnos($desc) 0]
7222 set anclist
[list
$x]
7226 for {set i
0} {$i < [llength
$anclist] && ($nnh > 0 ||
$ngrowanc > 0)} {incr i
} {
7227 set x
[lindex
$anclist $i]
7232 foreach a
$arcout($x) {
7233 if {[info exists growing
($a)]} {
7234 if {![info exists growanc
($x)] && $dl($x)} {
7240 if {[info exists dl
($y)]} {
7244 if {![info exists
done($y)]} {
7247 if {[info exists growanc
($x)]} {
7251 for {set k
0} {$k < [llength
$xl]} {incr k
} {
7252 set z
[lindex
$xl $k]
7253 foreach c
$arcout($z) {
7254 if {[info exists arcend
($c)]} {
7256 if {[info exists dl
($v)] && $dl($v)} {
7258 if {![info exists
done($v)]} {
7261 if {[info exists growanc
($v)]} {
7271 } elseif
{$y eq
$anc ||
!$dl($x)} {
7282 foreach x
[array names growanc
] {
7291 proc validate_arctags
{a
} {
7292 global arctags idtags
7296 foreach id
$arctags($a) {
7298 if {![info exists idtags
($id)]} {
7299 set na
[lreplace
$na $i $i]
7306 proc validate_archeads
{a
} {
7307 global archeads idheads
7310 set na
$archeads($a)
7311 foreach id
$archeads($a) {
7313 if {![info exists idheads
($id)]} {
7314 set na
[lreplace
$na $i $i]
7318 set archeads
($a) $na
7321 # Return the list of IDs that have tags that are descendents of id,
7322 # ignoring IDs that are descendents of IDs already reported.
7323 proc desctags
{id
} {
7324 global arcnos arcstart arcids arctags idtags allparents
7325 global growing cached_dtags
7327 if {![info exists allparents
($id)]} {
7330 set t1
[clock clicks
-milliseconds]
7332 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7333 # part-way along an arc; check that arc first
7334 set a
[lindex
$arcnos($id) 0]
7335 if {$arctags($a) ne
{}} {
7337 set i
[lsearch
-exact $arcids($a) $id]
7339 foreach t
$arctags($a) {
7340 set j
[lsearch
-exact $arcids($a) $t]
7348 set id
$arcstart($a)
7349 if {[info exists idtags
($id)]} {
7353 if {[info exists cached_dtags
($id)]} {
7354 return $cached_dtags($id)
7361 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7362 set id
[lindex
$todo $i]
7364 set ta
[info exists hastaggedancestor
($id)]
7368 # ignore tags on starting node
7369 if {!$ta && $i > 0} {
7370 if {[info exists idtags
($id)]} {
7373 } elseif
{[info exists cached_dtags
($id)]} {
7374 set tagloc
($id) $cached_dtags($id)
7378 foreach a
$arcnos($id) {
7380 if {!$ta && $arctags($a) ne
{}} {
7382 if {$arctags($a) ne
{}} {
7383 lappend tagloc
($id) [lindex
$arctags($a) end
]
7386 if {$ta ||
$arctags($a) ne
{}} {
7387 set tomark
[list
$d]
7388 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7389 set dd [lindex
$tomark $j]
7390 if {![info exists hastaggedancestor
($dd)]} {
7391 if {[info exists
done($dd)]} {
7392 foreach b
$arcnos($dd) {
7393 lappend tomark
$arcstart($b)
7395 if {[info exists tagloc
($dd)]} {
7398 } elseif
{[info exists queued
($dd)]} {
7401 set hastaggedancestor
($dd) 1
7405 if {![info exists queued
($d)]} {
7408 if {![info exists hastaggedancestor
($d)]} {
7415 foreach id
[array names tagloc
] {
7416 if {![info exists hastaggedancestor
($id)]} {
7417 foreach t
$tagloc($id) {
7418 if {[lsearch
-exact $tags $t] < 0} {
7424 set t2
[clock clicks
-milliseconds]
7427 # remove tags that are descendents of other tags
7428 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7429 set a
[lindex
$tags $i]
7430 for {set j
0} {$j < $i} {incr j
} {
7431 set b
[lindex
$tags $j]
7432 set r
[anc_or_desc
$a $b]
7434 set tags
[lreplace
$tags $j $j]
7437 } elseif
{$r == -1} {
7438 set tags
[lreplace
$tags $i $i]
7445 if {[array names growing
] ne
{}} {
7446 # graph isn't finished, need to check if any tag could get
7447 # eclipsed by another tag coming later. Simply ignore any
7448 # tags that could later get eclipsed.
7451 if {[is_certain
$t $origid]} {
7455 if {$tags eq
$ctags} {
7456 set cached_dtags
($origid) $tags
7461 set cached_dtags
($origid) $tags
7463 set t3
[clock clicks
-milliseconds]
7464 if {0 && $t3 - $t1 >= 100} {
7465 puts
"iterating descendents ($loopix/[llength $todo] nodes) took\
7466 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7472 global arcnos arcids arcout arcend arctags idtags allparents
7473 global growing cached_atags
7475 if {![info exists allparents
($id)]} {
7478 set t1
[clock clicks
-milliseconds]
7480 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7481 # part-way along an arc; check that arc first
7482 set a
[lindex
$arcnos($id) 0]
7483 if {$arctags($a) ne
{}} {
7485 set i
[lsearch
-exact $arcids($a) $id]
7486 foreach t
$arctags($a) {
7487 set j
[lsearch
-exact $arcids($a) $t]
7493 if {![info exists arcend
($a)]} {
7497 if {[info exists idtags
($id)]} {
7501 if {[info exists cached_atags
($id)]} {
7502 return $cached_atags($id)
7510 for {set i
0} {$i < [llength
$todo] && $nc > 0} {incr i
} {
7511 set id
[lindex
$todo $i]
7513 set td
[info exists hastaggeddescendent
($id)]
7517 # ignore tags on starting node
7518 if {!$td && $i > 0} {
7519 if {[info exists idtags
($id)]} {
7522 } elseif
{[info exists cached_atags
($id)]} {
7523 set tagloc
($id) $cached_atags($id)
7527 foreach a
$arcout($id) {
7528 if {!$td && $arctags($a) ne
{}} {
7530 if {$arctags($a) ne
{}} {
7531 lappend tagloc
($id) [lindex
$arctags($a) 0]
7534 if {![info exists arcend
($a)]} continue
7536 if {$td ||
$arctags($a) ne
{}} {
7537 set tomark
[list
$d]
7538 for {set j
0} {$j < [llength
$tomark]} {incr j
} {
7539 set dd [lindex
$tomark $j]
7540 if {![info exists hastaggeddescendent
($dd)]} {
7541 if {[info exists
done($dd)]} {
7542 foreach b
$arcout($dd) {
7543 if {[info exists arcend
($b)]} {
7544 lappend tomark
$arcend($b)
7547 if {[info exists tagloc
($dd)]} {
7550 } elseif
{[info exists queued
($dd)]} {
7553 set hastaggeddescendent
($dd) 1
7557 if {![info exists queued
($d)]} {
7560 if {![info exists hastaggeddescendent
($d)]} {
7566 set t2
[clock clicks
-milliseconds]
7569 foreach id
[array names tagloc
] {
7570 if {![info exists hastaggeddescendent
($id)]} {
7571 foreach t
$tagloc($id) {
7572 if {[lsearch
-exact $tags $t] < 0} {
7579 # remove tags that are ancestors of other tags
7580 for {set i
0} {$i < [llength
$tags]} {incr i
} {
7581 set a
[lindex
$tags $i]
7582 for {set j
0} {$j < $i} {incr j
} {
7583 set b
[lindex
$tags $j]
7584 set r
[anc_or_desc
$a $b]
7586 set tags
[lreplace
$tags $j $j]
7589 } elseif
{$r == 1} {
7590 set tags
[lreplace
$tags $i $i]
7597 if {[array names growing
] ne
{}} {
7598 # graph isn't finished, need to check if any tag could get
7599 # eclipsed by another tag coming later. Simply ignore any
7600 # tags that could later get eclipsed.
7603 if {[is_certain
$origid $t]} {
7607 if {$tags eq
$ctags} {
7608 set cached_atags
($origid) $tags
7613 set cached_atags
($origid) $tags
7615 set t3
[clock clicks
-milliseconds]
7616 if {0 && $t3 - $t1 >= 100} {
7617 puts
"iterating ancestors ($loopix/[llength $todo] nodes) took\
7618 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7623 # Return the list of IDs that have heads that are descendents of id,
7624 # including id itself if it has a head.
7625 proc descheads
{id
} {
7626 global arcnos arcstart arcids archeads idheads cached_dheads
7629 if {![info exists allparents
($id)]} {
7633 if {[llength
$arcnos($id)] == 1 && [llength
$allparents($id)] == 1} {
7634 # part-way along an arc; check it first
7635 set a
[lindex
$arcnos($id) 0]
7636 if {$archeads($a) ne
{}} {
7637 validate_archeads
$a
7638 set i
[lsearch
-exact $arcids($a) $id]
7639 foreach t
$archeads($a) {
7640 set j
[lsearch
-exact $arcids($a) $t]
7645 set id
$arcstart($a)
7651 for {set i
0} {$i < [llength
$todo]} {incr i
} {
7652 set id
[lindex
$todo $i]
7653 if {[info exists cached_dheads
($id)]} {
7654 set ret
[concat
$ret $cached_dheads($id)]
7656 if {[info exists idheads
($id)]} {
7659 foreach a
$arcnos($id) {
7660 if {$archeads($a) ne
{}} {
7661 validate_archeads
$a
7662 if {$archeads($a) ne
{}} {
7663 set ret
[concat
$ret $archeads($a)]
7667 if {![info exists seen
($d)]} {
7674 set ret
[lsort
-unique $ret]
7675 set cached_dheads
($origid) $ret
7676 return [concat
$ret $aret]
7679 proc addedtag
{id
} {
7680 global arcnos arcout cached_dtags cached_atags
7682 if {![info exists arcnos
($id)]} return
7683 if {![info exists arcout
($id)]} {
7684 recalcarc
[lindex
$arcnos($id) 0]
7686 catch
{unset cached_dtags
}
7687 catch
{unset cached_atags
}
7690 proc addedhead
{hid
head} {
7691 global arcnos arcout cached_dheads
7693 if {![info exists arcnos
($hid)]} return
7694 if {![info exists arcout
($hid)]} {
7695 recalcarc
[lindex
$arcnos($hid) 0]
7697 catch
{unset cached_dheads
}
7700 proc removedhead
{hid
head} {
7701 global cached_dheads
7703 catch
{unset cached_dheads
}
7706 proc movedhead
{hid
head} {
7707 global arcnos arcout cached_dheads
7709 if {![info exists arcnos
($hid)]} return
7710 if {![info exists arcout
($hid)]} {
7711 recalcarc
[lindex
$arcnos($hid) 0]
7713 catch
{unset cached_dheads
}
7716 proc changedrefs
{} {
7717 global cached_dheads cached_dtags cached_atags
7718 global arctags archeads arcnos arcout idheads idtags
7720 foreach id
[concat
[array names idheads
] [array names idtags
]] {
7721 if {[info exists arcnos
($id)] && ![info exists arcout
($id)]} {
7722 set a
[lindex
$arcnos($id) 0]
7723 if {![info exists donearc
($a)]} {
7729 catch
{unset cached_dtags
}
7730 catch
{unset cached_atags
}
7731 catch
{unset cached_dheads
}
7734 proc rereadrefs
{} {
7735 global idtags idheads idotherrefs mainhead
7737 set refids
[concat
[array names idtags
] \
7738 [array names idheads
] [array names idotherrefs
]]
7739 foreach id
$refids {
7740 if {![info exists ref
($id)]} {
7741 set ref
($id) [listrefs
$id]
7744 set oldmainhead
$mainhead
7747 set refids
[lsort
-unique [concat
$refids [array names idtags
] \
7748 [array names idheads
] [array names idotherrefs
]]]
7749 foreach id
$refids {
7750 set v
[listrefs
$id]
7751 if {![info exists ref
($id)] ||
$ref($id) != $v ||
7752 ($id eq
$oldmainhead && $id ne
$mainhead) ||
7753 ($id eq
$mainhead && $id ne
$oldmainhead)} {
7760 proc listrefs
{id
} {
7761 global idtags idheads idotherrefs
7764 if {[info exists idtags
($id)]} {
7768 if {[info exists idheads
($id)]} {
7772 if {[info exists idotherrefs
($id)]} {
7773 set z
$idotherrefs($id)
7775 return [list
$x $y $z]
7778 proc showtag
{tag isnew
} {
7779 global ctext tagcontents tagids linknum tagobjid
7782 addtohistory
[list showtag
$tag 0]
7784 $ctext conf
-state normal
7788 if {![info exists tagcontents
($tag)]} {
7790 set tagcontents
($tag) [exec git cat-file tag
$tagobjid($tag)]
7793 if {[info exists tagcontents
($tag)]} {
7794 set text
$tagcontents($tag)
7796 set text
"[mc "Tag
"]: $tag\n[mc "Id
"]: $tagids($tag)"
7798 appendwithlinks
$text {}
7799 $ctext conf
-state disabled
7810 proc mkfontdisp
{font top
which} {
7811 global fontattr fontpref
$font
7813 set fontpref
($font) [set $font]
7814 button
$top.
${font}but
-text $which -font optionfont \
7815 -command [list choosefont
$font $which]
7816 label
$top.
$font -relief flat
-font $font \
7817 -text $fontattr($font,family
) -justify left
7818 grid x
$top.
${font}but
$top.
$font -sticky w
7821 proc choosefont
{font
which} {
7822 global fontparam fontlist fonttop fontattr
7824 set fontparam
(which) $which
7825 set fontparam
(font
) $font
7826 set fontparam
(family
) [font actual
$font -family]
7827 set fontparam
(size
) $fontattr($font,size
)
7828 set fontparam
(weight
) $fontattr($font,weight
)
7829 set fontparam
(slant
) $fontattr($font,slant
)
7832 if {![winfo exists
$top]} {
7834 eval font config sample
[font actual
$font]
7836 wm title
$top [mc
"Gitk font chooser"]
7837 label
$top.l
-textvariable fontparam
(which)
7838 pack
$top.l
-side top
7839 set fontlist
[lsort
[font families
]]
7841 listbox
$top.f.fam
-listvariable fontlist \
7842 -yscrollcommand [list
$top.f.sb
set]
7843 bind $top.f.fam
<<ListboxSelect>> selfontfam
7844 scrollbar $top.f.sb -command [list $top.f.fam yview]
7845 pack $top.f.sb -side right -fill y
7846 pack $top.f.fam -side left -fill both -expand 1
7847 pack $top.f -side top -fill both -expand 1
7849 spinbox $top.g.size -from 4 -to 40 -width 4 \
7850 -textvariable fontparam(size) \
7851 -validatecommand {string is integer -strict %s}
7852 checkbutton $top.g.bold -padx 5 \
7853 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7854 -variable fontparam(weight) -onvalue bold -offvalue normal
7855 checkbutton $top.g.ital -padx 5 \
7856 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7857 -variable fontparam(slant) -onvalue italic -offvalue roman
7858 pack $top.g.size $top.g.bold $top.g.ital -side left
7859 pack $top.g -side top
7860 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7862 $top.c create text 100 25 -anchor center -text $which -font sample \
7863 -fill black -tags text
7864 bind $top.c <Configure> [list centertext $top.c]
7865 pack $top.c -side top -fill x
7867 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7868 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7869 grid $top.buts.ok $top.buts.can
7870 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7871 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7872 pack $top.buts -side bottom -fill x
7873 trace add variable fontparam write chg_fontparam
7876 $top.c itemconf text -text $which
7878 set i [lsearch -exact $fontlist $fontparam(family)]
7880 $top.f.fam selection set $i
7885 proc centertext {w} {
7886 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7890 global fontparam fontpref prefstop
7892 set f $fontparam(font)
7893 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7894 if {$fontparam(weight) eq "bold"} {
7895 lappend fontpref($f) "bold"
7897 if {$fontparam(slant) eq "italic"} {
7898 lappend fontpref($f) "italic"
7901 $w conf -text $fontparam(family) -font $fontpref($f)
7907 global fonttop fontparam
7909 if {[info exists fonttop]} {
7910 catch {destroy $fonttop}
7911 catch {font delete sample}
7917 proc selfontfam {} {
7918 global fonttop fontparam
7920 set i [$fonttop.f.fam curselection]
7922 set fontparam(family) [$fonttop.f.fam get $i]
7926 proc chg_fontparam {v sub op} {
7929 font config sample -$sub $fontparam($sub)
7933 global maxwidth maxgraphpct
7934 global oldprefs prefstop showneartags showlocalchanges
7935 global bgcolor fgcolor ctext diffcolors selectbgcolor
7936 global tabstop limitdiffs
7940 if {[winfo exists $top]} {
7944 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7945 limitdiffs tabstop} {
7946 set oldprefs($v) [set $v]
7949 wm title $top [mc "Gitk preferences"]
7950 label $top.ldisp -text [mc "Commit list display options"]
7951 grid $top.ldisp - -sticky w -pady 10
7952 label $top.spacer -text " "
7953 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
7955 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7956 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7957 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
7959 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7960 grid x $top.maxpctl $top.maxpct -sticky w
7961 frame $top.showlocal
7962 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
7963 checkbutton $top.showlocal.b -variable showlocalchanges
7964 pack $top.showlocal.b $top.showlocal.l -side left
7965 grid x $top.showlocal -sticky w
7967 label $top.ddisp -text [mc "Diff display options"]
7968 grid $top.ddisp - -sticky w -pady 10
7969 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
7970 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7971 grid x $top.tabstopl $top.tabstop -sticky w
7973 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
7974 checkbutton $top.ntag.b -variable showneartags
7975 pack $top.ntag.b $top.ntag.l -side left
7976 grid x $top.ntag -sticky w
7978 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
7979 checkbutton $top.ldiff.b -variable limitdiffs
7980 pack $top.ldiff.b $top.ldiff.l -side left
7981 grid x $top.ldiff -sticky w
7983 label $top.cdisp -text [mc "Colors: press to choose"]
7984 grid $top.cdisp - -sticky w -pady 10
7985 label $top.bg -padx 40 -relief sunk -background $bgcolor
7986 button $top.bgbut -text [mc "Background"] -font optionfont \
7987 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7988 grid x $top.bgbut $top.bg -sticky w
7989 label $top.fg -padx 40 -relief sunk -background $fgcolor
7990 button $top.fgbut -text [mc "Foreground"] -font optionfont \
7991 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7992 grid x $top.fgbut $top.fg -sticky w
7993 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7994 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
7995 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7996 [list $ctext tag conf d0 -foreground]]
7997 grid x $top.diffoldbut $top.diffold -sticky w
7998 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7999 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8000 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8001 [list $ctext tag conf d1 -foreground]]
8002 grid x $top.diffnewbut $top.diffnew -sticky w
8003 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8004 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8005 -command [list choosecolor diffcolors 2 $top.hunksep \
8006 "diff hunk header" \
8007 [list $ctext tag conf hunksep -foreground]]
8008 grid x $top.hunksepbut $top.hunksep -sticky w
8009 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8010 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8011 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8012 grid x $top.selbgbut $top.selbgsep -sticky w
8014 label $top.cfont -text [mc "Fonts: press to choose"]
8015 grid $top.cfont - -sticky w -pady 10
8016 mkfontdisp mainfont $top [mc "Main font"]
8017 mkfontdisp textfont $top [mc "Diff display font"]
8018 mkfontdisp uifont $top [mc "User interface font"]
8021 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8022 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8023 grid $top.buts.ok $top.buts.can
8024 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8025 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8026 grid $top.buts - - -pady 10 -sticky ew
8027 bind $top <Visibility> "focus $top.buts.ok"
8030 proc choosecolor {v vi w x cmd} {
8033 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8034 -title [mc "Gitk: choose color for %s" $x]]
8035 if {$c eq {}} return
8036 $w conf -background $c
8042 global bglist cflist
8044 $w configure -selectbackground $c
8046 $cflist tag configure highlight \
8047 -background [$cflist cget -selectbackground]
8048 allcanvs itemconf secsel -fill $c
8055 $w conf -background $c
8063 $w conf -foreground $c
8065 allcanvs itemconf text -fill $c
8066 $canv itemconf circle -outline $c
8070 global oldprefs prefstop
8072 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8073 limitdiffs tabstop} {
8075 set $v $oldprefs($v)
8077 catch {destroy $prefstop}
8083 global maxwidth maxgraphpct
8084 global oldprefs prefstop showneartags showlocalchanges
8085 global fontpref mainfont textfont uifont
8086 global limitdiffs treediffs
8088 catch {destroy $prefstop}
8092 if {$mainfont ne $fontpref(mainfont)} {
8093 set mainfont $fontpref(mainfont)
8094 parsefont mainfont $mainfont
8095 eval font configure mainfont [fontflags mainfont]
8096 eval font configure mainfontbold [fontflags mainfont 1]
8100 if {$textfont ne $fontpref(textfont)} {
8101 set textfont $fontpref(textfont)
8102 parsefont textfont $textfont
8103 eval font configure textfont [fontflags textfont]
8104 eval font configure textfontbold [fontflags textfont 1]
8106 if {$uifont ne $fontpref(uifont)} {
8107 set uifont $fontpref(uifont)
8108 parsefont uifont $uifont
8109 eval font configure uifont [fontflags uifont]
8112 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8113 if {$showlocalchanges} {
8119 if {$limitdiffs != $oldprefs(limitdiffs)} {
8120 # treediffs elements are limited by path
8121 catch {unset treediffs}
8123 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8124 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8126 } elseif {$showneartags != $oldprefs(showneartags) ||
8127 $limitdiffs != $oldprefs(limitdiffs)} {
8132 proc formatdate {d} {
8133 global datetimeformat
8135 set d [clock format $d -format $datetimeformat]
8140 # This list of encoding names and aliases is distilled from
8141 # http://www.iana.org/assignments/character-sets.
8142 # Not all of them are supported by Tcl.
8143 set encoding_aliases {
8144 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8145 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8146 { ISO-10646-UTF-1 csISO10646UTF1 }
8147 { ISO_646.basic:1983 ref csISO646basic1983 }
8148 { INVARIANT csINVARIANT }
8149 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8150 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8151 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8152 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8153 { NATS-DANO iso-ir-9-1 csNATSDANO }
8154 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8155 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8156 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8157 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8158 { ISO-2022-KR csISO2022KR }
8160 { ISO-2022-JP csISO2022JP }
8161 { ISO-2022-JP-2 csISO2022JP2 }
8162 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8164 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8165 { IT iso-ir-15 ISO646-IT csISO15Italian }
8166 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8167 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8168 { greek7-old iso-ir-18 csISO18Greek7Old }
8169 { latin-greek iso-ir-19 csISO19LatinGreek }
8170 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8171 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8172 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8173 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8174 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8175 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8176 { INIS iso-ir-49 csISO49INIS }
8177 { INIS-8 iso-ir-50 csISO50INIS8 }
8178 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8179 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8180 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8181 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8182 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8183 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8185 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8186 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8187 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8188 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8189 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8190 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8191 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8192 { greek7 iso-ir-88 csISO88Greek7 }
8193 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8194 { iso-ir-90 csISO90 }
8195 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8196 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8197 csISO92JISC62991984b }
8198 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8199 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8200 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8201 csISO95JIS62291984handadd }
8202 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8203 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8204 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8205 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8207 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8208 { T.61-7bit iso-ir-102 csISO102T617bit }
8209 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8210 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8211 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8212 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8213 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8214 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8215 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8216 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8217 arabic csISOLatinArabic }
8218 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8219 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8220 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8221 greek greek8 csISOLatinGreek }
8222 { T.101-G2 iso-ir-128 csISO128T101G2 }
8223 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8225 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8226 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8227 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8228 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8229 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8230 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8231 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8232 csISOLatinCyrillic }
8233 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8234 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8235 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8236 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8237 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8238 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8239 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8240 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8241 { ISO_10367-box iso-ir-155 csISO10367Box }
8242 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8243 { latin-lap lap iso-ir-158 csISO158Lap }
8244 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8245 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8248 { JIS_X0201 X0201 csHalfWidthKatakana }
8249 { KSC5636 ISO646-KR csKSC5636 }
8250 { ISO-10646-UCS-2 csUnicode }
8251 { ISO-10646-UCS-4 csUCS4 }
8252 { DEC-MCS dec csDECMCS }
8253 { hp-roman8 roman8 r8 csHPRoman8 }
8254 { macintosh mac csMacintosh }
8255 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8257 { IBM038 EBCDIC-INT cp038 csIBM038 }
8258 { IBM273 CP273 csIBM273 }
8259 { IBM274 EBCDIC-BE CP274 csIBM274 }
8260 { IBM275 EBCDIC-BR cp275 csIBM275 }
8261 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8262 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8263 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8264 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8265 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8266 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8267 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8268 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8269 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8270 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8271 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8272 { IBM437 cp437 437 csPC8CodePage437 }
8273 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8274 { IBM775 cp775 csPC775Baltic }
8275 { IBM850 cp850 850 csPC850Multilingual }
8276 { IBM851 cp851 851 csIBM851 }
8277 { IBM852 cp852 852 csPCp852 }
8278 { IBM855 cp855 855 csIBM855 }
8279 { IBM857 cp857 857 csIBM857 }
8280 { IBM860 cp860 860 csIBM860 }
8281 { IBM861 cp861 861 cp-is csIBM861 }
8282 { IBM862 cp862 862 csPC862LatinHebrew }
8283 { IBM863 cp863 863 csIBM863 }
8284 { IBM864 cp864 csIBM864 }
8285 { IBM865 cp865 865 csIBM865 }
8286 { IBM866 cp866 866 csIBM866 }
8287 { IBM868 CP868 cp-ar csIBM868 }
8288 { IBM869 cp869 869 cp-gr csIBM869 }
8289 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8290 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8291 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8292 { IBM891 cp891 csIBM891 }
8293 { IBM903 cp903 csIBM903 }
8294 { IBM904 cp904 904 csIBBM904 }
8295 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8296 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8297 { IBM1026 CP1026 csIBM1026 }
8298 { EBCDIC-AT-DE csIBMEBCDICATDE }
8299 { EBCDIC-AT-DE-A csEBCDICATDEA }
8300 { EBCDIC-CA-FR csEBCDICCAFR }
8301 { EBCDIC-DK-NO csEBCDICDKNO }
8302 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8303 { EBCDIC-FI-SE csEBCDICFISE }
8304 { EBCDIC-FI-SE-A csEBCDICFISEA }
8305 { EBCDIC-FR csEBCDICFR }
8306 { EBCDIC-IT csEBCDICIT }
8307 { EBCDIC-PT csEBCDICPT }
8308 { EBCDIC-ES csEBCDICES }
8309 { EBCDIC-ES-A csEBCDICESA }
8310 { EBCDIC-ES-S csEBCDICESS }
8311 { EBCDIC-UK csEBCDICUK }
8312 { EBCDIC-US csEBCDICUS }
8313 { UNKNOWN-8BIT csUnknown8BiT }
8314 { MNEMONIC csMnemonic }
8319 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8320 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8321 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8322 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8323 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8324 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8325 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8326 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8327 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8328 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8329 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8330 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8331 { IBM1047 IBM-1047 }
8332 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8333 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8334 { UNICODE-1-1 csUnicode11 }
8337 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8338 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8340 { ISO-8859-15 ISO_8859-15 Latin-9 }
8341 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8342 { GBK CP936 MS936 windows-936 }
8343 { JIS_Encoding csJISEncoding }
8344 { Shift_JIS MS_Kanji csShiftJIS }
8345 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8347 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8348 { ISO-10646-UCS-Basic csUnicodeASCII }
8349 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8350 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8351 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8352 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8353 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8354 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8355 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8356 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8357 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8358 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8359 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8360 { Ventura-US csVenturaUS }
8361 { Ventura-International csVenturaInternational }
8362 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8363 { PC8-Turkish csPC8Turkish }
8364 { IBM-Symbols csIBMSymbols }
8365 { IBM-Thai csIBMThai }
8366 { HP-Legal csHPLegal }
8367 { HP-Pi-font csHPPiFont }
8368 { HP-Math8 csHPMath8 }
8369 { Adobe-Symbol-Encoding csHPPSMath }
8370 { HP-DeskTop csHPDesktop }
8371 { Ventura-Math csVenturaMath }
8372 { Microsoft-Publishing csMicrosoftPublishing }
8373 { Windows-31J csWindows31J }
8378 proc tcl_encoding {enc} {
8379 global encoding_aliases
8380 set names [encoding names]
8381 set lcnames [string tolower $names]
8382 set enc [string tolower $enc]
8383 set i [lsearch -exact $lcnames $enc]
8385 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8386 if {[regsub {^iso[-_]} $enc iso encx]} {
8387 set i [lsearch -exact $lcnames $encx]
8391 foreach l $encoding_aliases {
8392 set ll [string tolower $l]
8393 if {[lsearch -exact $ll $enc] < 0} continue
8394 # look through the aliases for one that tcl knows about
8396 set i [lsearch -exact $lcnames $e]
8398 if {[regsub {^iso[-_]} $e iso ex]} {
8399 set i [lsearch -exact $lcnames $ex]
8408 return [lindex $names $i]
8413 # First check that Tcl/Tk is recent enough
8414 if {[catch {package require Tk 8.4} err]} {
8415 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8416 Gitk requires at least Tcl/Tk 8.4."]
8422 set wrcomcmd "git diff-tree --stdin -p --pretty"
8426 set gitencoding [exec git config --get i18n.commitencoding]
8428 if {$gitencoding == ""} {
8429 set gitencoding "utf-8"
8431 set tclencoding [tcl_encoding $gitencoding]
8432 if {$tclencoding == {}} {
8433 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8436 set mainfont {Helvetica 9}
8437 set textfont {Courier 9}
8438 set uifont {Helvetica 9 bold}
8440 set findmergefiles 0
8448 set cmitmode "patch"
8449 set wrapcomment "none"
8453 set showlocalchanges 1
8455 set datetimeformat "%Y-%m-%d %H:%M:%S"
8457 set colors {green red blue magenta darkgrey brown orange}
8460 set diffcolors {red "#00a000" blue}
8462 set selectbgcolor gray85
8464 ## For msgcat loading, first locate the installation location.
8465 if { [info exists ::env(GITK_MSGSDIR)] } {
8466 ## Msgsdir was manually set in the environment.
8467 set gitk_msgsdir $::env(GITK_MSGSDIR)
8469 ## Let's guess the prefix from argv0.
8470 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8471 set gitk_libdir [file join $gitk_prefix share gitk lib]
8472 set gitk_msgsdir [file join $gitk_libdir msgs]
8476 ## Internationalization (i18n) through msgcat and gettext. See
8477 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8478 package require msgcat
8479 namespace import ::msgcat::mc
8480 ## And eventually load the actual message catalog
8481 ::msgcat::mcload $gitk_msgsdir
8483 catch {source ~/.gitk}
8485 font create optionfont -family sans-serif -size -12
8487 parsefont mainfont $mainfont
8488 eval font create mainfont [fontflags mainfont]
8489 eval font create mainfontbold [fontflags mainfont 1]
8491 parsefont textfont $textfont
8492 eval font create textfont [fontflags textfont]
8493 eval font create textfontbold [fontflags textfont 1]
8495 parsefont uifont $uifont
8496 eval font create uifont [fontflags uifont]
8500 # check that we can find a .git directory somewhere...
8501 if {[catch {set gitdir [gitdir]}]} {
8502 show_error {} . [mc "Cannot find a git repository here."]
8505 if {![file isdirectory $gitdir]} {
8506 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8512 set cmdline_files {}
8517 "-d" { set datemode 1 }
8520 lappend revtreeargs $arg
8523 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8527 lappend revtreeargs $arg
8533 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8534 # no -- on command line, but some arguments (other than -d)
8536 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8537 set cmdline_files [split $f "\n"]
8538 set n [llength $cmdline_files]
8539 set revtreeargs [lrange $revtreeargs 0 end-$n]
8540 # Unfortunately git rev-parse doesn't produce an error when
8541 # something is both a revision and a filename. To be consistent
8542 # with git log and git rev-list, check revtreeargs for filenames.
8543 foreach arg $revtreeargs {
8544 if {[file exists $arg]} {
8545 show_error {} . [mc "Ambiguous argument '%s': both revision\
8551 # unfortunately we get both stdout and stderr in $err,
8552 # so look for "fatal:".
8553 set i [string first "fatal:" $err]
8555 set err [string range $err [expr {$i + 6}] end]
8557 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8563 # find the list of unmerged files
8567 set fd [open "| git ls-files -u" r]
8569 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8572 while {[gets $fd line] >= 0} {
8573 set i [string first "\t" $line]
8574 if {$i < 0} continue
8575 set fname [string range $line [expr {$i+1}] end]
8576 if {[lsearch -exact $mlist $fname] >= 0} continue
8578 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8579 lappend mlist $fname
8584 if {$nr_unmerged == 0} {
8585 show_error {} . [mc "No files selected: --merge specified but\
8586 no files are unmerged."]
8588 show_error {} . [mc "No files selected: --merge specified but\
8589 no unmerged files are within file limit."]
8593 set cmdline_files $mlist
8596 set nullid "0000000000000000000000000000000000000000"
8597 set nullid2 "0000000000000000000000000000000000000001"
8599 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8606 set highlight_paths {}
8608 set searchdirn -forwards
8612 set markingmatches 0
8613 set linkentercount 0
8614 set need_redisplay 0
8621 set selectedhlview [mc "None"]
8622 set highlight_related [mc "None"]
8623 set highlight_files {}
8637 # wait for the window to become visible
8639 wm title . "[file tail $argv0]: [file tail [pwd]]"
8642 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8643 # create a view for the files/dirs specified on the command line
8647 set viewname(1) [mc "Command line"]
8648 set viewfiles(1) $cmdline_files
8649 set viewargs(1) $revtreeargs
8652 .bar.view entryconf [mc "Edit view..."] -state normal
8653 .bar.view entryconf [mc "Delete view"] -state normal
8656 if {[info exists permviews]} {
8657 foreach v $permviews {
8660 set viewname($n) [lindex $v 0]
8661 set viewfiles($n) [lindex $v 1]
8662 set viewargs($n) [lindex $v 2]