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
-z --pretty=raw
$order --parents \
99 --boundary $viewargs($view) "--" $viewfiles($view)] r
]
101 error_popup
"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]
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
"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
"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
"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) {"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 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 OK
-command "set confirm_ok 1; destroy $w"
608 pack
$w.ok
-side left
-fill x
609 button
$w.cancel
-text Cancel
-command "destroy $w"
610 pack
$w.cancel
-side right
-fill x
611 bind $w <Visibility
> "grab $w; focus $w"
617 global canv canv2 canv3 linespc charspc ctext cflist
619 global findtype findtypemenu findloc findstring fstring geometry
620 global entries sha1entry sha1string sha1but
621 global diffcontextstring diffcontext
622 global maincursor textcursor curtextcursor
623 global rowctxmenu fakerowmenu mergemax wrapcomment
624 global highlight_files gdttype
625 global searchstring sstring
626 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
627 global headctxmenu progresscanv progressitem progresscoords statusw
628 global fprogitem fprogcoord lastprogupdate progupdatepending
632 .bar add cascade
-label "File" -menu .bar.
file
633 .bar configure
-font uifont
635 .bar.
file add
command -label "Update" -command updatecommits
636 .bar.
file add
command -label "Reread references" -command rereadrefs
637 .bar.
file add
command -label "List references" -command showrefs
638 .bar.
file add
command -label "Quit" -command doquit
639 .bar.
file configure
-font uifont
641 .bar add cascade
-label "Edit" -menu .bar.edit
642 .bar.edit add
command -label "Preferences" -command doprefs
643 .bar.edit configure
-font uifont
645 menu .bar.view
-font uifont
646 .bar add cascade
-label "View" -menu .bar.view
647 .bar.view add
command -label "New view..." -command {newview
0}
648 .bar.view add
command -label "Edit view..." -command editview \
650 .bar.view add
command -label "Delete view" -command delview
-state disabled
651 .bar.view add separator
652 .bar.view add radiobutton
-label "All files" -command {showview
0} \
653 -variable selectedview
-value 0
656 .bar add cascade
-label "Help" -menu .bar.
help
657 .bar.
help add
command -label "About gitk" -command about
658 .bar.
help add
command -label "Key bindings" -command keys
659 .bar.
help configure
-font uifont
660 . configure
-menu .bar
662 # the gui has upper and lower half, parts of a paned window.
663 panedwindow .ctop
-orient vertical
665 # possibly use assumed geometry
666 if {![info exists geometry
(pwsash0
)]} {
667 set geometry
(topheight
) [expr {15 * $linespc}]
668 set geometry
(topwidth
) [expr {80 * $charspc}]
669 set geometry
(botheight
) [expr {15 * $linespc}]
670 set geometry
(botwidth
) [expr {50 * $charspc}]
671 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
672 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
675 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
676 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
678 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
680 # create three canvases
681 set cscroll .tf.histframe.csb
682 set canv .tf.histframe.pwclist.canv
684 -selectbackground $selectbgcolor \
685 -background $bgcolor -bd 0 \
686 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
687 .tf.histframe.pwclist add
$canv
688 set canv2 .tf.histframe.pwclist.canv2
690 -selectbackground $selectbgcolor \
691 -background $bgcolor -bd 0 -yscrollincr $linespc
692 .tf.histframe.pwclist add
$canv2
693 set canv3 .tf.histframe.pwclist.canv3
695 -selectbackground $selectbgcolor \
696 -background $bgcolor -bd 0 -yscrollincr $linespc
697 .tf.histframe.pwclist add
$canv3
698 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
699 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
701 # a scroll bar to rule them
702 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
703 pack
$cscroll -side right
-fill y
704 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
705 lappend bglist
$canv $canv2 $canv3
706 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
708 # we have two button bars at bottom of top frame. Bar 1
710 frame .tf.lbar
-height 15
712 set sha1entry .tf.bar.sha1
713 set entries
$sha1entry
714 set sha1but .tf.bar.sha1label
715 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
716 -command gotocommit
-width 8 -font uifont
717 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
718 pack .tf.bar.sha1label
-side left
719 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
720 trace add variable sha1string
write sha1change
721 pack
$sha1entry -side left
-pady 2
723 image create bitmap bm-left
-data {
724 #define left_width 16
725 #define left_height 16
726 static unsigned char left_bits
[] = {
727 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
728 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
729 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
731 image create bitmap bm-right
-data {
732 #define right_width 16
733 #define right_height 16
734 static unsigned char right_bits
[] = {
735 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
736 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
737 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
739 button .tf.bar.leftbut
-image bm-left
-command goback \
740 -state disabled
-width 26
741 pack .tf.bar.leftbut
-side left
-fill y
742 button .tf.bar.rightbut
-image bm-right
-command goforw \
743 -state disabled
-width 26
744 pack .tf.bar.rightbut
-side left
-fill y
746 # Status label and progress bar
747 set statusw .tf.bar.status
748 label
$statusw -width 15 -relief sunken
-font uifont
749 pack
$statusw -side left
-padx 5
750 set h
[expr {[font metrics uifont
-linespace] + 2}]
751 set progresscanv .tf.bar.progress
752 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
753 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
754 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
755 pack
$progresscanv -side right
-expand 1 -fill x
756 set progresscoords
{0 0}
758 bind $progresscanv <Configure
> adjustprogress
759 set lastprogupdate
[clock clicks
-milliseconds]
760 set progupdatepending
0
762 # build up the bottom bar of upper window
763 label .tf.lbar.flabel
-text "Find " -font uifont
764 button .tf.lbar.fnext
-text "next" -command dofind
-font uifont
765 button .tf.lbar.fprev
-text "prev" -command {dofind
1} -font uifont
766 label .tf.lbar.flab2
-text " commit " -font uifont
767 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
769 set gdttype
"containing:"
770 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
773 "adding/removing string:"]
774 trace add variable gdttype
write gdttype_change
775 $gm conf
-font uifont
776 .tf.lbar.gdttype conf
-font uifont
777 pack .tf.lbar.gdttype
-side left
-fill y
780 set fstring .tf.lbar.findstring
781 lappend entries
$fstring
782 entry
$fstring -width 30 -font textfont
-textvariable findstring
783 trace add variable findstring
write find_change
785 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
786 findtype Exact IgnCase Regexp
]
787 trace add variable findtype
write findcom_change
788 .tf.lbar.findtype configure
-font uifont
789 .tf.lbar.findtype.menu configure
-font uifont
790 set findloc
"All fields"
791 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
792 Comments Author Committer
793 trace add variable findloc
write find_change
794 .tf.lbar.findloc configure
-font uifont
795 .tf.lbar.findloc.menu configure
-font uifont
796 pack .tf.lbar.findloc
-side right
797 pack .tf.lbar.findtype
-side right
798 pack
$fstring -side left
-expand 1 -fill x
800 # Finish putting the upper half of the viewer together
801 pack .tf.lbar
-in .tf
-side bottom
-fill x
802 pack .tf.bar
-in .tf
-side bottom
-fill x
803 pack .tf.histframe
-fill both
-side top
-expand 1
805 .ctop paneconfigure .tf
-height $geometry(topheight
)
806 .ctop paneconfigure .tf
-width $geometry(topwidth
)
808 # now build up the bottom
809 panedwindow .pwbottom
-orient horizontal
811 # lower left, a text box over search bar, scroll bar to the right
812 # if we know window height, then that will set the lower text height, otherwise
813 # we set lower text height which will drive window height
814 if {[info exists geometry
(main
)]} {
815 frame .bleft
-width $geometry(botwidth
)
817 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
822 button .bleft.top.search
-text "Search" -command dosearch \
824 pack .bleft.top.search
-side left
-padx 5
825 set sstring .bleft.top.sstring
826 entry
$sstring -width 20 -font textfont
-textvariable searchstring
827 lappend entries
$sstring
828 trace add variable searchstring
write incrsearch
829 pack
$sstring -side left
-expand 1 -fill x
830 radiobutton .bleft.mid.
diff -text "Diff" \
831 -command changediffdisp
-variable diffelide
-value {0 0}
832 radiobutton .bleft.mid.old
-text "Old version" \
833 -command changediffdisp
-variable diffelide
-value {0 1}
834 radiobutton .bleft.mid.new
-text "New version" \
835 -command changediffdisp
-variable diffelide
-value {1 0}
836 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
838 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
839 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
840 -from 1 -increment 1 -to 10000000 \
841 -validate all
-validatecommand "diffcontextvalidate %P" \
842 -textvariable diffcontextstring
843 .bleft.mid.diffcontext
set $diffcontext
844 trace add variable diffcontextstring
write diffcontextchange
845 lappend entries .bleft.mid.diffcontext
846 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
847 set ctext .bleft.ctext
848 text
$ctext -background $bgcolor -foreground $fgcolor \
849 -state disabled
-font textfont \
850 -yscrollcommand scrolltext
-wrap none
852 $ctext conf
-tabstyle wordprocessor
854 scrollbar .bleft.sb
-command "$ctext yview"
855 pack .bleft.top
-side top
-fill x
856 pack .bleft.mid
-side top
-fill x
857 pack .bleft.sb
-side right
-fill y
858 pack
$ctext -side left
-fill both
-expand 1
859 lappend bglist
$ctext
860 lappend fglist
$ctext
862 $ctext tag conf comment
-wrap $wrapcomment
863 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
864 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
865 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
866 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
867 $ctext tag conf m0
-fore red
868 $ctext tag conf m1
-fore blue
869 $ctext tag conf m2
-fore green
870 $ctext tag conf m3
-fore purple
871 $ctext tag conf
m4 -fore brown
872 $ctext tag conf m5
-fore "#009090"
873 $ctext tag conf m6
-fore magenta
874 $ctext tag conf m7
-fore "#808000"
875 $ctext tag conf m8
-fore "#009000"
876 $ctext tag conf m9
-fore "#ff0080"
877 $ctext tag conf m10
-fore cyan
878 $ctext tag conf m11
-fore "#b07070"
879 $ctext tag conf m12
-fore "#70b0f0"
880 $ctext tag conf m13
-fore "#70f0b0"
881 $ctext tag conf m14
-fore "#f0b070"
882 $ctext tag conf m15
-fore "#ff70b0"
883 $ctext tag conf mmax
-fore darkgrey
885 $ctext tag conf mresult
-font textfontbold
886 $ctext tag conf msep
-font textfontbold
887 $ctext tag conf found
-back yellow
890 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
895 radiobutton .bright.mode.
patch -text "Patch" \
896 -command reselectline
-variable cmitmode
-value "patch"
897 .bright.mode.
patch configure
-font uifont
898 radiobutton .bright.mode.tree
-text "Tree" \
899 -command reselectline
-variable cmitmode
-value "tree"
900 .bright.mode.tree configure
-font uifont
901 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
902 pack .bright.mode
-side top
-fill x
903 set cflist .bright.cfiles
904 set indent
[font measure mainfont
"nn"]
906 -selectbackground $selectbgcolor \
907 -background $bgcolor -foreground $fgcolor \
909 -tabs [list
$indent [expr {2 * $indent}]] \
910 -yscrollcommand ".bright.sb set" \
911 -cursor [. cget
-cursor] \
912 -spacing1 1 -spacing3 1
913 lappend bglist
$cflist
914 lappend fglist
$cflist
915 scrollbar .bright.sb
-command "$cflist yview"
916 pack .bright.sb
-side right
-fill y
917 pack
$cflist -side left
-fill both
-expand 1
918 $cflist tag configure highlight \
919 -background [$cflist cget
-selectbackground]
920 $cflist tag configure bold
-font mainfontbold
922 .pwbottom add .bright
925 # restore window position if known
926 if {[info exists geometry
(main
)]} {
927 wm geometry .
"$geometry(main)"
930 if {[tk windowingsystem
] eq
{aqua
}} {
936 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
937 pack .ctop
-fill both
-expand 1
938 bindall
<1> {selcanvline
%W
%x
%y
}
939 #bindall <B1-Motion> {selcanvline %W %x %y}
940 if {[tk windowingsystem
] == "win32"} {
941 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
942 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
944 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
945 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
947 bindall
<2> "canvscan mark %W %x %y"
948 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
949 bindkey
<Home
> selfirstline
950 bindkey
<End
> sellastline
951 bind .
<Key-Up
> "selnextline -1"
952 bind .
<Key-Down
> "selnextline 1"
953 bindkey
<Key-Right
> "goforw"
954 bindkey
<Key-Left
> "goback"
955 bind .
<Key-Prior
> "selnextpage -1"
956 bind .
<Key-Next
> "selnextpage 1"
957 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
958 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
959 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
960 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
961 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
962 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
963 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
964 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
965 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
966 bindkey p
"selnextline -1"
967 bindkey n
"selnextline 1"
970 bindkey i
"selnextline -1"
971 bindkey k
"selnextline 1"
974 bindkey b
"$ctext yview scroll -1 pages"
975 bindkey d
"$ctext yview scroll 18 units"
976 bindkey u
"$ctext yview scroll -18 units"
977 bindkey
/ {findnext
1}
978 bindkey
<Key-Return
> {findnext
0}
981 bindkey
<F5
> updatecommits
982 bind .
<$M1B-q> doquit
983 bind .
<$M1B-f> dofind
984 bind .
<$M1B-g> {findnext
0}
985 bind .
<$M1B-r> dosearchback
986 bind .
<$M1B-s> dosearch
987 bind .
<$M1B-equal> {incrfont
1}
988 bind .
<$M1B-KP_Add> {incrfont
1}
989 bind .
<$M1B-minus> {incrfont
-1}
990 bind .
<$M1B-KP_Subtract> {incrfont
-1}
991 wm protocol . WM_DELETE_WINDOW doquit
992 bind .
<Button-1
> "click %W"
993 bind $fstring <Key-Return
> dofind
994 bind $sha1entry <Key-Return
> gotocommit
995 bind $sha1entry <<PasteSelection>> clearsha1
996 bind $cflist <1> {sel_flist %W %x %y; break}
997 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
998 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
999 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1001 set maincursor [. cget -cursor]
1002 set textcursor [$ctext cget -cursor]
1003 set curtextcursor $textcursor
1005 set rowctxmenu .rowctxmenu
1006 menu $rowctxmenu -tearoff 0
1007 $rowctxmenu add command -label "Diff this -> selected" \
1008 -command {diffvssel 0}
1009 $rowctxmenu add command -label "Diff selected -> this" \
1010 -command {diffvssel 1}
1011 $rowctxmenu add command -label "Make patch" -command mkpatch
1012 $rowctxmenu add command -label "Create tag" -command mktag
1013 $rowctxmenu add command -label "Write commit to file" -command writecommit
1014 $rowctxmenu add command -label "Create new branch" -command mkbranch
1015 $rowctxmenu add command -label "Cherry-pick this commit" \
1017 $rowctxmenu add command -label "Reset HEAD branch to here" \
1020 set fakerowmenu .fakerowmenu
1021 menu $fakerowmenu -tearoff 0
1022 $fakerowmenu add command -label "Diff this -> selected" \
1023 -command {diffvssel 0}
1024 $fakerowmenu add command -label "Diff selected -> this" \
1025 -command {diffvssel 1}
1026 $fakerowmenu add command -label "Make patch" -command mkpatch
1027 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1028 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1029 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1031 set headctxmenu .headctxmenu
1032 menu $headctxmenu -tearoff 0
1033 $headctxmenu add command -label "Check out this branch" \
1035 $headctxmenu add command -label "Remove this branch" \
1039 set flist_menu .flistctxmenu
1040 menu $flist_menu -tearoff 0
1041 $flist_menu add command -label "Highlight this too" \
1042 -command {flist_hl 0}
1043 $flist_menu add command -label "Highlight this only" \
1044 -command {flist_hl 1}
1047 # Windows sends all mouse wheel events to the current focused window, not
1048 # the one where the mouse hovers, so bind those events here and redirect
1049 # to the correct window
1050 proc windows_mousewheel_redirector {W X Y D} {
1051 global canv canv2 canv3
1052 set w [winfo containing -displayof $W $X $Y]
1054 set u [expr {$D < 0 ? 5 : -5}]
1055 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1056 allcanvs yview scroll $u units
1059 $w yview scroll $u units
1065 # mouse-2 makes all windows scan vertically, but only the one
1066 # the cursor is in scans horizontally
1067 proc canvscan {op w x y} {
1068 global canv canv2 canv3
1069 foreach c [list $canv $canv2 $canv3] {
1078 proc scrollcanv {cscroll f0 f1} {
1079 $cscroll set $f0 $f1
1084 # when we make a key binding for the toplevel, make sure
1085 # it doesn't get triggered when that key is pressed in the
1086 # find string entry widget.
1087 proc bindkey {ev script} {
1090 set escript [bind Entry $ev]
1091 if {$escript == {}} {
1092 set escript [bind Entry <Key>]
1094 foreach e $entries {
1095 bind $e $ev "$escript; break"
1099 # set the focus back to the toplevel for any click outside
1102 global ctext entries
1103 foreach e [concat $entries $ctext] {
1104 if {$w == $e} return
1109 # Adjust the progress bar for a change in requested extent or canvas size
1110 proc adjustprogress {} {
1111 global progresscanv progressitem progresscoords
1112 global fprogitem fprogcoord lastprogupdate progupdatepending
1114 set w [expr {[winfo width $progresscanv] - 4}]
1115 set x0 [expr {$w * [lindex $progresscoords 0]}]
1116 set x1 [expr {$w * [lindex $progresscoords 1]}]
1117 set h [winfo height $progresscanv]
1118 $progresscanv coords $progressitem $x0 0 $x1 $h
1119 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1120 set now [clock clicks -milliseconds]
1121 if {$now >= $lastprogupdate + 100} {
1122 set progupdatepending 0
1124 } elseif {!$progupdatepending} {
1125 set progupdatepending 1
1126 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1130 proc doprogupdate {} {
1131 global lastprogupdate progupdatepending
1133 if {$progupdatepending} {
1134 set progupdatepending 0
1135 set lastprogupdate [clock clicks -milliseconds]
1140 proc savestuff {w} {
1141 global canv canv2 canv3 mainfont textfont uifont tabstop
1142 global stuffsaved findmergefiles maxgraphpct
1143 global maxwidth showneartags showlocalchanges
1144 global viewname viewfiles viewargs viewperm nextviewnum
1145 global cmitmode wrapcomment datetimeformat
1146 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1148 if {$stuffsaved} return
1149 if {![winfo viewable .]} return
1151 set f [open "~/.gitk-new" w]
1152 puts $f [list set mainfont $mainfont]
1153 puts $f [list set textfont $textfont]
1154 puts $f [list set uifont $uifont]
1155 puts $f [list set tabstop $tabstop]
1156 puts $f [list set findmergefiles $findmergefiles]
1157 puts $f [list set maxgraphpct $maxgraphpct]
1158 puts $f [list set maxwidth $maxwidth]
1159 puts $f [list set cmitmode $cmitmode]
1160 puts $f [list set wrapcomment $wrapcomment]
1161 puts $f [list set showneartags $showneartags]
1162 puts $f [list set showlocalchanges $showlocalchanges]
1163 puts $f [list set datetimeformat $datetimeformat]
1164 puts $f [list set bgcolor $bgcolor]
1165 puts $f [list set fgcolor $fgcolor]
1166 puts $f [list set colors $colors]
1167 puts $f [list set diffcolors $diffcolors]
1168 puts $f [list set diffcontext $diffcontext]
1169 puts $f [list set selectbgcolor $selectbgcolor]
1171 puts $f "set geometry(main) [wm geometry .]"
1172 puts $f "set geometry(topwidth) [winfo width .tf]"
1173 puts $f "set geometry(topheight) [winfo height .tf]"
1174 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1175 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1176 puts $f "set geometry(botwidth) [winfo width .bleft]"
1177 puts $f "set geometry(botheight) [winfo height .bleft]"
1179 puts -nonewline $f "set permviews {"
1180 for {set v 0} {$v < $nextviewnum} {incr v} {
1181 if {$viewperm($v)} {
1182 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1187 file rename -force "~/.gitk-new" "~/.gitk"
1192 proc resizeclistpanes {win w} {
1194 if {[info exists oldwidth($win)]} {
1195 set s0 [$win sash coord 0]
1196 set s1 [$win sash coord 1]
1198 set sash0 [expr {int($w/2 - 2)}]
1199 set sash1 [expr {int($w*5/6 - 2)}]
1201 set factor [expr {1.0 * $w / $oldwidth($win)}]
1202 set sash0 [expr {int($factor * [lindex $s0 0])}]
1203 set sash1 [expr {int($factor * [lindex $s1 0])}]
1207 if {$sash1 < $sash0 + 20} {
1208 set sash1 [expr {$sash0 + 20}]
1210 if {$sash1 > $w - 10} {
1211 set sash1 [expr {$w - 10}]
1212 if {$sash0 > $sash1 - 20} {
1213 set sash0 [expr {$sash1 - 20}]
1217 $win sash place 0 $sash0 [lindex $s0 1]
1218 $win sash place 1 $sash1 [lindex $s1 1]
1220 set oldwidth($win) $w
1223 proc resizecdetpanes {win w} {
1225 if {[info exists oldwidth($win)]} {
1226 set s0 [$win sash coord 0]
1228 set sash0 [expr {int($w*3/4 - 2)}]
1230 set factor [expr {1.0 * $w / $oldwidth($win)}]
1231 set sash0 [expr {int($factor * [lindex $s0 0])}]
1235 if {$sash0 > $w - 15} {
1236 set sash0 [expr {$w - 15}]
1239 $win sash place 0 $sash0 [lindex $s0 1]
1241 set oldwidth($win) $w
1244 proc allcanvs args {
1245 global canv canv2 canv3
1251 proc bindall {event action} {
1252 global canv canv2 canv3
1253 bind $canv $event $action
1254 bind $canv2 $event $action
1255 bind $canv3 $event $action
1261 if {[winfo exists $w]} {
1266 wm title $w "About gitk"
1267 message $w.m -text {
1268 Gitk - a commit viewer for git
1270 Copyright © 2005-2006 Paul Mackerras
1272 Use and redistribute under the terms of the GNU General Public License} \
1273 -justify center -aspect 400 -border 2 -bg white -relief groove
1274 pack $w.m -side top -fill x -padx 2 -pady 2
1275 $w.m configure -font uifont
1276 button $w.ok -text Close -command "destroy $w" -default active
1277 pack $w.ok -side bottom
1278 $w.ok configure -font uifont
1279 bind $w <Visibility> "focus $w.ok"
1280 bind $w <Key-Escape> "destroy $w"
1281 bind $w <Key-Return> "destroy $w"
1287 if {[winfo exists $w]} {
1291 if {[tk windowingsystem] eq {aqua}} {
1297 wm title $w "Gitk key bindings"
1298 message $w.m -text "
1302 <Home> Move to first commit
1303 <End> Move to last commit
1304 <Up>, p, i Move up one commit
1305 <Down>, n, k Move down one commit
1306 <Left>, z, j Go back in history list
1307 <Right>, x, l Go forward in history list
1308 <PageUp> Move up one page in commit list
1309 <PageDown> Move down one page in commit list
1310 <$M1T-Home> Scroll to top of commit list
1311 <$M1T-End> Scroll to bottom of commit list
1312 <$M1T-Up> Scroll commit list up one line
1313 <$M1T-Down> Scroll commit list down one line
1314 <$M1T-PageUp> Scroll commit list up one page
1315 <$M1T-PageDown> Scroll commit list down one page
1316 <Shift-Up> Move to previous highlighted line
1317 <Shift-Down> Move to next highlighted line
1318 <Delete>, b Scroll diff view up one page
1319 <Backspace> Scroll diff view up one page
1320 <Space> Scroll diff view down one page
1321 u Scroll diff view up 18 lines
1322 d Scroll diff view down 18 lines
1324 <$M1T-G> Move to next find hit
1325 <Return> Move to next find hit
1326 / Move to next find hit, or redo find
1327 ? Move to previous find hit
1328 f Scroll diff view to next file
1329 <$M1T-S> Search for next hit in diff view
1330 <$M1T-R> Search for previous hit in diff view
1331 <$M1T-KP+> Increase font size
1332 <$M1T-plus> Increase font size
1333 <$M1T-KP-> Decrease font size
1334 <$M1T-minus> Decrease font size
1337 -justify left -bg white -border 2 -relief groove
1338 pack $w.m -side top -fill both -padx 2 -pady 2
1339 $w.m configure -font uifont
1340 button $w.ok -text Close -command "destroy $w" -default active
1341 pack $w.ok -side bottom
1342 $w.ok configure -font uifont
1343 bind $w <Visibility> "focus $w.ok"
1344 bind $w <Key-Escape> "destroy $w"
1345 bind $w <Key-Return> "destroy $w"
1348 # Procedures for manipulating the file list window at the
1349 # bottom right of the overall window.
1351 proc treeview {w l openlevs} {
1352 global treecontents treediropen treeheight treeparent treeindex
1362 set treecontents() {}
1363 $w conf -state normal
1365 while {[string range $f 0 $prefixend] ne $prefix} {
1366 if {$lev <= $openlevs} {
1367 $w mark set e:$treeindex($prefix) "end -1c"
1368 $w mark gravity e:$treeindex($prefix) left
1370 set treeheight($prefix) $ht
1371 incr ht [lindex $htstack end]
1372 set htstack [lreplace $htstack end end]
1373 set prefixend [lindex $prefendstack end]
1374 set prefendstack [lreplace $prefendstack end end]
1375 set prefix [string range $prefix 0 $prefixend]
1378 set tail [string range $f [expr {$prefixend+1}] end]
1379 while {[set slash [string first "/" $tail]] >= 0} {
1382 lappend prefendstack $prefixend
1383 incr prefixend [expr {$slash + 1}]
1384 set d [string range $tail 0 $slash]
1385 lappend treecontents($prefix) $d
1386 set oldprefix $prefix
1388 set treecontents($prefix) {}
1389 set treeindex($prefix) [incr ix]
1390 set treeparent($prefix) $oldprefix
1391 set tail [string range $tail [expr {$slash+1}] end]
1392 if {$lev <= $openlevs} {
1394 set treediropen($prefix) [expr {$lev < $openlevs}]
1395 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1396 $w mark set d:$ix "end -1c"
1397 $w mark gravity d:$ix left
1399 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1401 $w image create end -align center -image $bm -padx 1 \
1403 $w insert end $d [highlight_tag $prefix]
1404 $w mark set s:$ix "end -1c"
1405 $w mark gravity s:$ix left
1410 if {$lev <= $openlevs} {
1413 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1415 $w insert end $tail [highlight_tag $f]
1417 lappend treecontents($prefix) $tail
1420 while {$htstack ne {}} {
1421 set treeheight($prefix) $ht
1422 incr ht [lindex $htstack end]
1423 set htstack [lreplace $htstack end end]
1424 set prefixend [lindex $prefendstack end]
1425 set prefendstack [lreplace $prefendstack end end]
1426 set prefix [string range $prefix 0 $prefixend]
1428 $w conf -state disabled
1431 proc linetoelt {l} {
1432 global treeheight treecontents
1437 foreach e $treecontents($prefix) {
1442 if {[string index $e end] eq "/"} {
1443 set n $treeheight($prefix$e)
1455 proc highlight_tree {y prefix} {
1456 global treeheight treecontents cflist
1458 foreach e $treecontents($prefix) {
1460 if {[highlight_tag $path] ne {}} {
1461 $cflist tag add bold $y.0 "$y.0 lineend"
1464 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1465 set y [highlight_tree $y $path]
1471 proc treeclosedir {w dir} {
1472 global treediropen treeheight treeparent treeindex
1474 set ix $treeindex($dir)
1475 $w conf -state normal
1476 $w delete s:$ix e:$ix
1477 set treediropen($dir) 0
1478 $w image configure a:$ix -image tri-rt
1479 $w conf -state disabled
1480 set n [expr {1 - $treeheight($dir)}]
1481 while {$dir ne {}} {
1482 incr treeheight($dir) $n
1483 set dir $treeparent($dir)
1487 proc treeopendir {w dir} {
1488 global treediropen treeheight treeparent treecontents treeindex
1490 set ix $treeindex($dir)
1491 $w conf -state normal
1492 $w image configure a:$ix -image tri-dn
1493 $w mark set e:$ix s:$ix
1494 $w mark gravity e:$ix right
1497 set n [llength $treecontents($dir)]
1498 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1501 incr treeheight($x) $n
1503 foreach e $treecontents($dir) {
1505 if {[string index $e end] eq "/"} {
1506 set iy $treeindex($de)
1507 $w mark set d:$iy e:$ix
1508 $w mark gravity d:$iy left
1509 $w insert e:$ix $str
1510 set treediropen($de) 0
1511 $w image create e:$ix -align center -image tri-rt -padx 1 \
1513 $w insert e:$ix $e [highlight_tag $de]
1514 $w mark set s:$iy e:$ix
1515 $w mark gravity s:$iy left
1516 set treeheight($de) 1
1518 $w insert e:$ix $str
1519 $w insert e:$ix $e [highlight_tag $de]
1522 $w mark gravity e:$ix left
1523 $w conf -state disabled
1524 set treediropen($dir) 1
1525 set top [lindex [split [$w index @0,0] .] 0]
1526 set ht [$w cget -height]
1527 set l [lindex [split [$w index s:$ix] .] 0]
1530 } elseif {$l + $n + 1 > $top + $ht} {
1531 set top [expr {$l + $n + 2 - $ht}]
1539 proc treeclick {w x y} {
1540 global treediropen cmitmode ctext cflist cflist_top
1542 if {$cmitmode ne "tree"} return
1543 if {![info exists cflist_top]} return
1544 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1545 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1546 $cflist tag add highlight $l.0 "$l.0 lineend"
1552 set e [linetoelt $l]
1553 if {[string index $e end] ne "/"} {
1555 } elseif {$treediropen($e)} {
1562 proc setfilelist {id} {
1563 global treefilelist cflist
1565 treeview $cflist $treefilelist($id) 0
1568 image create bitmap tri-rt -background black -foreground blue -data {
1569 #define tri-rt_width 13
1570 #define tri-rt_height 13
1571 static unsigned char tri-rt_bits[] = {
1572 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1573 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1576 #define tri-rt-mask_width 13
1577 #define tri-rt-mask_height 13
1578 static unsigned char tri-rt-mask_bits[] = {
1579 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1580 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1583 image create bitmap tri-dn -background black -foreground blue -data {
1584 #define tri-dn_width 13
1585 #define tri-dn_height 13
1586 static unsigned char tri-dn_bits[] = {
1587 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1588 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1591 #define tri-dn-mask_width 13
1592 #define tri-dn-mask_height 13
1593 static unsigned char tri-dn-mask_bits[] = {
1594 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1595 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1599 image create bitmap reficon-T -background black -foreground yellow -data {
1600 #define tagicon_width 13
1601 #define tagicon_height 9
1602 static unsigned char tagicon_bits[] = {
1603 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1604 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1606 #define tagicon-mask_width 13
1607 #define tagicon-mask_height 9
1608 static unsigned char tagicon-mask_bits[] = {
1609 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1610 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1613 #define headicon_width 13
1614 #define headicon_height 9
1615 static unsigned char headicon_bits[] = {
1616 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1617 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1620 #define headicon-mask_width 13
1621 #define headicon-mask_height 9
1622 static unsigned char headicon-mask_bits[] = {
1623 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1624 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1626 image create bitmap reficon-H -background black -foreground green \
1627 -data $rectdata -maskdata $rectmask
1628 image create bitmap reficon-o -background black -foreground "#ddddff" \
1629 -data $rectdata -maskdata $rectmask
1631 proc init_flist {first} {
1632 global cflist cflist_top selectedline difffilestart
1634 $cflist conf -state normal
1635 $cflist delete 0.0 end
1637 $cflist insert end $first
1639 $cflist tag add highlight 1.0 "1.0 lineend"
1641 catch {unset cflist_top}
1643 $cflist conf -state disabled
1644 set difffilestart {}
1647 proc highlight_tag {f} {
1648 global highlight_paths
1650 foreach p $highlight_paths {
1651 if {[string match $p $f]} {
1658 proc highlight_filelist {} {
1659 global cmitmode cflist
1661 $cflist conf -state normal
1662 if {$cmitmode ne "tree"} {
1663 set end [lindex [split [$cflist index end] .] 0]
1664 for {set l 2} {$l < $end} {incr l} {
1665 set line [$cflist get $l.0 "$l.0 lineend"]
1666 if {[highlight_tag $line] ne {}} {
1667 $cflist tag add bold $l.0 "$l.0 lineend"
1673 $cflist conf -state disabled
1676 proc unhighlight_filelist {} {
1679 $cflist conf -state normal
1680 $cflist tag remove bold 1.0 end
1681 $cflist conf -state disabled
1684 proc add_flist {fl} {
1687 $cflist conf -state normal
1689 $cflist insert end "\n"
1690 $cflist insert end $f [highlight_tag $f]
1692 $cflist conf -state disabled
1695 proc sel_flist {w x y} {
1696 global ctext difffilestart cflist cflist_top cmitmode
1698 if {$cmitmode eq "tree"} return
1699 if {![info exists cflist_top]} return
1700 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1701 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1702 $cflist tag add highlight $l.0 "$l.0 lineend"
1707 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1711 proc pop_flist_menu {w X Y x y} {
1712 global ctext cflist cmitmode flist_menu flist_menu_file
1713 global treediffs diffids
1716 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1718 if {$cmitmode eq "tree"} {
1719 set e [linetoelt $l]
1720 if {[string index $e end] eq "/"} return
1722 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1724 set flist_menu_file $e
1725 tk_popup $flist_menu $X $Y
1728 proc flist_hl {only} {
1729 global flist_menu_file findstring gdttype
1731 set x [shellquote $flist_menu_file]
1732 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1735 append findstring " " $x
1737 set gdttype "touching paths:"
1740 # Functions for adding and removing shell-type quoting
1742 proc shellquote {str} {
1743 if {![string match "*\['\"\\ \t]*" $str]} {
1746 if {![string match "*\['\"\\]*" $str]} {
1749 if {![string match "*'*" $str]} {
1752 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1755 proc shellarglist {l} {
1761 append str [shellquote $a]
1766 proc shelldequote {str} {
1771 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1772 append ret [string range $str $used end]
1773 set used [string length $str]
1776 set first [lindex $first 0]
1777 set ch [string index $str $first]
1778 if {$first > $used} {
1779 append ret [string range $str $used [expr {$first - 1}]]
1782 if {$ch eq " " || $ch eq "\t"} break
1785 set first [string first "'" $str $used]
1787 error "unmatched single-quote"
1789 append ret [string range $str $used [expr {$first - 1}]]
1794 if {$used >= [string length $str]} {
1795 error "trailing backslash"
1797 append ret [string index $str $used]
1802 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1803 error "unmatched double-quote"
1805 set first [lindex $first 0]
1806 set ch [string index $str $first]
1807 if {$first > $used} {
1808 append ret [string range $str $used [expr {$first - 1}]]
1811 if {$ch eq "\""} break
1813 append ret [string index $str $used]
1817 return [list $used $ret]
1820 proc shellsplit {str} {
1823 set str [string trimleft $str]
1824 if {$str eq {}} break
1825 set dq [shelldequote $str]
1826 set n [lindex $dq 0]
1827 set word [lindex $dq 1]
1828 set str [string range $str $n end]
1834 # Code to implement multiple views
1836 proc newview {ishighlight} {
1837 global nextviewnum newviewname newviewperm uifont newishighlight
1838 global newviewargs revtreeargs
1840 set newishighlight $ishighlight
1842 if {[winfo exists $top]} {
1846 set newviewname($nextviewnum) "View $nextviewnum"
1847 set newviewperm($nextviewnum) 0
1848 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1849 vieweditor $top $nextviewnum "Gitk view definition"
1854 global viewname viewperm newviewname newviewperm
1855 global viewargs newviewargs
1857 set top .gitkvedit-$curview
1858 if {[winfo exists $top]} {
1862 set newviewname($curview) $viewname($curview)
1863 set newviewperm($curview) $viewperm($curview)
1864 set newviewargs($curview) [shellarglist $viewargs($curview)]
1865 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1868 proc vieweditor {top n title} {
1869 global newviewname newviewperm viewfiles
1873 wm title $top $title
1874 label $top.nl -text "Name" -font uifont
1875 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1876 grid $top.nl $top.name -sticky w -pady 5
1877 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1879 grid $top.perm - -pady 5 -sticky w
1880 message $top.al -aspect 1000 -font uifont \
1881 -text "Commits to include (arguments to git rev-list):"
1882 grid $top.al - -sticky w -pady 5
1883 entry $top.args -width 50 -textvariable newviewargs($n) \
1884 -background white -font uifont
1885 grid $top.args - -sticky ew -padx 5
1886 message $top.l -aspect 1000 -font uifont \
1887 -text "Enter files and directories to include, one per line:"
1888 grid $top.l - -sticky w
1889 text $top.t -width 40 -height 10 -background white -font uifont
1890 if {[info exists viewfiles($n)]} {
1891 foreach f $viewfiles($n) {
1892 $top.t insert end $f
1893 $top.t insert end "\n"
1895 $top.t delete {end - 1c} end
1896 $top.t mark set insert 0.0
1898 grid $top.t - -sticky ew -padx 5
1900 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1902 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1904 grid $top.buts.ok $top.buts.can
1905 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1906 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1907 grid $top.buts - -pady 10 -sticky ew
1911 proc doviewmenu {m first cmd op argv} {
1912 set nmenu [$m index end]
1913 for {set i $first} {$i <= $nmenu} {incr i} {
1914 if {[$m entrycget $i -command] eq $cmd} {
1915 eval $m $op $i $argv
1921 proc allviewmenus {n op args} {
1924 doviewmenu .bar.view 5 [list showview $n] $op $args
1925 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1928 proc newviewok {top n} {
1929 global nextviewnum newviewperm newviewname newishighlight
1930 global viewname viewfiles viewperm selectedview curview
1931 global viewargs newviewargs viewhlmenu
1934 set newargs [shellsplit $newviewargs($n)]
1936 error_popup "Error in commit selection arguments: $err"
1942 foreach f [split [$top.t get 0.0 end] "\n"] {
1943 set ft [string trim $f]
1948 if {![info exists viewfiles($n)]} {
1949 # creating a new view
1951 set viewname($n) $newviewname($n)
1952 set viewperm($n) $newviewperm($n)
1953 set viewfiles($n) $files
1954 set viewargs($n) $newargs
1956 if {!$newishighlight} {
1959 run addvhighlight $n
1962 # editing an existing view
1963 set viewperm($n) $newviewperm($n)
1964 if {$newviewname($n) ne $viewname($n)} {
1965 set viewname($n) $newviewname($n)
1966 doviewmenu .bar.view 5 [list showview $n] \
1967 entryconf [list -label $viewname($n)]
1968 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1969 # entryconf [list -label $viewname($n) -value $viewname($n)]
1971 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1972 set viewfiles($n) $files
1973 set viewargs($n) $newargs
1974 if {$curview == $n} {
1979 catch {destroy $top}
1983 global curview viewdata viewperm hlview selectedhlview
1985 if {$curview == 0} return
1986 if {[info exists hlview] && $hlview == $curview} {
1987 set selectedhlview None
1990 allviewmenus $curview delete
1991 set viewdata($curview) {}
1992 set viewperm($curview) 0
1996 proc addviewmenu {n} {
1997 global viewname viewhlmenu
1999 .bar.view add radiobutton -label $viewname($n) \
2000 -command [list showview $n] -variable selectedview -value $n
2001 #$viewhlmenu add radiobutton -label $viewname($n) \
2002 # -command [list addvhighlight $n] -variable selectedhlview
2005 proc flatten {var} {
2009 foreach i [array names $var] {
2010 lappend ret $i [set $var\($i\)]
2015 proc unflatten {var l} {
2025 global curview viewdata viewfiles
2026 global displayorder parentlist rowidlist rowisopt rowfinal
2027 global colormap rowtextx commitrow nextcolor canvxmax
2028 global numcommits commitlisted
2029 global selectedline currentid canv canvy0
2031 global pending_select phase
2034 global selectedview selectfirst
2035 global vparentlist vdisporder vcmitlisted
2036 global hlview selectedhlview commitinterest
2038 if {$n == $curview} return
2040 if {[info exists selectedline]} {
2041 set selid $currentid
2042 set y [yc $selectedline]
2043 set ymax [lindex [$canv cget -scrollregion] 3]
2044 set span [$canv yview]
2045 set ytop [expr {[lindex $span 0] * $ymax}]
2046 set ybot [expr {[lindex $span 1] * $ymax}]
2047 if {$ytop < $y && $y < $ybot} {
2048 set yscreen [expr {$y - $ytop}]
2050 set yscreen [expr {($ybot - $ytop) / 2}]
2052 } elseif {[info exists pending_select]} {
2053 set selid $pending_select
2054 unset pending_select
2058 if {$curview >= 0} {
2059 set vparentlist($curview) $parentlist
2060 set vdisporder($curview) $displayorder
2061 set vcmitlisted($curview) $commitlisted
2063 ![info exists viewdata($curview)] ||
2064 [lindex $viewdata($curview) 0] ne {}} {
2065 set viewdata($curview) \
2066 [list $phase $rowidlist $rowisopt $rowfinal]
2069 catch {unset treediffs}
2071 if {[info exists hlview] && $hlview == $n} {
2073 set selectedhlview None
2075 catch {unset commitinterest}
2079 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2080 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2083 if {![info exists viewdata($n)]} {
2085 set pending_select $selid
2092 set phase [lindex $v 0]
2093 set displayorder $vdisporder($n)
2094 set parentlist $vparentlist($n)
2095 set commitlisted $vcmitlisted($n)
2096 set rowidlist [lindex $v 1]
2097 set rowisopt [lindex $v 2]
2098 set rowfinal [lindex $v 3]
2099 set numcommits $commitidx($n)
2101 catch {unset colormap}
2102 catch {unset rowtextx}
2104 set canvxmax [$canv cget -width]
2111 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2112 set row $commitrow($n,$selid)
2113 # try to get the selected row in the same position on the screen
2114 set ymax [lindex [$canv cget -scrollregion] 3]
2115 set ytop [expr {[yc $row] - $yscreen}]
2119 set yf [expr {$ytop * 1.0 / $ymax}]
2121 allcanvs yview moveto $yf
2125 } elseif {$selid ne {}} {
2126 set pending_select $selid
2128 set row [first_real_row]
2129 if {$row < $numcommits} {
2136 if {$phase eq "getcommits"} {
2137 show_status "Reading commits..."
2140 } elseif {$numcommits == 0} {
2141 show_status "No commits selected"
2145 # Stuff relating to the highlighting facility
2147 proc ishighlighted {row} {
2148 global vhighlights fhighlights nhighlights rhighlights
2150 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2151 return $nhighlights($row)
2153 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2154 return $vhighlights($row)
2156 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2157 return $fhighlights($row)
2159 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2160 return $rhighlights($row)
2165 proc bolden {row font} {
2166 global canv linehtag selectedline boldrows
2168 lappend boldrows $row
2169 $canv itemconf $linehtag($row) -font $font
2170 if {[info exists selectedline] && $row == $selectedline} {
2172 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2173 -outline {{}} -tags secsel \
2174 -fill [$canv cget -selectbackground]]
2179 proc bolden_name {row font} {
2180 global canv2 linentag selectedline boldnamerows
2182 lappend boldnamerows $row
2183 $canv2 itemconf $linentag($row) -font $font
2184 if {[info exists selectedline] && $row == $selectedline} {
2185 $canv2 delete secsel
2186 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2187 -outline {{}} -tags secsel \
2188 -fill [$canv2 cget -selectbackground]]
2197 foreach row $boldrows {
2198 if {![ishighlighted $row]} {
2199 bolden $row mainfont
2201 lappend stillbold $row
2204 set boldrows $stillbold
2207 proc addvhighlight {n} {
2208 global hlview curview viewdata vhl_done vhighlights commitidx
2210 if {[info exists hlview]} {
2214 if {$n != $curview && ![info exists viewdata($n)]} {
2215 set viewdata($n) [list getcommits {{}} 0 0 0]
2216 set vparentlist($n) {}
2217 set vdisporder($n) {}
2218 set vcmitlisted($n) {}
2221 set vhl_done $commitidx($hlview)
2222 if {$vhl_done > 0} {
2227 proc delvhighlight {} {
2228 global hlview vhighlights
2230 if {![info exists hlview]} return
2232 catch {unset vhighlights}
2236 proc vhighlightmore {} {
2237 global hlview vhl_done commitidx vhighlights
2238 global displayorder vdisporder curview
2240 set max $commitidx($hlview)
2241 if {$hlview == $curview} {
2242 set disp $displayorder
2244 set disp $vdisporder($hlview)
2246 set vr [visiblerows]
2247 set r0 [lindex $vr 0]
2248 set r1 [lindex $vr 1]
2249 for {set i $vhl_done} {$i < $max} {incr i} {
2250 set id [lindex $disp $i]
2251 if {[info exists commitrow($curview,$id)]} {
2252 set row $commitrow($curview,$id)
2253 if {$r0 <= $row && $row <= $r1} {
2254 if {![highlighted $row]} {
2255 bolden $row mainfontbold
2257 set vhighlights($row) 1
2264 proc askvhighlight {row id} {
2265 global hlview vhighlights commitrow iddrawn
2267 if {[info exists commitrow($hlview,$id)]} {
2268 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2269 bolden $row mainfontbold
2271 set vhighlights($row) 1
2273 set vhighlights($row) 0
2277 proc hfiles_change {} {
2278 global highlight_files filehighlight fhighlights fh_serial
2279 global highlight_paths gdttype
2281 if {[info exists filehighlight]} {
2282 # delete previous highlights
2283 catch {close $filehighlight}
2285 catch {unset fhighlights}
2287 unhighlight_filelist
2289 set highlight_paths {}
2290 after cancel do_file_hl $fh_serial
2292 if {$highlight_files ne {}} {
2293 after 300 do_file_hl $fh_serial
2297 proc gdttype_change {name ix op} {
2298 global gdttype highlight_files findstring findpattern
2301 if {$findstring ne {}} {
2302 if {$gdttype eq "containing:"} {
2303 if {$highlight_files ne {}} {
2304 set highlight_files {}
2309 if {$findpattern ne {}} {
2313 set highlight_files $findstring
2318 # enable/disable findtype/findloc menus too
2321 proc find_change {name ix op} {
2322 global gdttype findstring highlight_files
2325 if {$gdttype eq "containing:"} {
2328 if {$highlight_files ne $findstring} {
2329 set highlight_files $findstring
2336 proc findcom_change args {
2337 global nhighlights boldnamerows
2338 global findpattern findtype findstring gdttype
2341 # delete previous highlights, if any
2342 foreach row $boldnamerows {
2343 bolden_name $row mainfont
2346 catch {unset nhighlights}
2349 if {$gdttype ne "containing:" || $findstring eq {}} {
2351 } elseif {$findtype eq "Regexp"} {
2352 set findpattern $findstring
2354 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2356 set findpattern "*$e*"
2360 proc makepatterns {l} {
2363 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2364 if {[string index $ee end] eq "/"} {
2374 proc do_file_hl {serial} {
2375 global highlight_files filehighlight highlight_paths gdttype fhl_list
2377 if {$gdttype eq "touching paths:"} {
2378 if {[catch {set paths [shellsplit $highlight_files]}]} return
2379 set highlight_paths [makepatterns $paths]
2381 set gdtargs [concat -- $paths]
2382 } elseif {$gdttype eq "adding/removing string:"} {
2383 set gdtargs [list "-S$highlight_files"]
2385 # must be "containing:", i.e. we're searching commit info
2388 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2389 set filehighlight [open $cmd r+]
2390 fconfigure $filehighlight -blocking 0
2391 filerun $filehighlight readfhighlight
2397 proc flushhighlights {} {
2398 global filehighlight fhl_list
2400 if {[info exists filehighlight]} {
2402 puts $filehighlight ""
2403 flush $filehighlight
2407 proc askfilehighlight {row id} {
2408 global filehighlight fhighlights fhl_list
2410 lappend fhl_list $id
2411 set fhighlights($row) -1
2412 puts $filehighlight $id
2415 proc readfhighlight {} {
2416 global filehighlight fhighlights commitrow curview iddrawn
2417 global fhl_list find_dirn
2419 if {![info exists filehighlight]} {
2423 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2424 set line [string trim $line]
2425 set i [lsearch -exact $fhl_list $line]
2426 if {$i < 0} continue
2427 for {set j 0} {$j < $i} {incr j} {
2428 set id [lindex $fhl_list $j]
2429 if {[info exists commitrow($curview,$id)]} {
2430 set fhighlights($commitrow($curview,$id)) 0
2433 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2434 if {$line eq {}} continue
2435 if {![info exists commitrow($curview,$line)]} continue
2436 set row $commitrow($curview,$line)
2437 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2438 bolden $row mainfontbold
2440 set fhighlights($row) 1
2442 if {[eof $filehighlight]} {
2444 puts "oops, git diff-tree died"
2445 catch {close $filehighlight}
2449 if {[info exists find_dirn]} {
2450 if {$find_dirn > 0} {
2459 proc doesmatch {f} {
2460 global findtype findpattern
2462 if {$findtype eq "Regexp"} {
2463 return [regexp $findpattern $f]
2464 } elseif {$findtype eq "IgnCase"} {
2465 return [string match -nocase $findpattern $f]
2467 return [string match $findpattern $f]
2471 proc askfindhighlight {row id} {
2472 global nhighlights commitinfo iddrawn
2474 global markingmatches
2476 if {![info exists commitinfo($id)]} {
2479 set info $commitinfo($id)
2481 set fldtypes {Headline Author Date Committer CDate Comments}
2482 foreach f $info ty $fldtypes {
2483 if {($findloc eq "All fields" || $findloc eq $ty) &&
2485 if {$ty eq "Author"} {
2492 if {$isbold && [info exists iddrawn($id)]} {
2493 if {![ishighlighted $row]} {
2494 bolden $row mainfontbold
2496 bolden_name $row mainfontbold
2499 if {$markingmatches} {
2500 markrowmatches $row $id
2503 set nhighlights($row) $isbold
2506 proc markrowmatches {row id} {
2507 global canv canv2 linehtag linentag commitinfo findloc
2509 set headline [lindex $commitinfo($id) 0]
2510 set author [lindex $commitinfo($id) 1]
2511 $canv delete match$row
2512 $canv2 delete match$row
2513 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2514 set m [findmatches $headline]
2516 markmatches $canv $row $headline $linehtag($row) $m \
2517 [$canv itemcget $linehtag($row) -font] $row
2520 if {$findloc eq "All fields" || $findloc eq "Author"} {
2521 set m [findmatches $author]
2523 markmatches $canv2 $row $author $linentag($row) $m \
2524 [$canv2 itemcget $linentag($row) -font] $row
2529 proc vrel_change {name ix op} {
2530 global highlight_related
2533 if {$highlight_related ne "None"} {
2538 # prepare for testing whether commits are descendents or ancestors of a
2539 proc rhighlight_sel {a} {
2540 global descendent desc_todo ancestor anc_todo
2541 global highlight_related rhighlights
2543 catch {unset descendent}
2544 set desc_todo [list $a]
2545 catch {unset ancestor}
2546 set anc_todo [list $a]
2547 if {$highlight_related ne "None"} {
2553 proc rhighlight_none {} {
2556 catch {unset rhighlights}
2560 proc is_descendent {a} {
2561 global curview children commitrow descendent desc_todo
2564 set la $commitrow($v,$a)
2568 for {set i 0} {$i < [llength $todo]} {incr i} {
2569 set do [lindex $todo $i]
2570 if {$commitrow($v,$do) < $la} {
2571 lappend leftover $do
2574 foreach nk $children($v,$do) {
2575 if {![info exists descendent($nk)]} {
2576 set descendent($nk) 1
2584 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2588 set descendent($a) 0
2589 set desc_todo $leftover
2592 proc is_ancestor {a} {
2593 global curview parentlist commitrow ancestor anc_todo
2596 set la $commitrow($v,$a)
2600 for {set i 0} {$i < [llength $todo]} {incr i} {
2601 set do [lindex $todo $i]
2602 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2603 lappend leftover $do
2606 foreach np [lindex $parentlist $commitrow($v,$do)] {
2607 if {![info exists ancestor($np)]} {
2616 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2621 set anc_todo $leftover
2624 proc askrelhighlight {row id} {
2625 global descendent highlight_related iddrawn rhighlights
2626 global selectedline ancestor
2628 if {![info exists selectedline]} return
2630 if {$highlight_related eq "Descendent" ||
2631 $highlight_related eq "Not descendent"} {
2632 if {![info exists descendent($id)]} {
2635 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2638 } elseif {$highlight_related eq "Ancestor" ||
2639 $highlight_related eq "Not ancestor"} {
2640 if {![info exists ancestor($id)]} {
2643 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2647 if {[info exists iddrawn($id)]} {
2648 if {$isbold && ![ishighlighted $row]} {
2649 bolden $row mainfontbold
2652 set rhighlights($row) $isbold
2655 # Graph layout functions
2657 proc shortids {ids} {
2660 if {[llength $id] > 1} {
2661 lappend res [shortids $id]
2662 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2663 lappend res [string range $id 0 7]
2674 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2675 if {($n & $mask) != 0} {
2676 set ret [concat $ret $o]
2678 set o [concat $o $o]
2683 # Work out where id should go in idlist so that order-token
2684 # values increase from left to right
2685 proc idcol {idlist id {i 0}} {
2686 global ordertok curview
2688 set t $ordertok($curview,$id)
2689 if {$i >= [llength $idlist] ||
2690 $t < $ordertok($curview,[lindex $idlist $i])} {
2691 if {$i > [llength $idlist]} {
2692 set i [llength $idlist]
2694 while {[incr i -1] >= 0 &&
2695 $t < $ordertok($curview,[lindex $idlist $i])} {}
2698 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2699 while {[incr i] < [llength $idlist] &&
2700 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2706 proc initlayout {} {
2707 global rowidlist rowisopt rowfinal displayorder commitlisted
2708 global numcommits canvxmax canv
2711 global colormap rowtextx
2722 set canvxmax [$canv cget -width]
2723 catch {unset colormap}
2724 catch {unset rowtextx}
2728 proc setcanvscroll {} {
2729 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2731 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2732 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2733 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2734 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2737 proc visiblerows {} {
2738 global canv numcommits linespc
2740 set ymax [lindex [$canv cget -scrollregion] 3]
2741 if {$ymax eq {} || $ymax == 0} return
2743 set y0 [expr {int([lindex $f 0] * $ymax)}]
2744 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2748 set y1 [expr {int([lindex $f 1] * $ymax)}]
2749 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2750 if {$r1 >= $numcommits} {
2751 set r1 [expr {$numcommits - 1}]
2753 return [list $r0 $r1]
2756 proc layoutmore {} {
2757 global commitidx viewcomplete numcommits
2758 global uparrowlen downarrowlen mingaplen curview
2760 set show $commitidx($curview)
2761 if {$show > $numcommits || $viewcomplete($curview)} {
2762 showstuff $show $viewcomplete($curview)
2766 proc showstuff {canshow last} {
2767 global numcommits commitrow pending_select selectedline curview
2768 global mainheadid displayorder selectfirst
2769 global lastscrollset commitinterest
2771 if {$numcommits == 0} {
2773 set phase "incrdraw"
2777 set prev $numcommits
2778 set numcommits $canshow
2779 set t [clock clicks -milliseconds]
2780 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2781 set lastscrollset $t
2784 set rows [visiblerows]
2785 set r1 [lindex $rows 1]
2786 if {$r1 >= $canshow} {
2787 set r1 [expr {$canshow - 1}]
2792 if {[info exists pending_select] &&
2793 [info exists commitrow($curview,$pending_select)] &&
2794 $commitrow($curview,$pending_select) < $numcommits} {
2795 selectline $commitrow($curview,$pending_select) 1
2798 if {[info exists selectedline] || [info exists pending_select]} {
2801 set l [first_real_row]
2808 proc doshowlocalchanges {} {
2809 global curview mainheadid phase commitrow
2811 if {[info exists commitrow($curview,$mainheadid)] &&
2812 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2814 } elseif {$phase ne {}} {
2815 lappend commitinterest($mainheadid) {}
2819 proc dohidelocalchanges {} {
2820 global localfrow localirow lserial
2822 if {$localfrow >= 0} {
2823 removerow $localfrow
2825 if {$localirow > 0} {
2829 if {$localirow >= 0} {
2830 removerow $localirow
2836 # spawn off a process to do git diff-index --cached HEAD
2837 proc dodiffindex {} {
2838 global localirow localfrow lserial showlocalchanges
2840 if {!$showlocalchanges} return
2844 set fd [open "|git diff-index --cached HEAD" r]
2845 fconfigure $fd -blocking 0
2846 filerun $fd [list readdiffindex $fd $lserial]
2849 proc readdiffindex {fd serial} {
2850 global localirow commitrow mainheadid nullid2 curview
2851 global commitinfo commitdata lserial
2854 if {[gets $fd line] < 0} {
2860 # we only need to see one line and we don't really care what it says...
2863 # now see if there are any local changes not checked in to the index
2864 if {$serial == $lserial} {
2865 set fd [open "|git diff-files" r]
2866 fconfigure $fd -blocking 0
2867 filerun $fd [list readdifffiles $fd $serial]
2870 if {$isdiff && $serial == $lserial && $localirow == -1} {
2871 # add the line for the changes in the index to the graph
2872 set localirow $commitrow($curview,$mainheadid)
2873 set hl "Local changes checked in to index but not committed"
2874 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2875 set commitdata($nullid2) "\n $hl\n"
2876 insertrow $localirow $nullid2
2881 proc readdifffiles {fd serial} {
2882 global localirow localfrow commitrow mainheadid nullid curview
2883 global commitinfo commitdata lserial
2886 if {[gets $fd line] < 0} {
2892 # we only need to see one line and we don't really care what it says...
2895 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2896 # add the line for the local diff to the graph
2897 if {$localirow >= 0} {
2898 set localfrow $localirow
2901 set localfrow $commitrow($curview,$mainheadid)
2903 set hl "Local uncommitted changes, not checked in to index"
2904 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2905 set commitdata($nullid) "\n $hl\n"
2906 insertrow $localfrow $nullid
2911 proc nextuse {id row} {
2912 global commitrow curview children
2914 if {[info exists children($curview,$id)]} {
2915 foreach kid $children($curview,$id) {
2916 if {![info exists commitrow($curview,$kid)]} {
2919 if {$commitrow($curview,$kid) > $row} {
2920 return $commitrow($curview,$kid)
2924 if {[info exists commitrow($curview,$id)]} {
2925 return $commitrow($curview,$id)
2930 proc prevuse {id row} {
2931 global commitrow curview children
2934 if {[info exists children($curview,$id)]} {
2935 foreach kid $children($curview,$id) {
2936 if {![info exists commitrow($curview,$kid)]} break
2937 if {$commitrow($curview,$kid) < $row} {
2938 set ret $commitrow($curview,$kid)
2945 proc make_idlist {row} {
2946 global displayorder parentlist uparrowlen downarrowlen mingaplen
2947 global commitidx curview ordertok children commitrow
2949 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2953 set ra [expr {$row - $downarrowlen}]
2957 set rb [expr {$row + $uparrowlen}]
2958 if {$rb > $commitidx($curview)} {
2959 set rb $commitidx($curview)
2962 for {} {$r < $ra} {incr r} {
2963 set nextid [lindex $displayorder [expr {$r + 1}]]
2964 foreach p [lindex $parentlist $r] {
2965 if {$p eq $nextid} continue
2966 set rn [nextuse $p $r]
2968 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2969 lappend ids [list $ordertok($curview,$p) $p]
2973 for {} {$r < $row} {incr r} {
2974 set nextid [lindex $displayorder [expr {$r + 1}]]
2975 foreach p [lindex $parentlist $r] {
2976 if {$p eq $nextid} continue
2977 set rn [nextuse $p $r]
2978 if {$rn < 0 || $rn >= $row} {
2979 lappend ids [list $ordertok($curview,$p) $p]
2983 set id [lindex $displayorder $row]
2984 lappend ids [list $ordertok($curview,$id) $id]
2986 foreach p [lindex $parentlist $r] {
2987 set firstkid [lindex $children($curview,$p) 0]
2988 if {$commitrow($curview,$firstkid) < $row} {
2989 lappend ids [list $ordertok($curview,$p) $p]
2993 set id [lindex $displayorder $r]
2995 set firstkid [lindex $children($curview,$id) 0]
2996 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
2997 lappend ids [list $ordertok($curview,$id) $id]
3002 foreach idx [lsort -unique $ids] {
3003 lappend idlist [lindex $idx 1]
3008 proc rowsequal {a b} {
3009 while {[set i [lsearch -exact $a {}]] >= 0} {
3010 set a [lreplace $a $i $i]
3012 while {[set i [lsearch -exact $b {}]] >= 0} {
3013 set b [lreplace $b $i $i]
3015 return [expr {$a eq $b}]
3018 proc makeupline {id row rend col} {
3019 global rowidlist uparrowlen downarrowlen mingaplen
3021 for {set r $rend} {1} {set r $rstart} {
3022 set rstart [prevuse $id $r]
3023 if {$rstart < 0} return
3024 if {$rstart < $row} break
3026 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3027 set rstart [expr {$rend - $uparrowlen - 1}]
3029 for {set r $rstart} {[incr r] <= $row} {} {
3030 set idlist [lindex $rowidlist $r]
3031 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3032 set col [idcol $idlist $id $col]
3033 lset rowidlist $r [linsert $idlist $col $id]
3039 proc layoutrows {row endrow} {
3040 global rowidlist rowisopt rowfinal displayorder
3041 global uparrowlen downarrowlen maxwidth mingaplen
3042 global children parentlist
3043 global commitidx viewcomplete curview commitrow
3047 set rm1 [expr {$row - 1}]
3048 foreach id [lindex $rowidlist $rm1] {
3053 set final [lindex $rowfinal $rm1]
3055 for {} {$row < $endrow} {incr row} {
3056 set rm1 [expr {$row - 1}]
3057 if {$rm1 < 0 || $idlist eq {}} {
3058 set idlist [make_idlist $row]
3061 set id [lindex $displayorder $rm1]
3062 set col [lsearch -exact $idlist $id]
3063 set idlist [lreplace $idlist $col $col]
3064 foreach p [lindex $parentlist $rm1] {
3065 if {[lsearch -exact $idlist $p] < 0} {
3066 set col [idcol $idlist $p $col]
3067 set idlist [linsert $idlist $col $p]
3068 # if not the first child, we have to insert a line going up
3069 if {$id ne [lindex $children($curview,$p) 0]} {
3070 makeupline $p $rm1 $row $col
3074 set id [lindex $displayorder $row]
3075 if {$row > $downarrowlen} {
3076 set termrow [expr {$row - $downarrowlen - 1}]
3077 foreach p [lindex $parentlist $termrow] {
3078 set i [lsearch -exact $idlist $p]
3079 if {$i < 0} continue
3080 set nr [nextuse $p $termrow]
3081 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3082 set idlist [lreplace $idlist $i $i]
3086 set col [lsearch -exact $idlist $id]
3088 set col [idcol $idlist $id]
3089 set idlist [linsert $idlist $col $id]
3090 if {$children($curview,$id) ne {}} {
3091 makeupline $id $rm1 $row $col
3094 set r [expr {$row + $uparrowlen - 1}]
3095 if {$r < $commitidx($curview)} {
3097 foreach p [lindex $parentlist $r] {
3098 if {[lsearch -exact $idlist $p] >= 0} continue
3099 set fk [lindex $children($curview,$p) 0]
3100 if {$commitrow($curview,$fk) < $row} {
3101 set x [idcol $idlist $p $x]
3102 set idlist [linsert $idlist $x $p]
3105 if {[incr r] < $commitidx($curview)} {
3106 set p [lindex $displayorder $r]
3107 if {[lsearch -exact $idlist $p] < 0} {
3108 set fk [lindex $children($curview,$p) 0]
3109 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3110 set x [idcol $idlist $p $x]
3111 set idlist [linsert $idlist $x $p]
3117 if {$final && !$viewcomplete($curview) &&
3118 $row + $uparrowlen + $mingaplen + $downarrowlen
3119 >= $commitidx($curview)} {
3122 set l [llength $rowidlist]
3124 lappend rowidlist $idlist
3126 lappend rowfinal $final
3127 } elseif {$row < $l} {
3128 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3129 lset rowidlist $row $idlist
3132 lset rowfinal $row $final
3134 set pad [ntimes [expr {$row - $l}] {}]
3135 set rowidlist [concat $rowidlist $pad]
3136 lappend rowidlist $idlist
3137 set rowfinal [concat $rowfinal $pad]
3138 lappend rowfinal $final
3139 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3145 proc changedrow {row} {
3146 global displayorder iddrawn rowisopt need_redisplay
3148 set l [llength $rowisopt]
3150 lset rowisopt $row 0
3151 if {$row + 1 < $l} {
3152 lset rowisopt [expr {$row + 1}] 0
3153 if {$row + 2 < $l} {
3154 lset rowisopt [expr {$row + 2}] 0
3158 set id [lindex $displayorder $row]
3159 if {[info exists iddrawn($id)]} {
3160 set need_redisplay 1
3164 proc insert_pad {row col npad} {
3167 set pad [ntimes $npad {}]
3168 set idlist [lindex $rowidlist $row]
3169 set bef [lrange $idlist 0 [expr {$col - 1}]]
3170 set aft [lrange $idlist $col end]
3171 set i [lsearch -exact $aft {}]
3173 set aft [lreplace $aft $i $i]
3175 lset rowidlist $row [concat $bef $pad $aft]
3179 proc optimize_rows {row col endrow} {
3180 global rowidlist rowisopt displayorder curview children
3185 for {} {$row < $endrow} {incr row; set col 0} {
3186 if {[lindex $rowisopt $row]} continue
3188 set y0 [expr {$row - 1}]
3189 set ym [expr {$row - 2}]
3190 set idlist [lindex $rowidlist $row]
3191 set previdlist [lindex $rowidlist $y0]
3192 if {$idlist eq {} || $previdlist eq {}} continue
3194 set pprevidlist [lindex $rowidlist $ym]
3195 if {$pprevidlist eq {}} continue
3201 for {} {$col < [llength $idlist]} {incr col} {
3202 set id [lindex $idlist $col]
3203 if {[lindex $previdlist $col] eq $id} continue
3208 set x0 [lsearch -exact $previdlist $id]
3209 if {$x0 < 0} continue
3210 set z [expr {$x0 - $col}]
3214 set xm [lsearch -exact $pprevidlist $id]
3216 set z0 [expr {$xm - $x0}]
3220 # if row y0 is the first child of $id then it's not an arrow
3221 if {[lindex $children($curview,$id) 0] ne
3222 [lindex $displayorder $y0]} {
3226 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3227 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3230 # Looking at lines from this row to the previous row,
3231 # make them go straight up if they end in an arrow on
3232 # the previous row; otherwise make them go straight up
3234 if {$z < -1 || ($z < 0 && $isarrow)} {
3235 # Line currently goes left too much;
3236 # insert pads in the previous row, then optimize it
3237 set npad [expr {-1 - $z + $isarrow}]
3238 insert_pad $y0 $x0 $npad
3240 optimize_rows $y0 $x0 $row
3242 set previdlist [lindex $rowidlist $y0]
3243 set x0 [lsearch -exact $previdlist $id]
3244 set z [expr {$x0 - $col}]
3246 set pprevidlist [lindex $rowidlist $ym]
3247 set xm [lsearch -exact $pprevidlist $id]
3248 set z0 [expr {$xm - $x0}]
3250 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3251 # Line currently goes right too much;
3252 # insert pads in this line
3253 set npad [expr {$z - 1 + $isarrow}]
3254 insert_pad $row $col $npad
3255 set idlist [lindex $rowidlist $row]
3257 set z [expr {$x0 - $col}]
3260 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3261 # this line links to its first child on row $row-2
3262 set id [lindex $displayorder $ym]
3263 set xc [lsearch -exact $pprevidlist $id]
3265 set z0 [expr {$xc - $x0}]
3268 # avoid lines jigging left then immediately right
3269 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3270 insert_pad $y0 $x0 1
3272 optimize_rows $y0 $x0 $row
3273 set previdlist [lindex $rowidlist $y0]
3277 # Find the first column that doesn't have a line going right
3278 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3279 set id [lindex $idlist $col]
3280 if {$id eq {}} break
3281 set x0 [lsearch -exact $previdlist $id]
3283 # check if this is the link to the first child
3284 set kid [lindex $displayorder $y0]
3285 if {[lindex $children($curview,$id) 0] eq $kid} {
3286 # it is, work out offset to child
3287 set x0 [lsearch -exact $previdlist $kid]
3290 if {$x0 <= $col} break
3292 # Insert a pad at that column as long as it has a line and
3293 # isn't the last column
3294 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3295 set idlist [linsert $idlist $col {}]
3296 lset rowidlist $row $idlist
3304 global canvx0 linespc
3305 return [expr {$canvx0 + $col * $linespc}]
3309 global canvy0 linespc
3310 return [expr {$canvy0 + $row * $linespc}]
3313 proc linewidth {id} {
3314 global thickerline lthickness
3317 if {[info exists thickerline] && $id eq $thickerline} {
3318 set wid [expr {2 * $lthickness}]
3323 proc rowranges {id} {
3324 global commitrow curview children uparrowlen downarrowlen
3327 set kids $children($curview,$id)
3333 foreach child $kids {
3334 if {![info exists commitrow($curview,$child)]} break
3335 set row $commitrow($curview,$child)
3336 if {![info exists prev]} {
3337 lappend ret [expr {$row + 1}]
3339 if {$row <= $prevrow} {
3340 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3342 # see if the line extends the whole way from prevrow to row
3343 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3344 [lsearch -exact [lindex $rowidlist \
3345 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3346 # it doesn't, see where it ends
3347 set r [expr {$prevrow + $downarrowlen}]
3348 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3349 while {[incr r -1] > $prevrow &&
3350 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3352 while {[incr r] <= $row &&
3353 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3357 # see where it starts up again
3358 set r [expr {$row - $uparrowlen}]
3359 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3360 while {[incr r] < $row &&
3361 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3363 while {[incr r -1] >= $prevrow &&
3364 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3370 if {$child eq $id} {
3379 proc drawlineseg {id row endrow arrowlow} {
3380 global rowidlist displayorder iddrawn linesegs
3381 global canv colormap linespc curview maxlinelen parentlist
3383 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3384 set le [expr {$row + 1}]
3387 set c [lsearch -exact [lindex $rowidlist $le] $id]
3393 set x [lindex $displayorder $le]
3398 if {[info exists iddrawn($x)] || $le == $endrow} {
3399 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3415 if {[info exists linesegs($id)]} {
3416 set lines $linesegs($id)
3418 set r0 [lindex $li 0]
3420 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3430 set li [lindex $lines [expr {$i-1}]]
3431 set r1 [lindex $li 1]
3432 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3437 set x [lindex $cols [expr {$le - $row}]]
3438 set xp [lindex $cols [expr {$le - 1 - $row}]]
3439 set dir [expr {$xp - $x}]
3441 set ith [lindex $lines $i 2]
3442 set coords [$canv coords $ith]
3443 set ah [$canv itemcget $ith -arrow]
3444 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3445 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3446 if {$x2 ne {} && $x - $x2 == $dir} {
3447 set coords [lrange $coords 0 end-2]
3450 set coords [list [xc $le $x] [yc $le]]
3453 set itl [lindex $lines [expr {$i-1}] 2]
3454 set al [$canv itemcget $itl -arrow]
3455 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3456 } elseif {$arrowlow} {
3457 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3458 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3462 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3463 for {set y $le} {[incr y -1] > $row} {} {
3465 set xp [lindex $cols [expr {$y - 1 - $row}]]
3466 set ndir [expr {$xp - $x}]
3467 if {$dir != $ndir || $xp < 0} {
3468 lappend coords [xc $y $x] [yc $y]
3474 # join parent line to first child
3475 set ch [lindex $displayorder $row]
3476 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3478 puts "oops: drawlineseg: child $ch not on row $row"
3479 } elseif {$xc != $x} {
3480 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3481 set d [expr {int(0.5 * $linespc)}]
3484 set x2 [expr {$x1 - $d}]
3486 set x2 [expr {$x1 + $d}]
3489 set y1 [expr {$y2 + $d}]
3490 lappend coords $x1 $y1 $x2 $y2
3491 } elseif {$xc < $x - 1} {
3492 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3493 } elseif {$xc > $x + 1} {
3494 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3498 lappend coords [xc $row $x] [yc $row]
3500 set xn [xc $row $xp]
3502 lappend coords $xn $yn
3506 set t [$canv create line $coords -width [linewidth $id] \
3507 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3510 set lines [linsert $lines $i [list $row $le $t]]
3512 $canv coords $ith $coords
3513 if {$arrow ne $ah} {
3514 $canv itemconf $ith -arrow $arrow
3516 lset lines $i 0 $row
3519 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3520 set ndir [expr {$xo - $xp}]
3521 set clow [$canv coords $itl]
3522 if {$dir == $ndir} {
3523 set clow [lrange $clow 2 end]
3525 set coords [concat $coords $clow]
3527 lset lines [expr {$i-1}] 1 $le
3529 # coalesce two pieces
3531 set b [lindex $lines [expr {$i-1}] 0]
3532 set e [lindex $lines $i 1]
3533 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3535 $canv coords $itl $coords
3536 if {$arrow ne $al} {
3537 $canv itemconf $itl -arrow $arrow
3541 set linesegs($id) $lines
3545 proc drawparentlinks {id row} {
3546 global rowidlist canv colormap curview parentlist
3547 global idpos linespc
3549 set rowids [lindex $rowidlist $row]
3550 set col [lsearch -exact $rowids $id]
3551 if {$col < 0} return
3552 set olds [lindex $parentlist $row]
3553 set row2 [expr {$row + 1}]
3554 set x [xc $row $col]
3557 set d [expr {int(0.5 * $linespc)}]
3558 set ymid [expr {$y + $d}]
3559 set ids [lindex $rowidlist $row2]
3560 # rmx = right-most X coord used
3563 set i [lsearch -exact $ids $p]
3565 puts "oops, parent $p of $id not in list"
3568 set x2 [xc $row2 $i]
3572 set j [lsearch -exact $rowids $p]
3574 # drawlineseg will do this one for us
3578 # should handle duplicated parents here...
3579 set coords [list $x $y]
3581 # if attaching to a vertical segment, draw a smaller
3582 # slant for visual distinctness
3585 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3587 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3589 } elseif {$i < $col && $i < $j} {
3590 # segment slants towards us already
3591 lappend coords [xc $row $j] $y
3593 if {$i < $col - 1} {
3594 lappend coords [expr {$x2 + $linespc}] $y
3595 } elseif {$i > $col + 1} {
3596 lappend coords [expr {$x2 - $linespc}] $y
3598 lappend coords $x2 $y2
3601 lappend coords $x2 $y2
3603 set t [$canv create line $coords -width [linewidth $p] \
3604 -fill $colormap($p) -tags lines.$p]
3608 if {$rmx > [lindex $idpos($id) 1]} {
3609 lset idpos($id) 1 $rmx
3614 proc drawlines {id} {
3617 $canv itemconf lines.$id -width [linewidth $id]
3620 proc drawcmittext {id row col} {
3621 global linespc canv canv2 canv3 canvy0 fgcolor curview
3622 global commitlisted commitinfo rowidlist parentlist
3623 global rowtextx idpos idtags idheads idotherrefs
3624 global linehtag linentag linedtag selectedline
3625 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3627 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3628 set listed [lindex $commitlisted $row]
3629 if {$id eq $nullid} {
3631 } elseif {$id eq $nullid2} {
3634 set ofill [expr {$listed != 0? "blue": "white"}]
3636 set x [xc $row $col]
3638 set orad [expr {$linespc / 3}]
3640 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3641 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3642 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3643 } elseif {$listed == 2} {
3644 # triangle pointing left for left-side commits
3645 set t [$canv create polygon \
3646 [expr {$x - $orad}] $y \
3647 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3648 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3649 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3651 # triangle pointing right for right-side commits
3652 set t [$canv create polygon \
3653 [expr {$x + $orad - 1}] $y \
3654 [expr {$x - $orad}] [expr {$y - $orad}] \
3655 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3656 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3659 $canv bind $t <1> {selcanvline {} %x %y}
3660 set rmx [llength [lindex $rowidlist $row]]
3661 set olds [lindex $parentlist $row]
3663 set nextids [lindex $rowidlist [expr {$row + 1}]]
3665 set i [lsearch -exact $nextids $p]
3671 set xt [xc $row $rmx]
3672 set rowtextx($row) $xt
3673 set idpos($id) [list $x $xt $y]
3674 if {[info exists idtags($id)] || [info exists idheads($id)]
3675 || [info exists idotherrefs($id)]} {
3676 set xt [drawtags $id $x $xt $y]
3678 set headline [lindex $commitinfo($id) 0]
3679 set name [lindex $commitinfo($id) 1]
3680 set date [lindex $commitinfo($id) 2]
3681 set date [formatdate $date]
3684 set isbold [ishighlighted $row]
3686 lappend boldrows $row
3687 set font mainfontbold
3689 lappend boldnamerows $row
3690 set nfont mainfontbold
3693 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3694 -text $headline -font $font -tags text]
3695 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3696 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3697 -text $name -font $nfont -tags text]
3698 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3699 -text $date -font mainfont -tags text]
3700 if {[info exists selectedline] && $selectedline == $row} {
3703 set xr [expr {$xt + [font measure $font $headline]}]
3704 if {$xr > $canvxmax} {
3710 proc drawcmitrow {row} {
3711 global displayorder rowidlist nrows_drawn
3712 global iddrawn markingmatches
3713 global commitinfo parentlist numcommits
3714 global filehighlight fhighlights findpattern nhighlights
3715 global hlview vhighlights
3716 global highlight_related rhighlights
3718 if {$row >= $numcommits} return
3720 set id [lindex $displayorder $row]
3721 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3722 askvhighlight $row $id
3724 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3725 askfilehighlight $row $id
3727 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3728 askfindhighlight $row $id
3730 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3731 askrelhighlight $row $id
3733 if {![info exists iddrawn($id)]} {
3734 set col [lsearch -exact [lindex $rowidlist $row] $id]
3736 puts "oops, row $row id $id not in list"
3739 if {![info exists commitinfo($id)]} {
3743 drawcmittext $id $row $col
3747 if {$markingmatches} {
3748 markrowmatches $row $id
3752 proc drawcommits {row {endrow {}}} {
3753 global numcommits iddrawn displayorder curview need_redisplay
3754 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3759 if {$endrow eq {}} {
3762 if {$endrow >= $numcommits} {
3763 set endrow [expr {$numcommits - 1}]
3766 set rl1 [expr {$row - $downarrowlen - 3}]
3770 set ro1 [expr {$row - 3}]
3774 set r2 [expr {$endrow + $uparrowlen + 3}]
3775 if {$r2 > $numcommits} {
3778 for {set r $rl1} {$r < $r2} {incr r} {
3779 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3783 set rl1 [expr {$r + 1}]
3789 optimize_rows $ro1 0 $r2
3790 if {$need_redisplay || $nrows_drawn > 2000} {
3795 # make the lines join to already-drawn rows either side
3796 set r [expr {$row - 1}]
3797 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3800 set er [expr {$endrow + 1}]
3801 if {$er >= $numcommits ||
3802 ![info exists iddrawn([lindex $displayorder $er])]} {
3805 for {} {$r <= $er} {incr r} {
3806 set id [lindex $displayorder $r]
3807 set wasdrawn [info exists iddrawn($id)]
3809 if {$r == $er} break
3810 set nextid [lindex $displayorder [expr {$r + 1}]]
3811 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3812 catch {unset prevlines}
3815 drawparentlinks $id $r
3817 if {[info exists lineends($r)]} {
3818 foreach lid $lineends($r) {
3819 unset prevlines($lid)
3822 set rowids [lindex $rowidlist $r]
3823 foreach lid $rowids {
3824 if {$lid eq {}} continue
3826 # see if this is the first child of any of its parents
3827 foreach p [lindex $parentlist $r] {
3828 if {[lsearch -exact $rowids $p] < 0} {
3829 # make this line extend up to the child
3830 set le [drawlineseg $p $r $er 0]
3831 lappend lineends($le) $p
3835 } elseif {![info exists prevlines($lid)]} {
3836 set le [drawlineseg $lid $r $er 1]
3837 lappend lineends($le) $lid
3838 set prevlines($lid) 1
3844 proc drawfrac {f0 f1} {
3847 set ymax [lindex [$canv cget -scrollregion] 3]
3848 if {$ymax eq {} || $ymax == 0} return
3849 set y0 [expr {int($f0 * $ymax)}]
3850 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3851 set y1 [expr {int($f1 * $ymax)}]
3852 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3853 drawcommits $row $endrow
3856 proc drawvisible {} {
3858 eval drawfrac [$canv yview]
3861 proc clear_display {} {
3862 global iddrawn linesegs need_redisplay nrows_drawn
3863 global vhighlights fhighlights nhighlights rhighlights
3866 catch {unset iddrawn}
3867 catch {unset linesegs}
3868 catch {unset vhighlights}
3869 catch {unset fhighlights}
3870 catch {unset nhighlights}
3871 catch {unset rhighlights}
3872 set need_redisplay 0
3876 proc findcrossings {id} {
3877 global rowidlist parentlist numcommits displayorder
3881 foreach {s e} [rowranges $id] {
3882 if {$e >= $numcommits} {
3883 set e [expr {$numcommits - 1}]
3885 if {$e <= $s} continue
3886 for {set row $e} {[incr row -1] >= $s} {} {
3887 set x [lsearch -exact [lindex $rowidlist $row] $id]
3889 set olds [lindex $parentlist $row]
3890 set kid [lindex $displayorder $row]
3891 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3892 if {$kidx < 0} continue
3893 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3895 set px [lsearch -exact $nextrow $p]
3896 if {$px < 0} continue
3897 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3898 if {[lsearch -exact $ccross $p] >= 0} continue
3899 if {$x == $px + ($kidx < $px? -1: 1)} {
3901 } elseif {[lsearch -exact $cross $p] < 0} {
3908 return [concat $ccross {{}} $cross]
3911 proc assigncolor {id} {
3912 global colormap colors nextcolor
3913 global commitrow parentlist children children curview
3915 if {[info exists colormap($id)]} return
3916 set ncolors [llength $colors]
3917 if {[info exists children($curview,$id)]} {
3918 set kids $children($curview,$id)
3922 if {[llength $kids] == 1} {
3923 set child [lindex $kids 0]
3924 if {[info exists colormap($child)]
3925 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3926 set colormap($id) $colormap($child)
3932 foreach x [findcrossings $id] {
3934 # delimiter between corner crossings and other crossings
3935 if {[llength $badcolors] >= $ncolors - 1} break
3936 set origbad $badcolors
3938 if {[info exists colormap($x)]
3939 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3940 lappend badcolors $colormap($x)
3943 if {[llength $badcolors] >= $ncolors} {
3944 set badcolors $origbad
3946 set origbad $badcolors
3947 if {[llength $badcolors] < $ncolors - 1} {
3948 foreach child $kids {
3949 if {[info exists colormap($child)]
3950 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3951 lappend badcolors $colormap($child)
3953 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3954 if {[info exists colormap($p)]
3955 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3956 lappend badcolors $colormap($p)
3960 if {[llength $badcolors] >= $ncolors} {
3961 set badcolors $origbad
3964 for {set i 0} {$i <= $ncolors} {incr i} {
3965 set c [lindex $colors $nextcolor]
3966 if {[incr nextcolor] >= $ncolors} {
3969 if {[lsearch -exact $badcolors $c]} break
3971 set colormap($id) $c
3974 proc bindline {t id} {
3977 $canv bind $t <Enter> "lineenter %x %y $id"
3978 $canv bind $t <Motion> "linemotion %x %y $id"
3979 $canv bind $t <Leave> "lineleave $id"
3980 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3983 proc drawtags {id x xt y1} {
3984 global idtags idheads idotherrefs mainhead
3985 global linespc lthickness
3986 global canv commitrow rowtextx curview fgcolor bgcolor
3991 if {[info exists idtags($id)]} {
3992 set marks $idtags($id)
3993 set ntags [llength $marks]
3995 if {[info exists idheads($id)]} {
3996 set marks [concat $marks $idheads($id)]
3997 set nheads [llength $idheads($id)]
3999 if {[info exists idotherrefs($id)]} {
4000 set marks [concat $marks $idotherrefs($id)]
4006 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4007 set yt [expr {$y1 - 0.5 * $linespc}]
4008 set yb [expr {$yt + $linespc - 1}]
4012 foreach tag $marks {
4014 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4015 set wid [font measure mainfontbold $tag]
4017 set wid [font measure mainfont $tag]
4021 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4023 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4024 -width $lthickness -fill black -tags tag.$id]
4026 foreach tag $marks x $xvals wid $wvals {
4027 set xl [expr {$x + $delta}]
4028 set xr [expr {$x + $delta + $wid + $lthickness}]
4030 if {[incr ntags -1] >= 0} {
4032 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4033 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4034 -width 1 -outline black -fill yellow -tags tag.$id]
4035 $canv bind $t <1> [list showtag $tag 1]
4036 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4038 # draw a head or other ref
4039 if {[incr nheads -1] >= 0} {
4041 if {$tag eq $mainhead} {
4042 set font mainfontbold
4047 set xl [expr {$xl - $delta/2}]
4048 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4049 -width 1 -outline black -fill $col -tags tag.$id
4050 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4051 set rwid [font measure mainfont $remoteprefix]
4052 set xi [expr {$x + 1}]
4053 set yti [expr {$yt + 1}]
4054 set xri [expr {$x + $rwid}]
4055 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4056 -width 0 -fill "#ffddaa" -tags tag.$id
4059 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4060 -font $font -tags [list tag.$id text]]
4062 $canv bind $t <1> [list showtag $tag 1]
4063 } elseif {$nheads >= 0} {
4064 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4070 proc xcoord {i level ln} {
4071 global canvx0 xspc1 xspc2
4073 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4074 if {$i > 0 && $i == $level} {
4075 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4076 } elseif {$i > $level} {
4077 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4082 proc show_status {msg} {
4086 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4087 -tags text -fill $fgcolor
4090 # Insert a new commit as the child of the commit on row $row.
4091 # The new commit will be displayed on row $row and the commits
4092 # on that row and below will move down one row.
4093 proc insertrow {row newcmit} {
4094 global displayorder parentlist commitlisted children
4095 global commitrow curview rowidlist rowisopt rowfinal numcommits
4097 global selectedline commitidx ordertok
4099 if {$row >= $numcommits} {
4100 puts "oops, inserting new row $row but only have $numcommits rows"
4103 set p [lindex $displayorder $row]
4104 set displayorder [linsert $displayorder $row $newcmit]
4105 set parentlist [linsert $parentlist $row $p]
4106 set kids $children($curview,$p)
4107 lappend kids $newcmit
4108 set children($curview,$p) $kids
4109 set children($curview,$newcmit) {}
4110 set commitlisted [linsert $commitlisted $row 1]
4111 set l [llength $displayorder]
4112 for {set r $row} {$r < $l} {incr r} {
4113 set id [lindex $displayorder $r]
4114 set commitrow($curview,$id) $r
4116 incr commitidx($curview)
4117 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4119 if {$row < [llength $rowidlist]} {
4120 set idlist [lindex $rowidlist $row]
4121 if {$idlist ne {}} {
4122 if {[llength $kids] == 1} {
4123 set col [lsearch -exact $idlist $p]
4124 lset idlist $col $newcmit
4126 set col [llength $idlist]
4127 lappend idlist $newcmit
4130 set rowidlist [linsert $rowidlist $row $idlist]
4131 set rowisopt [linsert $rowisopt $row 0]
4132 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4137 if {[info exists selectedline] && $selectedline >= $row} {
4143 # Remove a commit that was inserted with insertrow on row $row.
4144 proc removerow {row} {
4145 global displayorder parentlist commitlisted children
4146 global commitrow curview rowidlist rowisopt rowfinal numcommits
4148 global linesegends selectedline commitidx
4150 if {$row >= $numcommits} {
4151 puts "oops, removing row $row but only have $numcommits rows"
4154 set rp1 [expr {$row + 1}]
4155 set id [lindex $displayorder $row]
4156 set p [lindex $parentlist $row]
4157 set displayorder [lreplace $displayorder $row $row]
4158 set parentlist [lreplace $parentlist $row $row]
4159 set commitlisted [lreplace $commitlisted $row $row]
4160 set kids $children($curview,$p)
4161 set i [lsearch -exact $kids $id]
4163 set kids [lreplace $kids $i $i]
4164 set children($curview,$p) $kids
4166 set l [llength $displayorder]
4167 for {set r $row} {$r < $l} {incr r} {
4168 set id [lindex $displayorder $r]
4169 set commitrow($curview,$id) $r
4171 incr commitidx($curview) -1
4173 if {$row < [llength $rowidlist]} {
4174 set rowidlist [lreplace $rowidlist $row $row]
4175 set rowisopt [lreplace $rowisopt $row $row]
4176 set rowfinal [lreplace $rowfinal $row $row]
4181 if {[info exists selectedline] && $selectedline > $row} {
4182 incr selectedline -1
4187 # Don't change the text pane cursor if it is currently the hand cursor,
4188 # showing that we are over a sha1 ID link.
4189 proc settextcursor {c} {
4190 global ctext curtextcursor
4192 if {[$ctext cget -cursor] == $curtextcursor} {
4193 $ctext config -cursor $c
4195 set curtextcursor $c
4198 proc nowbusy {what} {
4201 if {[array names isbusy] eq {}} {
4202 . config -cursor watch
4208 proc notbusy {what} {
4209 global isbusy maincursor textcursor
4211 catch {unset isbusy($what)}
4212 if {[array names isbusy] eq {}} {
4213 . config -cursor $maincursor
4214 settextcursor $textcursor
4218 proc findmatches {f} {
4219 global findtype findstring
4220 if {$findtype == "Regexp"} {
4221 set matches [regexp -indices -all -inline $findstring $f]
4224 if {$findtype == "IgnCase"} {
4225 set f [string tolower $f]
4226 set fs [string tolower $fs]
4230 set l [string length $fs]
4231 while {[set j [string first $fs $f $i]] >= 0} {
4232 lappend matches [list $j [expr {$j+$l-1}]]
4233 set i [expr {$j + $l}]
4239 proc dofind {{rev 0}} {
4240 global findstring findstartline findcurline selectedline numcommits
4241 global gdttype filehighlight fh_serial find_dirn
4245 if {$findstring eq {} || $numcommits == 0} return
4246 if {![info exists selectedline]} {
4247 set findstartline [lindex [visiblerows] $rev]
4249 set findstartline $selectedline
4251 set findcurline $findstartline
4253 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4254 after cancel do_file_hl $fh_serial
4255 do_file_hl $fh_serial
4266 proc stopfinding {} {
4267 global find_dirn findcurline fprogcoord
4269 if {[info exists find_dirn]} {
4278 proc findnext {restart} {
4279 global findcurline find_dirn
4281 if {[info exists find_dirn]} return
4283 if {![info exists findcurline]} {
4296 global findcurline find_dirn
4298 if {[info exists find_dirn]} return
4300 if {![info exists findcurline]} {
4309 global commitdata commitinfo numcommits findpattern findloc
4310 global findstartline findcurline displayorder
4311 global find_dirn gdttype fhighlights fprogcoord
4313 if {![info exists find_dirn]} {
4316 set fldtypes {Headline Author Date Committer CDate Comments}
4317 set l [expr {$findcurline + 1}]
4318 if {$l >= $numcommits} {
4321 if {$l <= $findstartline} {
4322 set lim [expr {$findstartline + 1}]
4326 if {$lim - $l > 500} {
4327 set lim [expr {$l + 500}]
4331 if {$gdttype eq "containing:"} {
4332 for {} {$l < $lim} {incr l} {
4333 set id [lindex $displayorder $l]
4334 # shouldn't happen unless git log doesn't give all the commits...
4335 if {![info exists commitdata($id)]} continue
4336 if {![doesmatch $commitdata($id)]} continue
4337 if {![info exists commitinfo($id)]} {
4340 set info $commitinfo($id)
4341 foreach f $info ty $fldtypes {
4342 if {($findloc eq "All fields" || $findloc eq $ty) &&
4351 for {} {$l < $lim} {incr l} {
4352 set id [lindex $displayorder $l]
4353 if {![info exists fhighlights($l)]} {
4354 askfilehighlight $l $id
4357 set findcurline [expr {$l - 1}]
4359 } elseif {$fhighlights($l)} {
4365 if {$found || ($domore && $l == $findstartline + 1)} {
4381 set findcurline [expr {$l - 1}]
4383 set n [expr {$findcurline - ($findstartline + 1)}]
4387 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4392 proc findmorerev {} {
4393 global commitdata commitinfo numcommits findpattern findloc
4394 global findstartline findcurline displayorder
4395 global find_dirn gdttype fhighlights fprogcoord
4397 if {![info exists find_dirn]} {
4400 set fldtypes {Headline Author Date Committer CDate Comments}
4406 if {$l >= $findstartline} {
4407 set lim [expr {$findstartline - 1}]
4411 if {$l - $lim > 500} {
4412 set lim [expr {$l - 500}]
4416 if {$gdttype eq "containing:"} {
4417 for {} {$l > $lim} {incr l -1} {
4418 set id [lindex $displayorder $l]
4419 if {![info exists commitdata($id)]} continue
4420 if {![doesmatch $commitdata($id)]} continue
4421 if {![info exists commitinfo($id)]} {
4424 set info $commitinfo($id)
4425 foreach f $info ty $fldtypes {
4426 if {($findloc eq "All fields" || $findloc eq $ty) &&
4435 for {} {$l > $lim} {incr l -1} {
4436 set id [lindex $displayorder $l]
4437 if {![info exists fhighlights($l)]} {
4438 askfilehighlight $l $id
4441 set findcurline [expr {$l + 1}]
4443 } elseif {$fhighlights($l)} {
4449 if {$found || ($domore && $l == $findstartline - 1)} {
4465 set findcurline [expr {$l + 1}]
4467 set n [expr {($findstartline - 1) - $findcurline}]
4471 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4476 proc findselectline {l} {
4477 global findloc commentend ctext findcurline markingmatches gdttype
4479 set markingmatches 1
4482 if {$findloc == "All fields" || $findloc == "Comments"} {
4483 # highlight the matches in the comments
4484 set f [$ctext get 1.0 $commentend]
4485 set matches [findmatches $f]
4486 foreach match $matches {
4487 set start [lindex $match 0]
4488 set end [expr {[lindex $match 1] + 1}]
4489 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4495 # mark the bits of a headline or author that match a find string
4496 proc markmatches {canv l str tag matches font row} {
4499 set bbox [$canv bbox $tag]
4500 set x0 [lindex $bbox 0]
4501 set y0 [lindex $bbox 1]
4502 set y1 [lindex $bbox 3]
4503 foreach match $matches {
4504 set start [lindex $match 0]
4505 set end [lindex $match 1]
4506 if {$start > $end} continue
4507 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4508 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4509 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4510 [expr {$x0+$xlen+2}] $y1 \
4511 -outline {} -tags [list match$l matches] -fill yellow]
4513 if {[info exists selectedline] && $row == $selectedline} {
4514 $canv raise $t secsel
4519 proc unmarkmatches {} {
4520 global markingmatches
4522 allcanvs delete matches
4523 set markingmatches 0
4527 proc selcanvline {w x y} {
4528 global canv canvy0 ctext linespc
4530 set ymax [lindex [$canv cget -scrollregion] 3]
4531 if {$ymax == {}} return
4532 set yfrac [lindex [$canv yview] 0]
4533 set y [expr {$y + $yfrac * $ymax}]
4534 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4539 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4545 proc commit_descriptor {p} {
4547 if {![info exists commitinfo($p)]} {
4551 if {[llength $commitinfo($p)] > 1} {
4552 set l [lindex $commitinfo($p) 0]
4557 # append some text to the ctext widget, and make any SHA1 ID
4558 # that we know about be a clickable link.
4559 proc appendwithlinks {text tags} {
4560 global ctext commitrow linknum curview pendinglinks
4562 set start [$ctext index "end - 1c"]
4563 $ctext insert end $text $tags
4564 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4568 set linkid [string range $text $s $e]
4570 $ctext tag delete link$linknum
4571 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4572 setlink $linkid link$linknum
4577 proc setlink {id lk} {
4578 global curview commitrow ctext pendinglinks commitinterest
4580 if {[info exists commitrow($curview,$id)]} {
4581 $ctext tag conf $lk -foreground blue -underline 1
4582 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4583 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4584 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4586 lappend pendinglinks($id) $lk
4587 lappend commitinterest($id) {makelink %I}
4591 proc makelink {id} {
4594 if {![info exists pendinglinks($id)]} return
4595 foreach lk $pendinglinks($id) {
4598 unset pendinglinks($id)
4601 proc linkcursor {w inc} {
4602 global linkentercount curtextcursor
4604 if {[incr linkentercount $inc] > 0} {
4605 $w configure -cursor hand2
4607 $w configure -cursor $curtextcursor
4608 if {$linkentercount < 0} {
4609 set linkentercount 0
4614 proc viewnextline {dir} {
4618 set ymax [lindex [$canv cget -scrollregion] 3]
4619 set wnow [$canv yview]
4620 set wtop [expr {[lindex $wnow 0] * $ymax}]
4621 set newtop [expr {$wtop + $dir * $linespc}]
4624 } elseif {$newtop > $ymax} {
4627 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4630 # add a list of tag or branch names at position pos
4631 # returns the number of names inserted
4632 proc appendrefs {pos ids var} {
4633 global ctext commitrow linknum curview $var maxrefs
4635 if {[catch {$ctext index $pos}]} {
4638 $ctext conf -state normal
4639 $ctext delete $pos "$pos lineend"
4642 foreach tag [set $var\($id\)] {
4643 lappend tags [list $tag $id]
4646 if {[llength $tags] > $maxrefs} {
4647 $ctext insert $pos "many ([llength $tags])"
4649 set tags [lsort -index 0 -decreasing $tags]
4652 set id [lindex $ti 1]
4655 $ctext tag delete $lk
4656 $ctext insert $pos $sep
4657 $ctext insert $pos [lindex $ti 0] $lk
4662 $ctext conf -state disabled
4663 return [llength $tags]
4666 # called when we have finished computing the nearby tags
4667 proc dispneartags {delay} {
4668 global selectedline currentid showneartags tagphase
4670 if {![info exists selectedline] || !$showneartags} return
4671 after cancel dispnexttag
4673 after 200 dispnexttag
4676 after idle dispnexttag
4681 proc dispnexttag {} {
4682 global selectedline currentid showneartags tagphase ctext
4684 if {![info exists selectedline] || !$showneartags} return
4685 switch -- $tagphase {
4687 set dtags [desctags $currentid]
4689 appendrefs precedes $dtags idtags
4693 set atags [anctags $currentid]
4695 appendrefs follows $atags idtags
4699 set dheads [descheads $currentid]
4700 if {$dheads ne {}} {
4701 if {[appendrefs branch $dheads idheads] > 1
4702 && [$ctext get "branch -3c"] eq "h"} {
4703 # turn "Branch" into "Branches"
4704 $ctext conf -state normal
4705 $ctext insert "branch -2c" "es"
4706 $ctext conf -state disabled
4711 if {[incr tagphase] <= 2} {
4712 after idle dispnexttag
4716 proc make_secsel {l} {
4717 global linehtag linentag linedtag canv canv2 canv3
4719 if {![info exists linehtag($l)]} return
4721 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4722 -tags secsel -fill [$canv cget -selectbackground]]
4724 $canv2 delete secsel
4725 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4726 -tags secsel -fill [$canv2 cget -selectbackground]]
4728 $canv3 delete secsel
4729 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4730 -tags secsel -fill [$canv3 cget -selectbackground]]
4734 proc selectline {l isnew} {
4735 global canv ctext commitinfo selectedline
4737 global canvy0 linespc parentlist children curview
4738 global currentid sha1entry
4739 global commentend idtags linknum
4740 global mergemax numcommits pending_select
4741 global cmitmode showneartags allcommits
4743 catch {unset pending_select}
4748 if {$l < 0 || $l >= $numcommits} return
4749 set y [expr {$canvy0 + $l * $linespc}]
4750 set ymax [lindex [$canv cget -scrollregion] 3]
4751 set ytop [expr {$y - $linespc - 1}]
4752 set ybot [expr {$y + $linespc + 1}]
4753 set wnow [$canv yview]
4754 set wtop [expr {[lindex $wnow 0] * $ymax}]
4755 set wbot [expr {[lindex $wnow 1] * $ymax}]
4756 set wh [expr {$wbot - $wtop}]
4758 if {$ytop < $wtop} {
4759 if {$ybot < $wtop} {
4760 set newtop [expr {$y - $wh / 2.0}]
4763 if {$newtop > $wtop - $linespc} {
4764 set newtop [expr {$wtop - $linespc}]
4767 } elseif {$ybot > $wbot} {
4768 if {$ytop > $wbot} {
4769 set newtop [expr {$y - $wh / 2.0}]
4771 set newtop [expr {$ybot - $wh}]
4772 if {$newtop < $wtop + $linespc} {
4773 set newtop [expr {$wtop + $linespc}]
4777 if {$newtop != $wtop} {
4781 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4788 addtohistory [list selectline $l 0]
4793 set id [lindex $displayorder $l]
4795 $sha1entry delete 0 end
4796 $sha1entry insert 0 $id
4797 $sha1entry selection from 0
4798 $sha1entry selection to end
4801 $ctext conf -state normal
4804 set info $commitinfo($id)
4805 set date [formatdate [lindex $info 2]]
4806 $ctext insert end "Author: [lindex $info 1] $date\n"
4807 set date [formatdate [lindex $info 4]]
4808 $ctext insert end "Committer: [lindex $info 3] $date\n"
4809 if {[info exists idtags($id)]} {
4810 $ctext insert end "Tags:"
4811 foreach tag $idtags($id) {
4812 $ctext insert end " $tag"
4814 $ctext insert end "\n"
4818 set olds [lindex $parentlist $l]
4819 if {[llength $olds] > 1} {
4822 if {$np >= $mergemax} {
4827 $ctext insert end "Parent: " $tag
4828 appendwithlinks [commit_descriptor $p] {}
4833 append headers "Parent: [commit_descriptor $p]"
4837 foreach c $children($curview,$id) {
4838 append headers "Child: [commit_descriptor $c]"
4841 # make anything that looks like a SHA1 ID be a clickable link
4842 appendwithlinks $headers {}
4843 if {$showneartags} {
4844 if {![info exists allcommits]} {
4847 $ctext insert end "Branch: "
4848 $ctext mark set branch "end -1c"
4849 $ctext mark gravity branch left
4850 $ctext insert end "\nFollows: "
4851 $ctext mark set follows "end -1c"
4852 $ctext mark gravity follows left
4853 $ctext insert end "\nPrecedes: "
4854 $ctext mark set precedes "end -1c"
4855 $ctext mark gravity precedes left
4856 $ctext insert end "\n"
4859 $ctext insert end "\n"
4860 set comment [lindex $info 5]
4861 if {[string first "\r" $comment] >= 0} {
4862 set comment [string map {"\r" "\n "} $comment]
4864 appendwithlinks $comment {comment}
4866 $ctext tag remove found 1.0 end
4867 $ctext conf -state disabled
4868 set commentend [$ctext index "end - 1c"]
4870 init_flist "Comments"
4871 if {$cmitmode eq "tree"} {
4873 } elseif {[llength $olds] <= 1} {
4880 proc selfirstline {} {
4885 proc sellastline {} {
4888 set l [expr {$numcommits - 1}]
4892 proc selnextline {dir} {
4895 if {![info exists selectedline]} return
4896 set l [expr {$selectedline + $dir}]
4901 proc selnextpage {dir} {
4902 global canv linespc selectedline numcommits
4904 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4908 allcanvs yview scroll [expr {$dir * $lpp}] units
4910 if {![info exists selectedline]} return
4911 set l [expr {$selectedline + $dir * $lpp}]
4914 } elseif {$l >= $numcommits} {
4915 set l [expr $numcommits - 1]
4921 proc unselectline {} {
4922 global selectedline currentid
4924 catch {unset selectedline}
4925 catch {unset currentid}
4926 allcanvs delete secsel
4930 proc reselectline {} {
4933 if {[info exists selectedline]} {
4934 selectline $selectedline 0
4938 proc addtohistory {cmd} {
4939 global history historyindex curview
4941 set elt [list $curview $cmd]
4942 if {$historyindex > 0
4943 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4947 if {$historyindex < [llength $history]} {
4948 set history [lreplace $history $historyindex end $elt]
4950 lappend history $elt
4953 if {$historyindex > 1} {
4954 .tf.bar.leftbut conf -state normal
4956 .tf.bar.leftbut conf -state disabled
4958 .tf.bar.rightbut conf -state disabled
4964 set view [lindex $elt 0]
4965 set cmd [lindex $elt 1]
4966 if {$curview != $view} {
4973 global history historyindex
4976 if {$historyindex > 1} {
4977 incr historyindex -1
4978 godo [lindex $history [expr {$historyindex - 1}]]
4979 .tf.bar.rightbut conf -state normal
4981 if {$historyindex <= 1} {
4982 .tf.bar.leftbut conf -state disabled
4987 global history historyindex
4990 if {$historyindex < [llength $history]} {
4991 set cmd [lindex $history $historyindex]
4994 .tf.bar.leftbut conf -state normal
4996 if {$historyindex >= [llength $history]} {
4997 .tf.bar.rightbut conf -state disabled
5002 global treefilelist treeidlist diffids diffmergeid treepending
5003 global nullid nullid2
5006 catch {unset diffmergeid}
5007 if {![info exists treefilelist($id)]} {
5008 if {![info exists treepending]} {
5009 if {$id eq $nullid} {
5010 set cmd [list | git ls-files]
5011 } elseif {$id eq $nullid2} {
5012 set cmd [list | git ls-files --stage -t]
5014 set cmd [list | git ls-tree -r $id]
5016 if {[catch {set gtf [open $cmd r]}]} {
5020 set treefilelist($id) {}
5021 set treeidlist($id) {}
5022 fconfigure $gtf -blocking 0
5023 filerun $gtf [list gettreeline $gtf $id]
5030 proc gettreeline {gtf id} {
5031 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5034 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5035 if {$diffids eq $nullid} {
5038 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5039 set i [string first "\t" $line]
5040 if {$i < 0} continue
5041 set sha1 [lindex $line 2]
5042 set fname [string range $line [expr {$i+1}] end]
5043 if {[string index $fname 0] eq "\""} {
5044 set fname [lindex $fname 0]
5046 lappend treeidlist($id) $sha1
5048 lappend treefilelist($id) $fname
5051 return [expr {$nl >= 1000? 2: 1}]
5055 if {$cmitmode ne "tree"} {
5056 if {![info exists diffmergeid]} {
5057 gettreediffs $diffids
5059 } elseif {$id ne $diffids} {
5068 global treefilelist treeidlist diffids nullid nullid2
5069 global ctext commentend
5071 set i [lsearch -exact $treefilelist($diffids) $f]
5073 puts "oops, $f not in list for id $diffids"
5076 if {$diffids eq $nullid} {
5077 if {[catch {set bf [open $f r]} err]} {
5078 puts "oops, can't read $f: $err"
5082 set blob [lindex $treeidlist($diffids) $i]
5083 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5084 puts "oops, error reading blob $blob: $err"
5088 fconfigure $bf -blocking 0
5089 filerun $bf [list getblobline $bf $diffids]
5090 $ctext config -state normal
5091 clear_ctext $commentend
5092 $ctext insert end "\n"
5093 $ctext insert end "$f\n" filesep
5094 $ctext config -state disabled
5095 $ctext yview $commentend
5099 proc getblobline {bf id} {
5100 global diffids cmitmode ctext
5102 if {$id ne $diffids || $cmitmode ne "tree"} {
5106 $ctext config -state normal
5108 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5109 $ctext insert end "$line\n"
5112 # delete last newline
5113 $ctext delete "end - 2c" "end - 1c"
5117 $ctext config -state disabled
5118 return [expr {$nl >= 1000? 2: 1}]
5121 proc mergediff {id l} {
5122 global diffmergeid diffopts mdifffd
5128 # this doesn't seem to actually affect anything...
5129 set env(GIT_DIFF_OPTS) $diffopts
5130 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5131 if {[catch {set mdf [open $cmd r]} err]} {
5132 error_popup "Error getting merge diffs: $err"
5135 fconfigure $mdf -blocking 0
5136 set mdifffd($id) $mdf
5137 set np [llength [lindex $parentlist $l]]
5139 filerun $mdf [list getmergediffline $mdf $id $np]
5142 proc getmergediffline {mdf id np} {
5143 global diffmergeid ctext cflist mergemax
5144 global difffilestart mdifffd
5146 $ctext conf -state normal
5148 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5149 if {![info exists diffmergeid] || $id != $diffmergeid
5150 || $mdf != $mdifffd($id)} {
5154 if {[regexp {^diff --cc (.*)} $line match fname]} {
5155 # start of a new file
5156 $ctext insert end "\n"
5157 set here [$ctext index "end - 1c"]
5158 lappend difffilestart $here
5159 add_flist [list $fname]
5160 set l [expr {(78 - [string length $fname]) / 2}]
5161 set pad [string range "----------------------------------------" 1 $l]
5162 $ctext insert end "$pad $fname $pad\n" filesep
5163 } elseif {[regexp {^@@} $line]} {
5164 $ctext insert end "$line\n" hunksep
5165 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5168 # parse the prefix - one ' ', '-' or '+' for each parent
5173 for {set j 0} {$j < $np} {incr j} {
5174 set c [string range $line $j $j]
5177 } elseif {$c == "-"} {
5179 } elseif {$c == "+"} {
5188 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5189 # line doesn't appear in result, parents in $minuses have the line
5190 set num [lindex $minuses 0]
5191 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5192 # line appears in result, parents in $pluses don't have the line
5193 lappend tags mresult
5194 set num [lindex $spaces 0]
5197 if {$num >= $mergemax} {
5202 $ctext insert end "$line\n" $tags
5205 $ctext conf -state disabled
5210 return [expr {$nr >= 1000? 2: 1}]
5213 proc startdiff {ids} {
5214 global treediffs diffids treepending diffmergeid nullid nullid2
5218 catch {unset diffmergeid}
5219 if {![info exists treediffs($ids)] ||
5220 [lsearch -exact $ids $nullid] >= 0 ||
5221 [lsearch -exact $ids $nullid2] >= 0} {
5222 if {![info exists treepending]} {
5230 proc addtocflist {ids} {
5231 global treediffs cflist
5232 add_flist $treediffs($ids)
5236 proc diffcmd {ids flags} {
5237 global nullid nullid2
5239 set i [lsearch -exact $ids $nullid]
5240 set j [lsearch -exact $ids $nullid2]
5242 if {[llength $ids] > 1 && $j < 0} {
5243 # comparing working directory with some specific revision
5244 set cmd [concat | git diff-index $flags]
5246 lappend cmd -R [lindex $ids 1]
5248 lappend cmd [lindex $ids 0]
5251 # comparing working directory with index
5252 set cmd [concat | git diff-files $flags]
5257 } elseif {$j >= 0} {
5258 set cmd [concat | git diff-index --cached $flags]
5259 if {[llength $ids] > 1} {
5260 # comparing index with specific revision
5262 lappend cmd -R [lindex $ids 1]
5264 lappend cmd [lindex $ids 0]
5267 # comparing index with HEAD
5271 set cmd [concat | git diff-tree -r $flags $ids]
5276 proc gettreediffs {ids} {
5277 global treediff treepending
5279 set treepending $ids
5281 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5282 fconfigure $gdtf -blocking 0
5283 filerun $gdtf [list gettreediffline $gdtf $ids]
5286 proc gettreediffline {gdtf ids} {
5287 global treediff treediffs treepending diffids diffmergeid
5291 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5292 set i [string first "\t" $line]
5294 set file [string range $line [expr {$i+1}] end]
5295 if {[string index $file 0] eq "\""} {
5296 set file [lindex $file 0]
5298 lappend treediff $file
5302 return [expr {$nr >= 1000? 2: 1}]
5305 set treediffs($ids) $treediff
5307 if {$cmitmode eq "tree"} {
5309 } elseif {$ids != $diffids} {
5310 if {![info exists diffmergeid]} {
5311 gettreediffs $diffids
5319 # empty string or positive integer
5320 proc diffcontextvalidate {v} {
5321 return [regexp {^(|[1-9][0-9]*)$} $v]
5324 proc diffcontextchange {n1 n2 op} {
5325 global diffcontextstring diffcontext
5327 if {[string is integer -strict $diffcontextstring]} {
5328 if {$diffcontextstring > 0} {
5329 set diffcontext $diffcontextstring
5335 proc getblobdiffs {ids} {
5336 global diffopts blobdifffd diffids env
5337 global diffinhdr treediffs
5340 set env(GIT_DIFF_OPTS) $diffopts
5341 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5342 puts "error getting diffs: $err"
5346 fconfigure $bdf -blocking 0
5347 set blobdifffd($ids) $bdf
5348 filerun $bdf [list getblobdiffline $bdf $diffids]
5351 proc setinlist {var i val} {
5354 while {[llength [set $var]] < $i} {
5357 if {[llength [set $var]] == $i} {
5364 proc makediffhdr {fname ids} {
5365 global ctext curdiffstart treediffs
5367 set i [lsearch -exact $treediffs($ids) $fname]
5369 setinlist difffilestart $i $curdiffstart
5371 set l [expr {(78 - [string length $fname]) / 2}]
5372 set pad [string range "----------------------------------------" 1 $l]
5373 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5376 proc getblobdiffline {bdf ids} {
5377 global diffids blobdifffd ctext curdiffstart
5378 global diffnexthead diffnextnote difffilestart
5379 global diffinhdr treediffs
5382 $ctext conf -state normal
5383 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5384 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5388 if {![string compare -length 11 "diff --git " $line]} {
5389 # trim off "diff --git "
5390 set line [string range $line 11 end]
5392 # start of a new file
5393 $ctext insert end "\n"
5394 set curdiffstart [$ctext index "end - 1c"]
5395 $ctext insert end "\n" filesep
5396 # If the name hasn't changed the length will be odd,
5397 # the middle char will be a space, and the two bits either
5398 # side will be a/name and b/name, or "a/name" and "b/name".
5399 # If the name has changed we'll get "rename from" and
5400 # "rename to" or "copy from" and "copy to" lines following this,
5401 # and we'll use them to get the filenames.
5402 # This complexity is necessary because spaces in the filename(s)
5403 # don't get escaped.
5404 set l [string length $line]
5405 set i [expr {$l / 2}]
5406 if {!(($l & 1) && [string index $line $i] eq " " &&
5407 [string range $line 2 [expr {$i - 1}]] eq \
5408 [string range $line [expr {$i + 3}] end])} {
5411 # unescape if quoted and chop off the a/ from the front
5412 if {[string index $line 0] eq "\""} {
5413 set fname [string range [lindex $line 0] 2 end]
5415 set fname [string range $line 2 [expr {$i - 1}]]
5417 makediffhdr $fname $ids
5419 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5420 $line match f1l f1c f2l f2c rest]} {
5421 $ctext insert end "$line\n" hunksep
5424 } elseif {$diffinhdr} {
5425 if {![string compare -length 12 "rename from " $line] ||
5426 ![string compare -length 10 "copy from " $line]} {
5427 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5428 if {[string index $fname 0] eq "\""} {
5429 set fname [lindex $fname 0]
5431 set i [lsearch -exact $treediffs($ids) $fname]
5433 setinlist difffilestart $i $curdiffstart
5435 } elseif {![string compare -length 10 $line "rename to "] ||
5436 ![string compare -length 8 $line "copy to "]} {
5437 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5438 if {[string index $fname 0] eq "\""} {
5439 set fname [lindex $fname 0]
5441 makediffhdr $fname $ids
5442 } elseif {[string compare -length 3 $line "---"] == 0} {
5445 } elseif {[string compare -length 3 $line "+++"] == 0} {
5449 $ctext insert end "$line\n" filesep
5452 set x [string range $line 0 0]
5453 if {$x == "-" || $x == "+"} {
5454 set tag [expr {$x == "+"}]
5455 $ctext insert end "$line\n" d$tag
5456 } elseif {$x == " "} {
5457 $ctext insert end "$line\n"
5459 # "\ No newline at end of file",
5460 # or something else we don't recognize
5461 $ctext insert end "$line\n" hunksep
5465 $ctext conf -state disabled
5470 return [expr {$nr >= 1000? 2: 1}]
5473 proc changediffdisp {} {
5474 global ctext diffelide
5476 $ctext tag conf d0 -elide [lindex $diffelide 0]
5477 $ctext tag conf d1 -elide [lindex $diffelide 1]
5481 global difffilestart ctext
5482 set prev [lindex $difffilestart 0]
5483 set here [$ctext index @0,0]
5484 foreach loc $difffilestart {
5485 if {[$ctext compare $loc >= $here]} {
5495 global difffilestart ctext
5496 set here [$ctext index @0,0]
5497 foreach loc $difffilestart {
5498 if {[$ctext compare $loc > $here]} {
5505 proc clear_ctext {{first 1.0}} {
5506 global ctext smarktop smarkbot
5509 set l [lindex [split $first .] 0]
5510 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5513 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5516 $ctext delete $first end
5517 if {$first eq "1.0"} {
5518 catch {unset pendinglinks}
5522 proc settabs {{firstab {}}} {
5523 global firsttabstop tabstop ctext have_tk85
5525 if {$firstab ne {} && $have_tk85} {
5526 set firsttabstop $firstab
5528 set w [font measure textfont "0"]
5529 if {$firsttabstop != 0} {
5530 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5531 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5532 } elseif {$have_tk85 || $tabstop != 8} {
5533 $ctext conf -tabs [expr {$tabstop * $w}]
5535 $ctext conf -tabs {}
5539 proc incrsearch {name ix op} {
5540 global ctext searchstring searchdirn
5542 $ctext tag remove found 1.0 end
5543 if {[catch {$ctext index anchor}]} {
5544 # no anchor set, use start of selection, or of visible area
5545 set sel [$ctext tag ranges sel]
5547 $ctext mark set anchor [lindex $sel 0]
5548 } elseif {$searchdirn eq "-forwards"} {
5549 $ctext mark set anchor @0,0
5551 $ctext mark set anchor @0,[winfo height $ctext]
5554 if {$searchstring ne {}} {
5555 set here [$ctext search $searchdirn -- $searchstring anchor]
5564 global sstring ctext searchstring searchdirn
5567 $sstring icursor end
5568 set searchdirn -forwards
5569 if {$searchstring ne {}} {
5570 set sel [$ctext tag ranges sel]
5572 set start "[lindex $sel 0] + 1c"
5573 } elseif {[catch {set start [$ctext index anchor]}]} {
5576 set match [$ctext search -count mlen -- $searchstring $start]
5577 $ctext tag remove sel 1.0 end
5583 set mend "$match + $mlen c"
5584 $ctext tag add sel $match $mend
5585 $ctext mark unset anchor
5589 proc dosearchback {} {
5590 global sstring ctext searchstring searchdirn
5593 $sstring icursor end
5594 set searchdirn -backwards
5595 if {$searchstring ne {}} {
5596 set sel [$ctext tag ranges sel]
5598 set start [lindex $sel 0]
5599 } elseif {[catch {set start [$ctext index anchor]}]} {
5600 set start @0,[winfo height $ctext]
5602 set match [$ctext search -backwards -count ml -- $searchstring $start]
5603 $ctext tag remove sel 1.0 end
5609 set mend "$match + $ml c"
5610 $ctext tag add sel $match $mend
5611 $ctext mark unset anchor
5615 proc searchmark {first last} {
5616 global ctext searchstring
5620 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5621 if {$match eq {}} break
5622 set mend "$match + $mlen c"
5623 $ctext tag add found $match $mend
5627 proc searchmarkvisible {doall} {
5628 global ctext smarktop smarkbot
5630 set topline [lindex [split [$ctext index @0,0] .] 0]
5631 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5632 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5633 # no overlap with previous
5634 searchmark $topline $botline
5635 set smarktop $topline
5636 set smarkbot $botline
5638 if {$topline < $smarktop} {
5639 searchmark $topline [expr {$smarktop-1}]
5640 set smarktop $topline
5642 if {$botline > $smarkbot} {
5643 searchmark [expr {$smarkbot+1}] $botline
5644 set smarkbot $botline
5649 proc scrolltext {f0 f1} {
5652 .bleft.sb set $f0 $f1
5653 if {$searchstring ne {}} {
5659 global linespc charspc canvx0 canvy0
5660 global xspc1 xspc2 lthickness
5662 set linespc [font metrics mainfont -linespace]
5663 set charspc [font measure mainfont "m"]
5664 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5665 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5666 set lthickness [expr {int($linespc / 9) + 1}]
5667 set xspc1(0) $linespc
5675 set ymax [lindex [$canv cget -scrollregion] 3]
5676 if {$ymax eq {} || $ymax == 0} return
5677 set span [$canv yview]
5680 allcanvs yview moveto [lindex $span 0]
5682 if {[info exists selectedline]} {
5683 selectline $selectedline 0
5684 allcanvs yview moveto [lindex $span 0]
5688 proc parsefont {f n} {
5691 set fontattr($f,family) [lindex $n 0]
5693 if {$s eq {} || $s == 0} {
5696 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5698 set fontattr($f,size) $s
5699 set fontattr($f,weight) normal
5700 set fontattr($f,slant) roman
5701 foreach style [lrange $n 2 end] {
5704 "bold" {set fontattr($f,weight) $style}
5706 "italic" {set fontattr($f,slant) $style}
5711 proc fontflags {f {isbold 0}} {
5714 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5715 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5716 -slant $fontattr($f,slant)]
5722 set n [list $fontattr($f,family) $fontattr($f,size)]
5723 if {$fontattr($f,weight) eq "bold"} {
5726 if {$fontattr($f,slant) eq "italic"} {
5732 proc incrfont {inc} {
5733 global mainfont textfont ctext canv phase cflist showrefstop
5734 global stopped entries fontattr
5737 set s $fontattr(mainfont,size)
5742 set fontattr(mainfont,size) $s
5743 font config mainfont -size $s
5744 font config mainfontbold -size $s
5745 set mainfont [fontname mainfont]
5746 set s $fontattr(textfont,size)
5751 set fontattr(textfont,size) $s
5752 font config textfont -size $s
5753 font config textfontbold -size $s
5754 set textfont [fontname textfont]
5761 global sha1entry sha1string
5762 if {[string length $sha1string] == 40} {
5763 $sha1entry delete 0 end
5767 proc sha1change {n1 n2 op} {
5768 global sha1string currentid sha1but
5769 if {$sha1string == {}
5770 || ([info exists currentid] && $sha1string == $currentid)} {
5775 if {[$sha1but cget -state] == $state} return
5776 if {$state == "normal"} {
5777 $sha1but conf -state normal -relief raised -text "Goto: "
5779 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5783 proc gotocommit {} {
5784 global sha1string currentid commitrow tagids headids
5785 global displayorder numcommits curview
5787 if {$sha1string == {}
5788 || ([info exists currentid] && $sha1string == $currentid)} return
5789 if {[info exists tagids($sha1string)]} {
5790 set id $tagids($sha1string)
5791 } elseif {[info exists headids($sha1string)]} {
5792 set id $headids($sha1string)
5794 set id [string tolower $sha1string]
5795 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5797 foreach i $displayorder {
5798 if {[string match $id* $i]} {
5802 if {$matches ne {}} {
5803 if {[llength $matches] > 1} {
5804 error_popup "Short SHA1 id $id is ambiguous"
5807 set id [lindex $matches 0]
5811 if {[info exists commitrow($curview,$id)]} {
5812 selectline $commitrow($curview,$id) 1
5815 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5820 error_popup "$type $sha1string is not known"
5823 proc lineenter {x y id} {
5824 global hoverx hovery hoverid hovertimer
5825 global commitinfo canv
5827 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5831 if {[info exists hovertimer]} {
5832 after cancel $hovertimer
5834 set hovertimer [after 500 linehover]
5838 proc linemotion {x y id} {
5839 global hoverx hovery hoverid hovertimer
5841 if {[info exists hoverid] && $id == $hoverid} {
5844 if {[info exists hovertimer]} {
5845 after cancel $hovertimer
5847 set hovertimer [after 500 linehover]
5851 proc lineleave {id} {
5852 global hoverid hovertimer canv
5854 if {[info exists hoverid] && $id == $hoverid} {
5856 if {[info exists hovertimer]} {
5857 after cancel $hovertimer
5865 global hoverx hovery hoverid hovertimer
5866 global canv linespc lthickness
5869 set text [lindex $commitinfo($hoverid) 0]
5870 set ymax [lindex [$canv cget -scrollregion] 3]
5871 if {$ymax == {}} return
5872 set yfrac [lindex [$canv yview] 0]
5873 set x [expr {$hoverx + 2 * $linespc}]
5874 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5875 set x0 [expr {$x - 2 * $lthickness}]
5876 set y0 [expr {$y - 2 * $lthickness}]
5877 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5878 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5879 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5880 -fill \#ffff80 -outline black -width 1 -tags hover]
5882 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5887 proc clickisonarrow {id y} {
5890 set ranges [rowranges $id]
5891 set thresh [expr {2 * $lthickness + 6}]
5892 set n [expr {[llength $ranges] - 1}]
5893 for {set i 1} {$i < $n} {incr i} {
5894 set row [lindex $ranges $i]
5895 if {abs([yc $row] - $y) < $thresh} {
5902 proc arrowjump {id n y} {
5905 # 1 <-> 2, 3 <-> 4, etc...
5906 set n [expr {(($n - 1) ^ 1) + 1}]
5907 set row [lindex [rowranges $id] $n]
5909 set ymax [lindex [$canv cget -scrollregion] 3]
5910 if {$ymax eq {} || $ymax <= 0} return
5911 set view [$canv yview]
5912 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5913 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5917 allcanvs yview moveto $yfrac
5920 proc lineclick {x y id isnew} {
5921 global ctext commitinfo children canv thickerline curview commitrow
5923 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5928 # draw this line thicker than normal
5932 set ymax [lindex [$canv cget -scrollregion] 3]
5933 if {$ymax eq {}} return
5934 set yfrac [lindex [$canv yview] 0]
5935 set y [expr {$y + $yfrac * $ymax}]
5937 set dirn [clickisonarrow $id $y]
5939 arrowjump $id $dirn $y
5944 addtohistory [list lineclick $x $y $id 0]
5946 # fill the details pane with info about this line
5947 $ctext conf -state normal
5950 $ctext insert end "Parent:\t"
5951 $ctext insert end $id link0
5953 set info $commitinfo($id)
5954 $ctext insert end "\n\t[lindex $info 0]\n"
5955 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5956 set date [formatdate [lindex $info 2]]
5957 $ctext insert end "\tDate:\t$date\n"
5958 set kids $children($curview,$id)
5960 $ctext insert end "\nChildren:"
5962 foreach child $kids {
5964 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5965 set info $commitinfo($child)
5966 $ctext insert end "\n\t"
5967 $ctext insert end $child link$i
5968 setlink $child link$i
5969 $ctext insert end "\n\t[lindex $info 0]"
5970 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5971 set date [formatdate [lindex $info 2]]
5972 $ctext insert end "\n\tDate:\t$date\n"
5975 $ctext conf -state disabled
5979 proc normalline {} {
5981 if {[info exists thickerline]} {
5989 global commitrow curview
5990 if {[info exists commitrow($curview,$id)]} {
5991 selectline $commitrow($curview,$id) 1
5997 if {![info exists startmstime]} {
5998 set startmstime [clock clicks -milliseconds]
6000 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6003 proc rowmenu {x y id} {
6004 global rowctxmenu commitrow selectedline rowmenuid curview
6005 global nullid nullid2 fakerowmenu mainhead
6009 if {![info exists selectedline]
6010 || $commitrow($curview,$id) eq $selectedline} {
6015 if {$id ne $nullid && $id ne $nullid2} {
6016 set menu $rowctxmenu
6017 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6019 set menu $fakerowmenu
6021 $menu entryconfigure "Diff this*" -state $state
6022 $menu entryconfigure "Diff selected*" -state $state
6023 $menu entryconfigure "Make patch" -state $state
6024 tk_popup $menu $x $y
6027 proc diffvssel {dirn} {
6028 global rowmenuid selectedline displayorder
6030 if {![info exists selectedline]} return
6032 set oldid [lindex $displayorder $selectedline]
6033 set newid $rowmenuid
6035 set oldid $rowmenuid
6036 set newid [lindex $displayorder $selectedline]
6038 addtohistory [list doseldiff $oldid $newid]
6039 doseldiff $oldid $newid
6042 proc doseldiff {oldid newid} {
6046 $ctext conf -state normal
6049 $ctext insert end "From "
6050 $ctext insert end $oldid link0
6051 setlink $oldid link0
6052 $ctext insert end "\n "
6053 $ctext insert end [lindex $commitinfo($oldid) 0]
6054 $ctext insert end "\n\nTo "
6055 $ctext insert end $newid link1
6056 setlink $newid link1
6057 $ctext insert end "\n "
6058 $ctext insert end [lindex $commitinfo($newid) 0]
6059 $ctext insert end "\n"
6060 $ctext conf -state disabled
6061 $ctext tag remove found 1.0 end
6062 startdiff [list $oldid $newid]
6066 global rowmenuid currentid commitinfo patchtop patchnum
6068 if {![info exists currentid]} return
6069 set oldid $currentid
6070 set oldhead [lindex $commitinfo($oldid) 0]
6071 set newid $rowmenuid
6072 set newhead [lindex $commitinfo($newid) 0]
6075 catch {destroy $top}
6077 label $top.title -text "Generate patch"
6078 grid $top.title - -pady 10
6079 label $top.from -text "From:"
6080 entry $top.fromsha1 -width 40 -relief flat
6081 $top.fromsha1 insert 0 $oldid
6082 $top.fromsha1 conf -state readonly
6083 grid $top.from $top.fromsha1 -sticky w
6084 entry $top.fromhead -width 60 -relief flat
6085 $top.fromhead insert 0 $oldhead
6086 $top.fromhead conf -state readonly
6087 grid x $top.fromhead -sticky w
6088 label $top.to -text "To:"
6089 entry $top.tosha1 -width 40 -relief flat
6090 $top.tosha1 insert 0 $newid
6091 $top.tosha1 conf -state readonly
6092 grid $top.to $top.tosha1 -sticky w
6093 entry $top.tohead -width 60 -relief flat
6094 $top.tohead insert 0 $newhead
6095 $top.tohead conf -state readonly
6096 grid x $top.tohead -sticky w
6097 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6098 grid $top.rev x -pady 10
6099 label $top.flab -text "Output file:"
6100 entry $top.fname -width 60
6101 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6103 grid $top.flab $top.fname -sticky w
6105 button $top.buts.gen -text "Generate" -command mkpatchgo
6106 button $top.buts.can -text "Cancel" -command mkpatchcan
6107 grid $top.buts.gen $top.buts.can
6108 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6109 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6110 grid $top.buts - -pady 10 -sticky ew
6114 proc mkpatchrev {} {
6117 set oldid [$patchtop.fromsha1 get]
6118 set oldhead [$patchtop.fromhead get]
6119 set newid [$patchtop.tosha1 get]
6120 set newhead [$patchtop.tohead get]
6121 foreach e [list fromsha1 fromhead tosha1 tohead] \
6122 v [list $newid $newhead $oldid $oldhead] {
6123 $patchtop.$e conf -state normal
6124 $patchtop.$e delete 0 end
6125 $patchtop.$e insert 0 $v
6126 $patchtop.$e conf -state readonly
6131 global patchtop nullid nullid2
6133 set oldid [$patchtop.fromsha1 get]
6134 set newid [$patchtop.tosha1 get]
6135 set fname [$patchtop.fname get]
6136 set cmd [diffcmd [list $oldid $newid] -p]
6137 # trim off the initial "|"
6138 set cmd [lrange $cmd 1 end]
6139 lappend cmd >$fname &
6140 if {[catch {eval exec $cmd} err]} {
6141 error_popup "Error creating patch: $err"
6143 catch {destroy $patchtop}
6147 proc mkpatchcan {} {
6150 catch {destroy $patchtop}
6155 global rowmenuid mktagtop commitinfo
6159 catch {destroy $top}
6161 label $top.title -text "Create tag"
6162 grid $top.title - -pady 10
6163 label $top.id -text "ID:"
6164 entry $top.sha1 -width 40 -relief flat
6165 $top.sha1 insert 0 $rowmenuid
6166 $top.sha1 conf -state readonly
6167 grid $top.id $top.sha1 -sticky w
6168 entry $top.head -width 60 -relief flat
6169 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6170 $top.head conf -state readonly
6171 grid x $top.head -sticky w
6172 label $top.tlab -text "Tag name:"
6173 entry $top.tag -width 60
6174 grid $top.tlab $top.tag -sticky w
6176 button $top.buts.gen -text "Create" -command mktaggo
6177 button $top.buts.can -text "Cancel" -command mktagcan
6178 grid $top.buts.gen $top.buts.can
6179 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6180 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6181 grid $top.buts - -pady 10 -sticky ew
6186 global mktagtop env tagids idtags
6188 set id [$mktagtop.sha1 get]
6189 set tag [$mktagtop.tag get]
6191 error_popup "No tag name specified"
6194 if {[info exists tagids($tag)]} {
6195 error_popup "Tag \"$tag\" already exists"
6200 set fname [file join $dir "refs/tags" $tag]
6201 set f [open $fname w]
6205 error_popup "Error creating tag: $err"
6209 set tagids($tag) $id
6210 lappend idtags($id) $tag
6217 proc redrawtags {id} {
6218 global canv linehtag commitrow idpos selectedline curview
6219 global canvxmax iddrawn
6221 if {![info exists commitrow($curview,$id)]} return
6222 if {![info exists iddrawn($id)]} return
6223 drawcommits $commitrow($curview,$id)
6224 $canv delete tag.$id
6225 set xt [eval drawtags $id $idpos($id)]
6226 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6227 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6228 set xr [expr {$xt + [font measure mainfont $text]}]
6229 if {$xr > $canvxmax} {
6233 if {[info exists selectedline]
6234 && $selectedline == $commitrow($curview,$id)} {
6235 selectline $selectedline 0
6242 catch {destroy $mktagtop}
6251 proc writecommit {} {
6252 global rowmenuid wrcomtop commitinfo wrcomcmd
6254 set top .writecommit
6256 catch {destroy $top}
6258 label $top.title -text "Write commit to file"
6259 grid $top.title - -pady 10
6260 label $top.id -text "ID:"
6261 entry $top.sha1 -width 40 -relief flat
6262 $top.sha1 insert 0 $rowmenuid
6263 $top.sha1 conf -state readonly
6264 grid $top.id $top.sha1 -sticky w
6265 entry $top.head -width 60 -relief flat
6266 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6267 $top.head conf -state readonly
6268 grid x $top.head -sticky w
6269 label $top.clab -text "Command:"
6270 entry $top.cmd -width 60 -textvariable wrcomcmd
6271 grid $top.clab $top.cmd -sticky w -pady 10
6272 label $top.flab -text "Output file:"
6273 entry $top.fname -width 60
6274 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6275 grid $top.flab $top.fname -sticky w
6277 button $top.buts.gen -text "Write" -command wrcomgo
6278 button $top.buts.can -text "Cancel" -command wrcomcan
6279 grid $top.buts.gen $top.buts.can
6280 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6281 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6282 grid $top.buts - -pady 10 -sticky ew
6289 set id [$wrcomtop.sha1 get]
6290 set cmd "echo $id | [$wrcomtop.cmd get]"
6291 set fname [$wrcomtop.fname get]
6292 if {[catch {exec sh -c $cmd >$fname &} err]} {
6293 error_popup "Error writing commit: $err"
6295 catch {destroy $wrcomtop}
6302 catch {destroy $wrcomtop}
6307 global rowmenuid mkbrtop
6310 catch {destroy $top}
6312 label $top.title -text "Create new branch"
6313 grid $top.title - -pady 10
6314 label $top.id -text "ID:"
6315 entry $top.sha1 -width 40 -relief flat
6316 $top.sha1 insert 0 $rowmenuid
6317 $top.sha1 conf -state readonly
6318 grid $top.id $top.sha1 -sticky w
6319 label $top.nlab -text "Name:"
6320 entry $top.name -width 40
6321 grid $top.nlab $top.name -sticky w
6323 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6324 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6325 grid $top.buts.go $top.buts.can
6326 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6327 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6328 grid $top.buts - -pady 10 -sticky ew
6333 global headids idheads
6335 set name [$top.name get]
6336 set id [$top.sha1 get]
6338 error_popup "Please specify a name for the new branch"
6341 catch {destroy $top}
6345 exec git branch $name $id
6350 set headids($name) $id
6351 lappend idheads($id) $name
6360 proc cherrypick {} {
6361 global rowmenuid curview commitrow
6364 set oldhead [exec git rev-parse HEAD]
6365 set dheads [descheads $rowmenuid]
6366 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6367 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6368 included in branch $mainhead -- really re-apply it?"]
6373 # Unfortunately git-cherry-pick writes stuff to stderr even when
6374 # no error occurs, and exec takes that as an indication of error...
6375 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6380 set newhead [exec git rev-parse HEAD]
6381 if {$newhead eq $oldhead} {
6383 error_popup "No changes committed"
6386 addnewchild $newhead $oldhead
6387 if {[info exists commitrow($curview,$oldhead)]} {
6388 insertrow $commitrow($curview,$oldhead) $newhead
6389 if {$mainhead ne {}} {
6390 movehead $newhead $mainhead
6391 movedhead $newhead $mainhead
6400 global mainheadid mainhead rowmenuid confirm_ok resettype
6403 set w ".confirmreset"
6406 wm title $w "Confirm reset"
6407 message $w.m -text \
6408 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6409 -justify center -aspect 1000
6410 pack $w.m -side top -fill x -padx 20 -pady 20
6411 frame $w.f -relief sunken -border 2
6412 message $w.f.rt -text "Reset type:" -aspect 1000
6413 grid $w.f.rt -sticky w
6415 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6416 -text "Soft: Leave working tree and index untouched"
6417 grid $w.f.soft -sticky w
6418 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6419 -text "Mixed: Leave working tree untouched, reset index"
6420 grid $w.f.mixed -sticky w
6421 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6422 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6423 grid $w.f.hard -sticky w
6424 pack $w.f -side top -fill x
6425 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6426 pack $w.ok -side left -fill x -padx 20 -pady 20
6427 button $w.cancel -text Cancel -command "destroy $w"
6428 pack $w.cancel -side right -fill x -padx 20 -pady 20
6429 bind $w <Visibility> "grab $w; focus $w"
6431 if {!$confirm_ok} return
6432 if {[catch {set fd [open \
6433 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6437 set w ".resetprogress"
6438 filerun $fd [list readresetstat $fd $w]
6441 wm title $w "Reset progress"
6442 message $w.m -text "Reset in progress, please wait..." \
6443 -justify center -aspect 1000
6444 pack $w.m -side top -fill x -padx 20 -pady 5
6445 canvas $w.c -width 150 -height 20 -bg white
6446 $w.c create rect 0 0 0 20 -fill green -tags rect
6447 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6452 proc readresetstat {fd w} {
6453 global mainhead mainheadid showlocalchanges
6455 if {[gets $fd line] >= 0} {
6456 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6457 set x [expr {($m * 150) / $n}]
6458 $w.c coords rect 0 0 $x 20
6464 if {[catch {close $fd} err]} {
6467 set oldhead $mainheadid
6468 set newhead [exec git rev-parse HEAD]
6469 if {$newhead ne $oldhead} {
6470 movehead $newhead $mainhead
6471 movedhead $newhead $mainhead
6472 set mainheadid $newhead
6476 if {$showlocalchanges} {
6482 # context menu for a head
6483 proc headmenu {x y id head} {
6484 global headmenuid headmenuhead headctxmenu mainhead
6488 set headmenuhead $head
6490 if {$head eq $mainhead} {
6493 $headctxmenu entryconfigure 0 -state $state
6494 $headctxmenu entryconfigure 1 -state $state
6495 tk_popup $headctxmenu $x $y
6499 global headmenuid headmenuhead mainhead headids
6500 global showlocalchanges mainheadid
6502 # check the tree is clean first??
6503 set oldmainhead $mainhead
6508 exec git checkout -q $headmenuhead
6514 set mainhead $headmenuhead
6515 set mainheadid $headmenuid
6516 if {[info exists headids($oldmainhead)]} {
6517 redrawtags $headids($oldmainhead)
6519 redrawtags $headmenuid
6521 if {$showlocalchanges} {
6527 global headmenuid headmenuhead mainhead
6530 set head $headmenuhead
6532 # this check shouldn't be needed any more...
6533 if {$head eq $mainhead} {
6534 error_popup "Cannot delete the currently checked-out branch"
6537 set dheads [descheads $id]
6538 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6539 # the stuff on this branch isn't on any other branch
6540 if {![confirm_popup "The commits on branch $head aren't on any other\
6541 branch.\nReally delete branch $head?"]} return
6545 if {[catch {exec git branch -D $head} err]} {
6550 removehead $id $head
6551 removedhead $id $head
6558 # Display a list of tags and heads
6560 global showrefstop bgcolor fgcolor selectbgcolor
6561 global bglist fglist reflistfilter reflist maincursor
6564 set showrefstop $top
6565 if {[winfo exists $top]} {
6571 wm title $top "Tags and heads: [file tail [pwd]]"
6572 text $top.list -background $bgcolor -foreground $fgcolor \
6573 -selectbackground $selectbgcolor -font mainfont \
6574 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6575 -width 30 -height 20 -cursor $maincursor \
6576 -spacing1 1 -spacing3 1 -state disabled
6577 $top.list tag configure highlight -background $selectbgcolor
6578 lappend bglist $top.list
6579 lappend fglist $top.list
6580 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6581 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6582 grid $top.list $top.ysb -sticky nsew
6583 grid $top.xsb x -sticky ew
6585 label $top.f.l -text "Filter: " -font uifont
6586 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6587 set reflistfilter "*"
6588 trace add variable reflistfilter write reflistfilter_change
6589 pack $top.f.e -side right -fill x -expand 1
6590 pack $top.f.l -side left
6591 grid $top.f - -sticky ew -pady 2
6592 button $top.close -command [list destroy $top] -text "Close" \
6595 grid columnconfigure $top 0 -weight 1
6596 grid rowconfigure $top 0 -weight 1
6597 bind $top.list <1> {break}
6598 bind $top.list <B1-Motion> {break}
6599 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6604 proc sel_reflist {w x y} {
6605 global showrefstop reflist headids tagids otherrefids
6607 if {![winfo exists $showrefstop]} return
6608 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6609 set ref [lindex $reflist [expr {$l-1}]]
6610 set n [lindex $ref 0]
6611 switch -- [lindex $ref 1] {
6612 "H" {selbyid $headids($n)}
6613 "T" {selbyid $tagids($n)}
6614 "o" {selbyid $otherrefids($n)}
6616 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6619 proc unsel_reflist {} {
6622 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6623 $showrefstop.list tag remove highlight 0.0 end
6626 proc reflistfilter_change {n1 n2 op} {
6627 global reflistfilter
6629 after cancel refill_reflist
6630 after 200 refill_reflist
6633 proc refill_reflist {} {
6634 global reflist reflistfilter showrefstop headids tagids otherrefids
6635 global commitrow curview commitinterest
6637 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6639 foreach n [array names headids] {
6640 if {[string match $reflistfilter $n]} {
6641 if {[info exists commitrow($curview,$headids($n))]} {
6642 lappend refs [list $n H]
6644 set commitinterest($headids($n)) {run refill_reflist}
6648 foreach n [array names tagids] {
6649 if {[string match $reflistfilter $n]} {
6650 if {[info exists commitrow($curview,$tagids($n))]} {
6651 lappend refs [list $n T]
6653 set commitinterest($tagids($n)) {run refill_reflist}
6657 foreach n [array names otherrefids] {
6658 if {[string match $reflistfilter $n]} {
6659 if {[info exists commitrow($curview,$otherrefids($n))]} {
6660 lappend refs [list $n o]
6662 set commitinterest($otherrefids($n)) {run refill_reflist}
6666 set refs [lsort -index 0 $refs]
6667 if {$refs eq $reflist} return
6669 # Update the contents of $showrefstop.list according to the
6670 # differences between $reflist (old) and $refs (new)
6671 $showrefstop.list conf -state normal
6672 $showrefstop.list insert end "\n"
6675 while {$i < [llength $reflist] || $j < [llength $refs]} {
6676 if {$i < [llength $reflist]} {
6677 if {$j < [llength $refs]} {
6678 set cmp [string compare [lindex $reflist $i 0] \
6679 [lindex $refs $j 0]]
6681 set cmp [string compare [lindex $reflist $i 1] \
6682 [lindex $refs $j 1]]
6692 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6700 set l [expr {$j + 1}]
6701 $showrefstop.list image create $l.0 -align baseline \
6702 -image reficon-[lindex $refs $j 1] -padx 2
6703 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6709 # delete last newline
6710 $showrefstop.list delete end-2c end-1c
6711 $showrefstop.list conf -state disabled
6714 # Stuff for finding nearby tags
6715 proc getallcommits {} {
6716 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6717 global idheads idtags idotherrefs allparents tagobjid
6719 if {![info exists allcommits]} {
6725 set allccache [file join [gitdir] "gitk.cache"]
6727 set f [open $allccache r]
6736 set cmd [list | git rev-list --parents]
6737 set allcupdate [expr {$seeds ne {}}]
6741 set refs [concat [array names idheads] [array names idtags] \
6742 [array names idotherrefs]]
6745 foreach name [array names tagobjid] {
6746 lappend tagobjs $tagobjid($name)
6748 foreach id [lsort -unique $refs] {
6749 if {![info exists allparents($id)] &&
6750 [lsearch -exact $tagobjs $id] < 0} {
6761 set fd [open [concat $cmd $ids] r]
6762 fconfigure $fd -blocking 0
6765 filerun $fd [list getallclines $fd]
6771 # Since most commits have 1 parent and 1 child, we group strings of
6772 # such commits into "arcs" joining branch/merge points (BMPs), which
6773 # are commits that either don't have 1 parent or don't have 1 child.
6775 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6776 # arcout(id) - outgoing arcs for BMP
6777 # arcids(a) - list of IDs on arc including end but not start
6778 # arcstart(a) - BMP ID at start of arc
6779 # arcend(a) - BMP ID at end of arc
6780 # growing(a) - arc a is still growing
6781 # arctags(a) - IDs out of arcids (excluding end) that have tags
6782 # archeads(a) - IDs out of arcids (excluding end) that have heads
6783 # The start of an arc is at the descendent end, so "incoming" means
6784 # coming from descendents, and "outgoing" means going towards ancestors.
6786 proc getallclines {fd} {
6787 global allparents allchildren idtags idheads nextarc
6788 global arcnos arcids arctags arcout arcend arcstart archeads growing
6789 global seeds allcommits cachedarcs allcupdate
6792 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6793 set id [lindex $line 0]
6794 if {[info exists allparents($id)]} {
6799 set olds [lrange $line 1 end]
6800 set allparents($id) $olds
6801 if {![info exists allchildren($id)]} {
6802 set allchildren($id) {}
6807 if {[llength $olds] == 1 && [llength $a] == 1} {
6808 lappend arcids($a) $id
6809 if {[info exists idtags($id)]} {
6810 lappend arctags($a) $id
6812 if {[info exists idheads($id)]} {
6813 lappend archeads($a) $id
6815 if {[info exists allparents($olds)]} {
6816 # seen parent already
6817 if {![info exists arcout($olds)]} {
6820 lappend arcids($a) $olds
6821 set arcend($a) $olds
6824 lappend allchildren($olds) $id
6825 lappend arcnos($olds) $a
6829 foreach a $arcnos($id) {
6830 lappend arcids($a) $id
6837 lappend allchildren($p) $id
6838 set a [incr nextarc]
6839 set arcstart($a) $id
6846 if {[info exists allparents($p)]} {
6847 # seen it already, may need to make a new branch
6848 if {![info exists arcout($p)]} {
6851 lappend arcids($a) $p
6855 lappend arcnos($p) $a
6860 global cached_dheads cached_dtags cached_atags
6861 catch {unset cached_dheads}
6862 catch {unset cached_dtags}
6863 catch {unset cached_atags}
6866 return [expr {$nid >= 1000? 2: 1}]
6870 fconfigure $fd -blocking 1
6873 # got an error reading the list of commits
6874 # if we were updating, try rereading the whole thing again
6880 error_popup "Error reading commit topology information;\
6881 branch and preceding/following tag information\
6882 will be incomplete.\n($err)"
6885 if {[incr allcommits -1] == 0} {
6895 proc recalcarc {a} {
6896 global arctags archeads arcids idtags idheads
6900 foreach id [lrange $arcids($a) 0 end-1] {
6901 if {[info exists idtags($id)]} {
6904 if {[info exists idheads($id)]} {
6909 set archeads($a) $ah
6913 global arcnos arcids nextarc arctags archeads idtags idheads
6914 global arcstart arcend arcout allparents growing
6917 if {[llength $a] != 1} {
6918 puts "oops splitarc called but [llength $a] arcs already"
6922 set i [lsearch -exact $arcids($a) $p]
6924 puts "oops splitarc $p not in arc $a"
6927 set na [incr nextarc]
6928 if {[info exists arcend($a)]} {
6929 set arcend($na) $arcend($a)
6931 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6932 set j [lsearch -exact $arcnos($l) $a]
6933 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6935 set tail [lrange $arcids($a) [expr {$i+1}] end]
6936 set arcids($a) [lrange $arcids($a) 0 $i]
6938 set arcstart($na) $p
6940 set arcids($na) $tail
6941 if {[info exists growing($a)]} {
6947 if {[llength $arcnos($id)] == 1} {
6950 set j [lsearch -exact $arcnos($id) $a]
6951 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6955 # reconstruct tags and heads lists
6956 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6961 set archeads($na) {}
6965 # Update things for a new commit added that is a child of one
6966 # existing commit. Used when cherry-picking.
6967 proc addnewchild {id p} {
6968 global allparents allchildren idtags nextarc
6969 global arcnos arcids arctags arcout arcend arcstart archeads growing
6970 global seeds allcommits
6972 if {![info exists allcommits]} return
6973 set allparents($id) [list $p]
6974 set allchildren($id) {}
6977 lappend allchildren($p) $id
6978 set a [incr nextarc]
6979 set arcstart($a) $id
6982 set arcids($a) [list $p]
6984 if {![info exists arcout($p)]} {
6987 lappend arcnos($p) $a
6988 set arcout($id) [list $a]
6991 # This implements a cache for the topology information.
6992 # The cache saves, for each arc, the start and end of the arc,
6993 # the ids on the arc, and the outgoing arcs from the end.
6994 proc readcache {f} {
6995 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6996 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7001 if {$lim - $a > 500} {
7002 set lim [expr {$a + 500}]
7006 # finish reading the cache and setting up arctags, etc.
7008 if {$line ne "1"} {error "bad final version"}
7010 foreach id [array names idtags] {
7011 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7012 [llength $allparents($id)] == 1} {
7013 set a [lindex $arcnos($id) 0]
7014 if {$arctags($a) eq {}} {
7019 foreach id [array names idheads] {
7020 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7021 [llength $allparents($id)] == 1} {
7022 set a [lindex $arcnos($id) 0]
7023 if {$archeads($a) eq {}} {
7028 foreach id [lsort -unique $possible_seeds] {
7029 if {$arcnos($id) eq {}} {
7035 while {[incr a] <= $lim} {
7037 if {[llength $line] != 3} {error "bad line"}
7038 set s [lindex $line 0]
7040 lappend arcout($s) $a
7041 if {![info exists arcnos($s)]} {
7042 lappend possible_seeds $s
7045 set e [lindex $line 1]
7050 if {![info exists arcout($e)]} {
7054 set arcids($a) [lindex $line 2]
7055 foreach id $arcids($a) {
7056 lappend allparents($s) $id
7058 lappend arcnos($id) $a
7060 if {![info exists allparents($s)]} {
7061 set allparents($s) {}
7066 set nextarc [expr {$a - 1}]
7079 global nextarc cachedarcs possible_seeds
7083 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7084 # make sure it's an integer
7085 set cachedarcs [expr {int([lindex $line 1])}]
7086 if {$cachedarcs < 0} {error "bad number of arcs"}
7088 set possible_seeds {}
7096 proc dropcache {err} {
7097 global allcwait nextarc cachedarcs seeds
7099 #puts "dropping cache ($err)"
7100 foreach v {arcnos arcout arcids arcstart arcend growing \
7101 arctags archeads allparents allchildren} {
7112 proc writecache {f} {
7113 global cachearc cachedarcs allccache
7114 global arcstart arcend arcnos arcids arcout
7118 if {$lim - $a > 1000} {
7119 set lim [expr {$a + 1000}]
7122 while {[incr a] <= $lim} {
7123 if {[info exists arcend($a)]} {
7124 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7126 puts $f [list $arcstart($a) {} $arcids($a)]
7131 catch {file delete $allccache}
7132 #puts "writing cache failed ($err)"
7135 set cachearc [expr {$a - 1}]
7136 if {$a > $cachedarcs} {
7145 global nextarc cachedarcs cachearc allccache
7147 if {$nextarc == $cachedarcs} return
7149 set cachedarcs $nextarc
7151 set f [open $allccache w]
7152 puts $f [list 1 $cachedarcs]
7157 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7158 # or 0 if neither is true.
7159 proc anc_or_desc {a b} {
7160 global arcout arcstart arcend arcnos cached_isanc
7162 if {$arcnos($a) eq $arcnos($b)} {
7163 # Both are on the same arc(s); either both are the same BMP,
7164 # or if one is not a BMP, the other is also not a BMP or is
7165 # the BMP at end of the arc (and it only has 1 incoming arc).
7166 # Or both can be BMPs with no incoming arcs.
7167 if {$a eq $b || $arcnos($a) eq {}} {
7170 # assert {[llength $arcnos($a)] == 1}
7171 set arc [lindex $arcnos($a) 0]
7172 set i [lsearch -exact $arcids($arc) $a]
7173 set j [lsearch -exact $arcids($arc) $b]
7174 if {$i < 0 || $i > $j} {
7181 if {![info exists arcout($a)]} {
7182 set arc [lindex $arcnos($a) 0]
7183 if {[info exists arcend($arc)]} {
7184 set aend $arcend($arc)
7188 set a $arcstart($arc)
7192 if {![info exists arcout($b)]} {
7193 set arc [lindex $arcnos($b) 0]
7194 if {[info exists arcend($arc)]} {
7195 set bend $arcend($arc)
7199 set b $arcstart($arc)
7209 if {[info exists cached_isanc($a,$bend)]} {
7210 if {$cached_isanc($a,$bend)} {
7214 if {[info exists cached_isanc($b,$aend)]} {
7215 if {$cached_isanc($b,$aend)} {
7218 if {[info exists cached_isanc($a,$bend)]} {
7223 set todo [list $a $b]
7226 for {set i 0} {$i < [llength $todo]} {incr i} {
7227 set x [lindex $todo $i]
7228 if {$anc($x) eq {}} {
7231 foreach arc $arcnos($x) {
7232 set xd $arcstart($arc)
7234 set cached_isanc($a,$bend) 1
7235 set cached_isanc($b,$aend) 0
7237 } elseif {$xd eq $aend} {
7238 set cached_isanc($b,$aend) 1
7239 set cached_isanc($a,$bend) 0
7242 if {![info exists anc($xd)]} {
7243 set anc($xd) $anc($x)
7245 } elseif {$anc($xd) ne $anc($x)} {
7250 set cached_isanc($a,$bend) 0
7251 set cached_isanc($b,$aend) 0
7255 # This identifies whether $desc has an ancestor that is
7256 # a growing tip of the graph and which is not an ancestor of $anc
7257 # and returns 0 if so and 1 if not.
7258 # If we subsequently discover a tag on such a growing tip, and that
7259 # turns out to be a descendent of $anc (which it could, since we
7260 # don't necessarily see children before parents), then $desc
7261 # isn't a good choice to display as a descendent tag of
7262 # $anc (since it is the descendent of another tag which is
7263 # a descendent of $anc). Similarly, $anc isn't a good choice to
7264 # display as a ancestor tag of $desc.
7266 proc is_certain {desc anc} {
7267 global arcnos arcout arcstart arcend growing problems
7270 if {[llength $arcnos($anc)] == 1} {
7271 # tags on the same arc are certain
7272 if {$arcnos($desc) eq $arcnos($anc)} {
7275 if {![info exists arcout($anc)]} {
7276 # if $anc is partway along an arc, use the start of the arc instead
7277 set a [lindex $arcnos($anc) 0]
7278 set anc $arcstart($a)
7281 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7284 set a [lindex $arcnos($desc) 0]
7290 set anclist [list $x]
7294 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7295 set x [lindex $anclist $i]
7300 foreach a $arcout($x) {
7301 if {[info exists growing($a)]} {
7302 if {![info exists growanc($x)] && $dl($x)} {
7308 if {[info exists dl($y)]} {
7312 if {![info exists done($y)]} {
7315 if {[info exists growanc($x)]} {
7319 for {set k 0} {$k < [llength $xl]} {incr k} {
7320 set z [lindex $xl $k]
7321 foreach c $arcout($z) {
7322 if {[info exists arcend($c)]} {
7324 if {[info exists dl($v)] && $dl($v)} {
7326 if {![info exists done($v)]} {
7329 if {[info exists growanc($v)]} {
7339 } elseif {$y eq $anc || !$dl($x)} {
7350 foreach x [array names growanc] {
7359 proc validate_arctags {a} {
7360 global arctags idtags
7364 foreach id $arctags($a) {
7366 if {![info exists idtags($id)]} {
7367 set na [lreplace $na $i $i]
7374 proc validate_archeads {a} {
7375 global archeads idheads
7378 set na $archeads($a)
7379 foreach id $archeads($a) {
7381 if {![info exists idheads($id)]} {
7382 set na [lreplace $na $i $i]
7386 set archeads($a) $na
7389 # Return the list of IDs that have tags that are descendents of id,
7390 # ignoring IDs that are descendents of IDs already reported.
7391 proc desctags {id} {
7392 global arcnos arcstart arcids arctags idtags allparents
7393 global growing cached_dtags
7395 if {![info exists allparents($id)]} {
7398 set t1 [clock clicks -milliseconds]
7400 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7401 # part-way along an arc; check that arc first
7402 set a [lindex $arcnos($id) 0]
7403 if {$arctags($a) ne {}} {
7405 set i [lsearch -exact $arcids($a) $id]
7407 foreach t $arctags($a) {
7408 set j [lsearch -exact $arcids($a) $t]
7416 set id $arcstart($a)
7417 if {[info exists idtags($id)]} {
7421 if {[info exists cached_dtags($id)]} {
7422 return $cached_dtags($id)
7429 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7430 set id [lindex $todo $i]
7432 set ta [info exists hastaggedancestor($id)]
7436 # ignore tags on starting node
7437 if {!$ta && $i > 0} {
7438 if {[info exists idtags($id)]} {
7441 } elseif {[info exists cached_dtags($id)]} {
7442 set tagloc($id) $cached_dtags($id)
7446 foreach a $arcnos($id) {
7448 if {!$ta && $arctags($a) ne {}} {
7450 if {$arctags($a) ne {}} {
7451 lappend tagloc($id) [lindex $arctags($a) end]
7454 if {$ta || $arctags($a) ne {}} {
7455 set tomark [list $d]
7456 for {set j 0} {$j < [llength $tomark]} {incr j} {
7457 set dd [lindex $tomark $j]
7458 if {![info exists hastaggedancestor($dd)]} {
7459 if {[info exists done($dd)]} {
7460 foreach b $arcnos($dd) {
7461 lappend tomark $arcstart($b)
7463 if {[info exists tagloc($dd)]} {
7466 } elseif {[info exists queued($dd)]} {
7469 set hastaggedancestor($dd) 1
7473 if {![info exists queued($d)]} {
7476 if {![info exists hastaggedancestor($d)]} {
7483 foreach id [array names tagloc] {
7484 if {![info exists hastaggedancestor($id)]} {
7485 foreach t $tagloc($id) {
7486 if {[lsearch -exact $tags $t] < 0} {
7492 set t2 [clock clicks -milliseconds]
7495 # remove tags that are descendents of other tags
7496 for {set i 0} {$i < [llength $tags]} {incr i} {
7497 set a [lindex $tags $i]
7498 for {set j 0} {$j < $i} {incr j} {
7499 set b [lindex $tags $j]
7500 set r [anc_or_desc $a $b]
7502 set tags [lreplace $tags $j $j]
7505 } elseif {$r == -1} {
7506 set tags [lreplace $tags $i $i]
7513 if {[array names growing] ne {}} {
7514 # graph isn't finished, need to check if any tag could get
7515 # eclipsed by another tag coming later. Simply ignore any
7516 # tags that could later get eclipsed.
7519 if {[is_certain $t $origid]} {
7523 if {$tags eq $ctags} {
7524 set cached_dtags($origid) $tags
7529 set cached_dtags($origid) $tags
7531 set t3 [clock clicks -milliseconds]
7532 if {0 && $t3 - $t1 >= 100} {
7533 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7534 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7540 global arcnos arcids arcout arcend arctags idtags allparents
7541 global growing cached_atags
7543 if {![info exists allparents($id)]} {
7546 set t1 [clock clicks -milliseconds]
7548 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7549 # part-way along an arc; check that arc first
7550 set a [lindex $arcnos($id) 0]
7551 if {$arctags($a) ne {}} {
7553 set i [lsearch -exact $arcids($a) $id]
7554 foreach t $arctags($a) {
7555 set j [lsearch -exact $arcids($a) $t]
7561 if {![info exists arcend($a)]} {
7565 if {[info exists idtags($id)]} {
7569 if {[info exists cached_atags($id)]} {
7570 return $cached_atags($id)
7578 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7579 set id [lindex $todo $i]
7581 set td [info exists hastaggeddescendent($id)]
7585 # ignore tags on starting node
7586 if {!$td && $i > 0} {
7587 if {[info exists idtags($id)]} {
7590 } elseif {[info exists cached_atags($id)]} {
7591 set tagloc($id) $cached_atags($id)
7595 foreach a $arcout($id) {
7596 if {!$td && $arctags($a) ne {}} {
7598 if {$arctags($a) ne {}} {
7599 lappend tagloc($id) [lindex $arctags($a) 0]
7602 if {![info exists arcend($a)]} continue
7604 if {$td || $arctags($a) ne {}} {
7605 set tomark [list $d]
7606 for {set j 0} {$j < [llength $tomark]} {incr j} {
7607 set dd [lindex $tomark $j]
7608 if {![info exists hastaggeddescendent($dd)]} {
7609 if {[info exists done($dd)]} {
7610 foreach b $arcout($dd) {
7611 if {[info exists arcend($b)]} {
7612 lappend tomark $arcend($b)
7615 if {[info exists tagloc($dd)]} {
7618 } elseif {[info exists queued($dd)]} {
7621 set hastaggeddescendent($dd) 1
7625 if {![info exists queued($d)]} {
7628 if {![info exists hastaggeddescendent($d)]} {
7634 set t2 [clock clicks -milliseconds]
7637 foreach id [array names tagloc] {
7638 if {![info exists hastaggeddescendent($id)]} {
7639 foreach t $tagloc($id) {
7640 if {[lsearch -exact $tags $t] < 0} {
7647 # remove tags that are ancestors of other tags
7648 for {set i 0} {$i < [llength $tags]} {incr i} {
7649 set a [lindex $tags $i]
7650 for {set j 0} {$j < $i} {incr j} {
7651 set b [lindex $tags $j]
7652 set r [anc_or_desc $a $b]
7654 set tags [lreplace $tags $j $j]
7657 } elseif {$r == 1} {
7658 set tags [lreplace $tags $i $i]
7665 if {[array names growing] ne {}} {
7666 # graph isn't finished, need to check if any tag could get
7667 # eclipsed by another tag coming later. Simply ignore any
7668 # tags that could later get eclipsed.
7671 if {[is_certain $origid $t]} {
7675 if {$tags eq $ctags} {
7676 set cached_atags($origid) $tags
7681 set cached_atags($origid) $tags
7683 set t3 [clock clicks -milliseconds]
7684 if {0 && $t3 - $t1 >= 100} {
7685 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7686 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7691 # Return the list of IDs that have heads that are descendents of id,
7692 # including id itself if it has a head.
7693 proc descheads {id} {
7694 global arcnos arcstart arcids archeads idheads cached_dheads
7697 if {![info exists allparents($id)]} {
7701 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7702 # part-way along an arc; check it first
7703 set a [lindex $arcnos($id) 0]
7704 if {$archeads($a) ne {}} {
7705 validate_archeads $a
7706 set i [lsearch -exact $arcids($a) $id]
7707 foreach t $archeads($a) {
7708 set j [lsearch -exact $arcids($a) $t]
7713 set id $arcstart($a)
7719 for {set i 0} {$i < [llength $todo]} {incr i} {
7720 set id [lindex $todo $i]
7721 if {[info exists cached_dheads($id)]} {
7722 set ret [concat $ret $cached_dheads($id)]
7724 if {[info exists idheads($id)]} {
7727 foreach a $arcnos($id) {
7728 if {$archeads($a) ne {}} {
7729 validate_archeads $a
7730 if {$archeads($a) ne {}} {
7731 set ret [concat $ret $archeads($a)]
7735 if {![info exists seen($d)]} {
7742 set ret [lsort -unique $ret]
7743 set cached_dheads($origid) $ret
7744 return [concat $ret $aret]
7747 proc addedtag {id} {
7748 global arcnos arcout cached_dtags cached_atags
7750 if {![info exists arcnos($id)]} return
7751 if {![info exists arcout($id)]} {
7752 recalcarc [lindex $arcnos($id) 0]
7754 catch {unset cached_dtags}
7755 catch {unset cached_atags}
7758 proc addedhead {hid head} {
7759 global arcnos arcout cached_dheads
7761 if {![info exists arcnos($hid)]} return
7762 if {![info exists arcout($hid)]} {
7763 recalcarc [lindex $arcnos($hid) 0]
7765 catch {unset cached_dheads}
7768 proc removedhead {hid head} {
7769 global cached_dheads
7771 catch {unset cached_dheads}
7774 proc movedhead {hid head} {
7775 global arcnos arcout cached_dheads
7777 if {![info exists arcnos($hid)]} return
7778 if {![info exists arcout($hid)]} {
7779 recalcarc [lindex $arcnos($hid) 0]
7781 catch {unset cached_dheads}
7784 proc changedrefs {} {
7785 global cached_dheads cached_dtags cached_atags
7786 global arctags archeads arcnos arcout idheads idtags
7788 foreach id [concat [array names idheads] [array names idtags]] {
7789 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7790 set a [lindex $arcnos($id) 0]
7791 if {![info exists donearc($a)]} {
7797 catch {unset cached_dtags}
7798 catch {unset cached_atags}
7799 catch {unset cached_dheads}
7802 proc rereadrefs {} {
7803 global idtags idheads idotherrefs mainhead
7805 set refids [concat [array names idtags] \
7806 [array names idheads] [array names idotherrefs]]
7807 foreach id $refids {
7808 if {![info exists ref($id)]} {
7809 set ref($id) [listrefs $id]
7812 set oldmainhead $mainhead
7815 set refids [lsort -unique [concat $refids [array names idtags] \
7816 [array names idheads] [array names idotherrefs]]]
7817 foreach id $refids {
7818 set v [listrefs $id]
7819 if {![info exists ref($id)] || $ref($id) != $v ||
7820 ($id eq $oldmainhead && $id ne $mainhead) ||
7821 ($id eq $mainhead && $id ne $oldmainhead)} {
7828 proc listrefs {id} {
7829 global idtags idheads idotherrefs
7832 if {[info exists idtags($id)]} {
7836 if {[info exists idheads($id)]} {
7840 if {[info exists idotherrefs($id)]} {
7841 set z $idotherrefs($id)
7843 return [list $x $y $z]
7846 proc showtag {tag isnew} {
7847 global ctext tagcontents tagids linknum tagobjid
7850 addtohistory [list showtag $tag 0]
7852 $ctext conf -state normal
7856 if {![info exists tagcontents($tag)]} {
7858 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7861 if {[info exists tagcontents($tag)]} {
7862 set text $tagcontents($tag)
7864 set text "Tag: $tag\nId: $tagids($tag)"
7866 appendwithlinks $text {}
7867 $ctext conf -state disabled
7878 proc mkfontdisp {font top which} {
7879 global fontattr fontpref $font
7881 set fontpref($font) [set $font]
7882 button $top.${font}but -text $which -font optionfont \
7883 -command [list choosefont $font $which]
7884 label $top.$font -relief flat -font $font \
7885 -text $fontattr($font,family) -justify left
7886 grid x $top.${font}but $top.$font -sticky w
7889 proc choosefont {font which} {
7890 global fontparam fontlist fonttop fontattr
7892 set fontparam(which) $which
7893 set fontparam(font) $font
7894 set fontparam(family) [font actual $font -family]
7895 set fontparam(size) $fontattr($font,size)
7896 set fontparam(weight) $fontattr($font,weight)
7897 set fontparam(slant) $fontattr($font,slant)
7900 if {![winfo exists $top]} {
7902 eval font config sample [font actual $font]
7904 wm title $top "Gitk font chooser"
7905 label $top.l -textvariable fontparam(which) -font uifont
7906 pack $top.l -side top
7907 set fontlist [lsort [font families]]
7909 listbox $top.f.fam -listvariable fontlist \
7910 -yscrollcommand [list $top.f.sb set]
7911 bind $top.f.fam <<ListboxSelect>> selfontfam
7912 scrollbar $top.f.sb -command [list $top.f.fam yview]
7913 pack $top.f.sb -side right -fill y
7914 pack $top.f.fam -side left -fill both -expand 1
7915 pack $top.f -side top -fill both -expand 1
7917 spinbox $top.g.size -from 4 -to 40 -width 4 \
7918 -textvariable fontparam(size) \
7919 -validatecommand {string is integer -strict %s}
7920 checkbutton $top.g.bold -padx 5 \
7921 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7922 -variable fontparam(weight) -onvalue bold -offvalue normal
7923 checkbutton $top.g.ital -padx 5 \
7924 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
7925 -variable fontparam(slant) -onvalue italic -offvalue roman
7926 pack $top.g.size $top.g.bold $top.g.ital -side left
7927 pack $top.g -side top
7928 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7930 $top.c create text 100 25 -anchor center -text $which -font sample \
7931 -fill black -tags text
7932 bind $top.c <Configure> [list centertext $top.c]
7933 pack $top.c -side top -fill x
7935 button $top.buts.ok -text "OK" -command fontok -default active \
7937 button $top.buts.can -text "Cancel" -command fontcan -default normal \
7939 grid $top.buts.ok $top.buts.can
7940 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7941 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7942 pack $top.buts -side bottom -fill x
7943 trace add variable fontparam write chg_fontparam
7946 $top.c itemconf text -text $which
7948 set i [lsearch -exact $fontlist $fontparam(family)]
7950 $top.f.fam selection set $i
7955 proc centertext {w} {
7956 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7960 global fontparam fontpref prefstop
7962 set f $fontparam(font)
7963 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7964 if {$fontparam(weight) eq "bold"} {
7965 lappend fontpref($f) "bold"
7967 if {$fontparam(slant) eq "italic"} {
7968 lappend fontpref($f) "italic"
7971 $w conf -text $fontparam(family) -font $fontpref($f)
7977 global fonttop fontparam
7979 if {[info exists fonttop]} {
7980 catch {destroy $fonttop}
7981 catch {font delete sample}
7987 proc selfontfam {} {
7988 global fonttop fontparam
7990 set i [$fonttop.f.fam curselection]
7992 set fontparam(family) [$fonttop.f.fam get $i]
7996 proc chg_fontparam {v sub op} {
7999 font config sample -$sub $fontparam($sub)
8003 global maxwidth maxgraphpct diffopts
8004 global oldprefs prefstop showneartags showlocalchanges
8005 global bgcolor fgcolor ctext diffcolors selectbgcolor
8006 global uifont tabstop
8010 if {[winfo exists $top]} {
8014 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
8015 set oldprefs($v) [set $v]
8018 wm title $top "Gitk preferences"
8019 label $top.ldisp -text "Commit list display options"
8020 $top.ldisp configure -font uifont
8021 grid $top.ldisp - -sticky w -pady 10
8022 label $top.spacer -text " "
8023 label $top.maxwidthl -text "Maximum graph width (lines)" \
8025 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8026 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8027 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8029 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8030 grid x $top.maxpctl $top.maxpct -sticky w
8031 frame $top.showlocal
8032 label $top.showlocal.l -text "Show local changes" -font optionfont
8033 checkbutton $top.showlocal.b -variable showlocalchanges
8034 pack $top.showlocal.b $top.showlocal.l -side left
8035 grid x $top.showlocal -sticky w
8037 label $top.ddisp -text "Diff display options"
8038 $top.ddisp configure -font uifont
8039 grid $top.ddisp - -sticky w -pady 10
8040 label $top.diffoptl -text "Options for diff program" \
8042 entry $top.diffopt -width 20 -textvariable diffopts
8043 grid x $top.diffoptl $top.diffopt -sticky w
8045 label $top.ntag.l -text "Display nearby tags" -font optionfont
8046 checkbutton $top.ntag.b -variable showneartags
8047 pack $top.ntag.b $top.ntag.l -side left
8048 grid x $top.ntag -sticky w
8049 label $top.tabstopl -text "tabstop" -font optionfont
8050 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8051 grid x $top.tabstopl $top.tabstop -sticky w
8053 label $top.cdisp -text "Colors: press to choose"
8054 $top.cdisp configure -font uifont
8055 grid $top.cdisp - -sticky w -pady 10
8056 label $top.bg -padx 40 -relief sunk -background $bgcolor
8057 button $top.bgbut -text "Background" -font optionfont \
8058 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8059 grid x $top.bgbut $top.bg -sticky w
8060 label $top.fg -padx 40 -relief sunk -background $fgcolor
8061 button $top.fgbut -text "Foreground" -font optionfont \
8062 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8063 grid x $top.fgbut $top.fg -sticky w
8064 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8065 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8066 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8067 [list $ctext tag conf d0 -foreground]]
8068 grid x $top.diffoldbut $top.diffold -sticky w
8069 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8070 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8071 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8072 [list $ctext tag conf d1 -foreground]]
8073 grid x $top.diffnewbut $top.diffnew -sticky w
8074 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8075 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8076 -command [list choosecolor diffcolors 2 $top.hunksep \
8077 "diff hunk header" \
8078 [list $ctext tag conf hunksep -foreground]]
8079 grid x $top.hunksepbut $top.hunksep -sticky w
8080 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8081 button $top.selbgbut -text "Select bg" -font optionfont \
8082 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8083 grid x $top.selbgbut $top.selbgsep -sticky w
8085 label $top.cfont -text "Fonts: press to choose"
8086 $top.cfont configure -font uifont
8087 grid $top.cfont - -sticky w -pady 10
8088 mkfontdisp mainfont $top "Main font"
8089 mkfontdisp textfont $top "Diff display font"
8090 mkfontdisp uifont $top "User interface font"
8093 button $top.buts.ok -text "OK" -command prefsok -default active
8094 $top.buts.ok configure -font uifont
8095 button $top.buts.can -text "Cancel" -command prefscan -default normal
8096 $top.buts.can configure -font uifont
8097 grid $top.buts.ok $top.buts.can
8098 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8099 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8100 grid $top.buts - - -pady 10 -sticky ew
8101 bind $top <Visibility> "focus $top.buts.ok"
8104 proc choosecolor {v vi w x cmd} {
8107 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8108 -title "Gitk: choose color for $x"]
8109 if {$c eq {}} return
8110 $w conf -background $c
8116 global bglist cflist
8118 $w configure -selectbackground $c
8120 $cflist tag configure highlight \
8121 -background [$cflist cget -selectbackground]
8122 allcanvs itemconf secsel -fill $c
8129 $w conf -background $c
8137 $w conf -foreground $c
8139 allcanvs itemconf text -fill $c
8140 $canv itemconf circle -outline $c
8144 global maxwidth maxgraphpct diffopts
8145 global oldprefs prefstop showneartags showlocalchanges
8147 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
8148 set $v $oldprefs($v)
8150 catch {destroy $prefstop}
8156 global maxwidth maxgraphpct
8157 global oldprefs prefstop showneartags showlocalchanges
8158 global fontpref mainfont textfont uifont
8160 catch {destroy $prefstop}
8164 if {$mainfont ne $fontpref(mainfont)} {
8165 set mainfont $fontpref(mainfont)
8166 parsefont mainfont $mainfont
8167 eval font configure mainfont [fontflags mainfont]
8168 eval font configure mainfontbold [fontflags mainfont 1]
8172 if {$textfont ne $fontpref(textfont)} {
8173 set textfont $fontpref(textfont)
8174 parsefont textfont $textfont
8175 eval font configure textfont [fontflags textfont]
8176 eval font configure textfontbold [fontflags textfont 1]
8178 if {$uifont ne $fontpref(uifont)} {
8179 set uifont $fontpref(uifont)
8180 parsefont uifont $uifont
8181 eval font configure uifont [fontflags uifont]
8184 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8185 if {$showlocalchanges} {
8191 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8192 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8194 } elseif {$showneartags != $oldprefs(showneartags)} {
8199 proc formatdate {d} {
8200 global datetimeformat
8202 set d [clock format $d -format $datetimeformat]
8207 # This list of encoding names and aliases is distilled from
8208 # http://www.iana.org/assignments/character-sets.
8209 # Not all of them are supported by Tcl.
8210 set encoding_aliases {
8211 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8212 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8213 { ISO-10646-UTF-1 csISO10646UTF1 }
8214 { ISO_646.basic:1983 ref csISO646basic1983 }
8215 { INVARIANT csINVARIANT }
8216 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8217 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8218 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8219 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8220 { NATS-DANO iso-ir-9-1 csNATSDANO }
8221 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8222 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8223 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8224 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8225 { ISO-2022-KR csISO2022KR }
8227 { ISO-2022-JP csISO2022JP }
8228 { ISO-2022-JP-2 csISO2022JP2 }
8229 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8231 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8232 { IT iso-ir-15 ISO646-IT csISO15Italian }
8233 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8234 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8235 { greek7-old iso-ir-18 csISO18Greek7Old }
8236 { latin-greek iso-ir-19 csISO19LatinGreek }
8237 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8238 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8239 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8240 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8241 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8242 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8243 { INIS iso-ir-49 csISO49INIS }
8244 { INIS-8 iso-ir-50 csISO50INIS8 }
8245 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8246 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8247 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8248 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8249 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8250 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8252 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8253 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8254 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8255 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8256 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8257 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8258 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8259 { greek7 iso-ir-88 csISO88Greek7 }
8260 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8261 { iso-ir-90 csISO90 }
8262 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8263 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8264 csISO92JISC62991984b }
8265 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8266 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8267 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8268 csISO95JIS62291984handadd }
8269 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8270 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8271 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8272 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8274 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8275 { T.61-7bit iso-ir-102 csISO102T617bit }
8276 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8277 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8278 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8279 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8280 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8281 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8282 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8283 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8284 arabic csISOLatinArabic }
8285 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8286 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8287 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8288 greek greek8 csISOLatinGreek }
8289 { T.101-G2 iso-ir-128 csISO128T101G2 }
8290 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8292 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8293 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8294 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8295 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8296 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8297 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8298 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8299 csISOLatinCyrillic }
8300 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8301 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8302 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8303 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8304 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8305 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8306 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8307 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8308 { ISO_10367-box iso-ir-155 csISO10367Box }
8309 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8310 { latin-lap lap iso-ir-158 csISO158Lap }
8311 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8312 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8315 { JIS_X0201 X0201 csHalfWidthKatakana }
8316 { KSC5636 ISO646-KR csKSC5636 }
8317 { ISO-10646-UCS-2 csUnicode }
8318 { ISO-10646-UCS-4 csUCS4 }
8319 { DEC-MCS dec csDECMCS }
8320 { hp-roman8 roman8 r8 csHPRoman8 }
8321 { macintosh mac csMacintosh }
8322 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8324 { IBM038 EBCDIC-INT cp038 csIBM038 }
8325 { IBM273 CP273 csIBM273 }
8326 { IBM274 EBCDIC-BE CP274 csIBM274 }
8327 { IBM275 EBCDIC-BR cp275 csIBM275 }
8328 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8329 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8330 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8331 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8332 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8333 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8334 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8335 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8336 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8337 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8338 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8339 { IBM437 cp437 437 csPC8CodePage437 }
8340 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8341 { IBM775 cp775 csPC775Baltic }
8342 { IBM850 cp850 850 csPC850Multilingual }
8343 { IBM851 cp851 851 csIBM851 }
8344 { IBM852 cp852 852 csPCp852 }
8345 { IBM855 cp855 855 csIBM855 }
8346 { IBM857 cp857 857 csIBM857 }
8347 { IBM860 cp860 860 csIBM860 }
8348 { IBM861 cp861 861 cp-is csIBM861 }
8349 { IBM862 cp862 862 csPC862LatinHebrew }
8350 { IBM863 cp863 863 csIBM863 }
8351 { IBM864 cp864 csIBM864 }
8352 { IBM865 cp865 865 csIBM865 }
8353 { IBM866 cp866 866 csIBM866 }
8354 { IBM868 CP868 cp-ar csIBM868 }
8355 { IBM869 cp869 869 cp-gr csIBM869 }
8356 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8357 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8358 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8359 { IBM891 cp891 csIBM891 }
8360 { IBM903 cp903 csIBM903 }
8361 { IBM904 cp904 904 csIBBM904 }
8362 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8363 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8364 { IBM1026 CP1026 csIBM1026 }
8365 { EBCDIC-AT-DE csIBMEBCDICATDE }
8366 { EBCDIC-AT-DE-A csEBCDICATDEA }
8367 { EBCDIC-CA-FR csEBCDICCAFR }
8368 { EBCDIC-DK-NO csEBCDICDKNO }
8369 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8370 { EBCDIC-FI-SE csEBCDICFISE }
8371 { EBCDIC-FI-SE-A csEBCDICFISEA }
8372 { EBCDIC-FR csEBCDICFR }
8373 { EBCDIC-IT csEBCDICIT }
8374 { EBCDIC-PT csEBCDICPT }
8375 { EBCDIC-ES csEBCDICES }
8376 { EBCDIC-ES-A csEBCDICESA }
8377 { EBCDIC-ES-S csEBCDICESS }
8378 { EBCDIC-UK csEBCDICUK }
8379 { EBCDIC-US csEBCDICUS }
8380 { UNKNOWN-8BIT csUnknown8BiT }
8381 { MNEMONIC csMnemonic }
8386 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8387 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8388 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8389 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8390 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8391 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8392 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8393 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8394 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8395 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8396 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8397 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8398 { IBM1047 IBM-1047 }
8399 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8400 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8401 { UNICODE-1-1 csUnicode11 }
8404 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8405 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8407 { ISO-8859-15 ISO_8859-15 Latin-9 }
8408 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8409 { GBK CP936 MS936 windows-936 }
8410 { JIS_Encoding csJISEncoding }
8411 { Shift_JIS MS_Kanji csShiftJIS }
8412 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8414 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8415 { ISO-10646-UCS-Basic csUnicodeASCII }
8416 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8417 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8418 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8419 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8420 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8421 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8422 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8423 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8424 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8425 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8426 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8427 { Ventura-US csVenturaUS }
8428 { Ventura-International csVenturaInternational }
8429 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8430 { PC8-Turkish csPC8Turkish }
8431 { IBM-Symbols csIBMSymbols }
8432 { IBM-Thai csIBMThai }
8433 { HP-Legal csHPLegal }
8434 { HP-Pi-font csHPPiFont }
8435 { HP-Math8 csHPMath8 }
8436 { Adobe-Symbol-Encoding csHPPSMath }
8437 { HP-DeskTop csHPDesktop }
8438 { Ventura-Math csVenturaMath }
8439 { Microsoft-Publishing csMicrosoftPublishing }
8440 { Windows-31J csWindows31J }
8445 proc tcl_encoding {enc} {
8446 global encoding_aliases
8447 set names [encoding names]
8448 set lcnames [string tolower $names]
8449 set enc [string tolower $enc]
8450 set i [lsearch -exact $lcnames $enc]
8452 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8453 if {[regsub {^iso[-_]} $enc iso encx]} {
8454 set i [lsearch -exact $lcnames $encx]
8458 foreach l $encoding_aliases {
8459 set ll [string tolower $l]
8460 if {[lsearch -exact $ll $enc] < 0} continue
8461 # look through the aliases for one that tcl knows about
8463 set i [lsearch -exact $lcnames $e]
8465 if {[regsub {^iso[-_]} $e iso ex]} {
8466 set i [lsearch -exact $lcnames $ex]
8475 return [lindex $names $i]
8482 set diffopts "-U 5 -p"
8483 set wrcomcmd "git diff-tree --stdin -p --pretty"
8487 set gitencoding [exec git config --get i18n.commitencoding]
8489 if {$gitencoding == ""} {
8490 set gitencoding "utf-8"
8492 set tclencoding [tcl_encoding $gitencoding]
8493 if {$tclencoding == {}} {
8494 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8497 set mainfont {Helvetica 9}
8498 set textfont {Courier 9}
8499 set uifont {Helvetica 9 bold}
8501 set findmergefiles 0
8509 set cmitmode "patch"
8510 set wrapcomment "none"
8514 set showlocalchanges 1
8515 set datetimeformat "%Y-%m-%d %H:%M:%S"
8517 set colors {green red blue magenta darkgrey brown orange}
8520 set diffcolors {red "#00a000" blue}
8522 set selectbgcolor gray85
8524 catch {source ~/.gitk}
8526 font create optionfont -family sans-serif -size -12
8528 parsefont mainfont $mainfont
8529 eval font create mainfont [fontflags mainfont]
8530 eval font create mainfontbold [fontflags mainfont 1]
8532 parsefont textfont $textfont
8533 eval font create textfont [fontflags textfont]
8534 eval font create textfontbold [fontflags textfont 1]
8536 parsefont uifont $uifont
8537 eval font create uifont [fontflags uifont]
8539 # check that we can find a .git directory somewhere...
8540 if {[catch {set gitdir [gitdir]}]} {
8541 show_error {} . "Cannot find a git repository here."
8544 if {![file isdirectory $gitdir]} {
8545 show_error {} . "Cannot find the git directory \"$gitdir\"."
8550 set cmdline_files {}
8555 "-d" { set datemode 1 }
8557 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8561 lappend revtreeargs $arg
8567 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8568 # no -- on command line, but some arguments (other than -d)
8570 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8571 set cmdline_files [split $f "\n"]
8572 set n [llength $cmdline_files]
8573 set revtreeargs [lrange $revtreeargs 0 end-$n]
8574 # Unfortunately git rev-parse doesn't produce an error when
8575 # something is both a revision and a filename. To be consistent
8576 # with git log and git rev-list, check revtreeargs for filenames.
8577 foreach arg $revtreeargs {
8578 if {[file exists $arg]} {
8579 show_error {} . "Ambiguous argument '$arg': both revision\
8585 # unfortunately we get both stdout and stderr in $err,
8586 # so look for "fatal:".
8587 set i [string first "fatal:" $err]
8589 set err [string range $err [expr {$i + 6}] end]
8591 show_error {} . "Bad arguments to gitk:\n$err"
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 None
8622 set highlight_related 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) "Command line"
8648 set viewfiles(1) $cmdline_files
8649 set viewargs(1) $revtreeargs
8652 .bar.view entryconf Edit* -state normal
8653 .bar.view entryconf Delete* -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]