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]
114 nowbusy
$view "Reading"
115 if {$view == $curview} {
117 set progresscoords
{0 0}
122 proc stop_rev_list
{} {
123 global commfd curview
125 if {![info exists commfd
($curview)]} return
126 set fd
$commfd($curview)
132 unset commfd
($curview)
136 global phase canv curview
140 start_rev_list
$curview
141 show_status
"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
629 global rprogitem rprogcoord
633 .bar add cascade
-label "File" -menu .bar.
file
634 .bar configure
-font uifont
636 .bar.
file add
command -label "Update" -command updatecommits
637 .bar.
file add
command -label "Reread references" -command rereadrefs
638 .bar.
file add
command -label "List references" -command showrefs
639 .bar.
file add
command -label "Quit" -command doquit
640 .bar.
file configure
-font uifont
642 .bar add cascade
-label "Edit" -menu .bar.edit
643 .bar.edit add
command -label "Preferences" -command doprefs
644 .bar.edit configure
-font uifont
646 menu .bar.view
-font uifont
647 .bar add cascade
-label "View" -menu .bar.view
648 .bar.view add
command -label "New view..." -command {newview
0}
649 .bar.view add
command -label "Edit view..." -command editview \
651 .bar.view add
command -label "Delete view" -command delview
-state disabled
652 .bar.view add separator
653 .bar.view add radiobutton
-label "All files" -command {showview
0} \
654 -variable selectedview
-value 0
657 .bar add cascade
-label "Help" -menu .bar.
help
658 .bar.
help add
command -label "About gitk" -command about
659 .bar.
help add
command -label "Key bindings" -command keys
660 .bar.
help configure
-font uifont
661 . configure
-menu .bar
663 # the gui has upper and lower half, parts of a paned window.
664 panedwindow .ctop
-orient vertical
666 # possibly use assumed geometry
667 if {![info exists geometry
(pwsash0
)]} {
668 set geometry
(topheight
) [expr {15 * $linespc}]
669 set geometry
(topwidth
) [expr {80 * $charspc}]
670 set geometry
(botheight
) [expr {15 * $linespc}]
671 set geometry
(botwidth
) [expr {50 * $charspc}]
672 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
673 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
676 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
677 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
679 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
681 # create three canvases
682 set cscroll .tf.histframe.csb
683 set canv .tf.histframe.pwclist.canv
685 -selectbackground $selectbgcolor \
686 -background $bgcolor -bd 0 \
687 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
688 .tf.histframe.pwclist add
$canv
689 set canv2 .tf.histframe.pwclist.canv2
691 -selectbackground $selectbgcolor \
692 -background $bgcolor -bd 0 -yscrollincr $linespc
693 .tf.histframe.pwclist add
$canv2
694 set canv3 .tf.histframe.pwclist.canv3
696 -selectbackground $selectbgcolor \
697 -background $bgcolor -bd 0 -yscrollincr $linespc
698 .tf.histframe.pwclist add
$canv3
699 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
700 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
702 # a scroll bar to rule them
703 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
704 pack
$cscroll -side right
-fill y
705 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
706 lappend bglist
$canv $canv2 $canv3
707 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
709 # we have two button bars at bottom of top frame. Bar 1
711 frame .tf.lbar
-height 15
713 set sha1entry .tf.bar.sha1
714 set entries
$sha1entry
715 set sha1but .tf.bar.sha1label
716 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
717 -command gotocommit
-width 8 -font uifont
718 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
719 pack .tf.bar.sha1label
-side left
720 entry
$sha1entry -width 40 -font textfont
-textvariable sha1string
721 trace add variable sha1string
write sha1change
722 pack
$sha1entry -side left
-pady 2
724 image create bitmap bm-left
-data {
725 #define left_width 16
726 #define left_height 16
727 static unsigned char left_bits
[] = {
728 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
729 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
730 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
732 image create bitmap bm-right
-data {
733 #define right_width 16
734 #define right_height 16
735 static unsigned char right_bits
[] = {
736 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
737 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
738 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
740 button .tf.bar.leftbut
-image bm-left
-command goback \
741 -state disabled
-width 26
742 pack .tf.bar.leftbut
-side left
-fill y
743 button .tf.bar.rightbut
-image bm-right
-command goforw \
744 -state disabled
-width 26
745 pack .tf.bar.rightbut
-side left
-fill y
747 # Status label and progress bar
748 set statusw .tf.bar.status
749 label
$statusw -width 15 -relief sunken
-font uifont
750 pack
$statusw -side left
-padx 5
751 set h
[expr {[font metrics uifont
-linespace] + 2}]
752 set progresscanv .tf.bar.progress
753 canvas
$progresscanv -relief sunken
-height $h -borderwidth 2
754 set progressitem
[$progresscanv create rect
-1 0 0 $h -fill green
]
755 set fprogitem
[$progresscanv create rect
-1 0 0 $h -fill yellow
]
756 set rprogitem
[$progresscanv create rect
-1 0 0 $h -fill red
]
757 pack
$progresscanv -side right
-expand 1 -fill x
758 set progresscoords
{0 0}
761 bind $progresscanv <Configure
> adjustprogress
762 set lastprogupdate
[clock clicks
-milliseconds]
763 set progupdatepending
0
765 # build up the bottom bar of upper window
766 label .tf.lbar.flabel
-text "Find " -font uifont
767 button .tf.lbar.fnext
-text "next" -command dofind
-font uifont
768 button .tf.lbar.fprev
-text "prev" -command {dofind
1} -font uifont
769 label .tf.lbar.flab2
-text " commit " -font uifont
770 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
772 set gdttype
"containing:"
773 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype \
776 "adding/removing string:"]
777 trace add variable gdttype
write gdttype_change
778 $gm conf
-font uifont
779 .tf.lbar.gdttype conf
-font uifont
780 pack .tf.lbar.gdttype
-side left
-fill y
783 set fstring .tf.lbar.findstring
784 lappend entries
$fstring
785 entry
$fstring -width 30 -font textfont
-textvariable findstring
786 trace add variable findstring
write find_change
788 set findtypemenu
[tk_optionMenu .tf.lbar.findtype \
789 findtype Exact IgnCase Regexp
]
790 trace add variable findtype
write findcom_change
791 .tf.lbar.findtype configure
-font uifont
792 .tf.lbar.findtype.menu configure
-font uifont
793 set findloc
"All fields"
794 tk_optionMenu .tf.lbar.findloc findloc
"All fields" Headline \
795 Comments Author Committer
796 trace add variable findloc
write find_change
797 .tf.lbar.findloc configure
-font uifont
798 .tf.lbar.findloc.menu configure
-font uifont
799 pack .tf.lbar.findloc
-side right
800 pack .tf.lbar.findtype
-side right
801 pack
$fstring -side left
-expand 1 -fill x
803 # Finish putting the upper half of the viewer together
804 pack .tf.lbar
-in .tf
-side bottom
-fill x
805 pack .tf.bar
-in .tf
-side bottom
-fill x
806 pack .tf.histframe
-fill both
-side top
-expand 1
808 .ctop paneconfigure .tf
-height $geometry(topheight
)
809 .ctop paneconfigure .tf
-width $geometry(topwidth
)
811 # now build up the bottom
812 panedwindow .pwbottom
-orient horizontal
814 # lower left, a text box over search bar, scroll bar to the right
815 # if we know window height, then that will set the lower text height, otherwise
816 # we set lower text height which will drive window height
817 if {[info exists geometry
(main
)]} {
818 frame .bleft
-width $geometry(botwidth
)
820 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
825 button .bleft.top.search
-text "Search" -command dosearch \
827 pack .bleft.top.search
-side left
-padx 5
828 set sstring .bleft.top.sstring
829 entry
$sstring -width 20 -font textfont
-textvariable searchstring
830 lappend entries
$sstring
831 trace add variable searchstring
write incrsearch
832 pack
$sstring -side left
-expand 1 -fill x
833 radiobutton .bleft.mid.
diff -text "Diff" \
834 -command changediffdisp
-variable diffelide
-value {0 0}
835 radiobutton .bleft.mid.old
-text "Old version" \
836 -command changediffdisp
-variable diffelide
-value {0 1}
837 radiobutton .bleft.mid.new
-text "New version" \
838 -command changediffdisp
-variable diffelide
-value {1 0}
839 label .bleft.mid.labeldiffcontext
-text " Lines of context: " \
841 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
842 spinbox .bleft.mid.diffcontext
-width 5 -font textfont \
843 -from 1 -increment 1 -to 10000000 \
844 -validate all
-validatecommand "diffcontextvalidate %P" \
845 -textvariable diffcontextstring
846 .bleft.mid.diffcontext
set $diffcontext
847 trace add variable diffcontextstring
write diffcontextchange
848 lappend entries .bleft.mid.diffcontext
849 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext
-side left
850 set ctext .bleft.ctext
851 text
$ctext -background $bgcolor -foreground $fgcolor \
852 -state disabled
-font textfont \
853 -yscrollcommand scrolltext
-wrap none
855 $ctext conf
-tabstyle wordprocessor
857 scrollbar .bleft.sb
-command "$ctext yview"
858 pack .bleft.top
-side top
-fill x
859 pack .bleft.mid
-side top
-fill x
860 pack .bleft.sb
-side right
-fill y
861 pack
$ctext -side left
-fill both
-expand 1
862 lappend bglist
$ctext
863 lappend fglist
$ctext
865 $ctext tag conf comment
-wrap $wrapcomment
866 $ctext tag conf filesep
-font textfontbold
-back "#aaaaaa"
867 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
868 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
869 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
870 $ctext tag conf m0
-fore red
871 $ctext tag conf m1
-fore blue
872 $ctext tag conf m2
-fore green
873 $ctext tag conf m3
-fore purple
874 $ctext tag conf
m4 -fore brown
875 $ctext tag conf m5
-fore "#009090"
876 $ctext tag conf m6
-fore magenta
877 $ctext tag conf m7
-fore "#808000"
878 $ctext tag conf m8
-fore "#009000"
879 $ctext tag conf m9
-fore "#ff0080"
880 $ctext tag conf m10
-fore cyan
881 $ctext tag conf m11
-fore "#b07070"
882 $ctext tag conf m12
-fore "#70b0f0"
883 $ctext tag conf m13
-fore "#70f0b0"
884 $ctext tag conf m14
-fore "#f0b070"
885 $ctext tag conf m15
-fore "#ff70b0"
886 $ctext tag conf mmax
-fore darkgrey
888 $ctext tag conf mresult
-font textfontbold
889 $ctext tag conf msep
-font textfontbold
890 $ctext tag conf found
-back yellow
893 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
898 radiobutton .bright.mode.
patch -text "Patch" \
899 -command reselectline
-variable cmitmode
-value "patch"
900 .bright.mode.
patch configure
-font uifont
901 radiobutton .bright.mode.tree
-text "Tree" \
902 -command reselectline
-variable cmitmode
-value "tree"
903 .bright.mode.tree configure
-font uifont
904 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
905 pack .bright.mode
-side top
-fill x
906 set cflist .bright.cfiles
907 set indent
[font measure mainfont
"nn"]
909 -selectbackground $selectbgcolor \
910 -background $bgcolor -foreground $fgcolor \
912 -tabs [list
$indent [expr {2 * $indent}]] \
913 -yscrollcommand ".bright.sb set" \
914 -cursor [. cget
-cursor] \
915 -spacing1 1 -spacing3 1
916 lappend bglist
$cflist
917 lappend fglist
$cflist
918 scrollbar .bright.sb
-command "$cflist yview"
919 pack .bright.sb
-side right
-fill y
920 pack
$cflist -side left
-fill both
-expand 1
921 $cflist tag configure highlight \
922 -background [$cflist cget
-selectbackground]
923 $cflist tag configure bold
-font mainfontbold
925 .pwbottom add .bright
928 # restore window position if known
929 if {[info exists geometry
(main
)]} {
930 wm geometry .
"$geometry(main)"
933 if {[tk windowingsystem
] eq
{aqua
}} {
939 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
940 pack .ctop
-fill both
-expand 1
941 bindall
<1> {selcanvline
%W
%x
%y
}
942 #bindall <B1-Motion> {selcanvline %W %x %y}
943 if {[tk windowingsystem
] == "win32"} {
944 bind .
<MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
}
945 bind $ctext <MouseWheel
> { windows_mousewheel_redirector
%W
%X
%Y
%D
; break }
947 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
948 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
950 bindall
<2> "canvscan mark %W %x %y"
951 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
952 bindkey
<Home
> selfirstline
953 bindkey
<End
> sellastline
954 bind .
<Key-Up
> "selnextline -1"
955 bind .
<Key-Down
> "selnextline 1"
956 bindkey
<Key-Right
> "goforw"
957 bindkey
<Key-Left
> "goback"
958 bind .
<Key-Prior
> "selnextpage -1"
959 bind .
<Key-Next
> "selnextpage 1"
960 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
961 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
962 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
963 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
964 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
965 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
966 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
967 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
968 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
969 bindkey p
"selnextline -1"
970 bindkey n
"selnextline 1"
973 bindkey i
"selnextline -1"
974 bindkey k
"selnextline 1"
977 bindkey b
"$ctext yview scroll -1 pages"
978 bindkey d
"$ctext yview scroll 18 units"
979 bindkey u
"$ctext yview scroll -18 units"
980 bindkey
/ {findnext
1}
981 bindkey
<Key-Return
> {findnext
0}
984 bindkey
<F5
> updatecommits
985 bind .
<$M1B-q> doquit
986 bind .
<$M1B-f> dofind
987 bind .
<$M1B-g> {findnext
0}
988 bind .
<$M1B-r> dosearchback
989 bind .
<$M1B-s> dosearch
990 bind .
<$M1B-equal> {incrfont
1}
991 bind .
<$M1B-KP_Add> {incrfont
1}
992 bind .
<$M1B-minus> {incrfont
-1}
993 bind .
<$M1B-KP_Subtract> {incrfont
-1}
994 wm protocol . WM_DELETE_WINDOW doquit
995 bind .
<Button-1
> "click %W"
996 bind $fstring <Key-Return
> dofind
997 bind $sha1entry <Key-Return
> gotocommit
998 bind $sha1entry <<PasteSelection>> clearsha1
999 bind $cflist <1> {sel_flist %W %x %y; break}
1000 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1001 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1002 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1004 set maincursor [. cget -cursor]
1005 set textcursor [$ctext cget -cursor]
1006 set curtextcursor $textcursor
1008 set rowctxmenu .rowctxmenu
1009 menu $rowctxmenu -tearoff 0
1010 $rowctxmenu add command -label "Diff this -> selected" \
1011 -command {diffvssel 0}
1012 $rowctxmenu add command -label "Diff selected -> this" \
1013 -command {diffvssel 1}
1014 $rowctxmenu add command -label "Make patch" -command mkpatch
1015 $rowctxmenu add command -label "Create tag" -command mktag
1016 $rowctxmenu add command -label "Write commit to file" -command writecommit
1017 $rowctxmenu add command -label "Create new branch" -command mkbranch
1018 $rowctxmenu add command -label "Cherry-pick this commit" \
1020 $rowctxmenu add command -label "Reset HEAD branch to here" \
1023 set fakerowmenu .fakerowmenu
1024 menu $fakerowmenu -tearoff 0
1025 $fakerowmenu add command -label "Diff this -> selected" \
1026 -command {diffvssel 0}
1027 $fakerowmenu add command -label "Diff selected -> this" \
1028 -command {diffvssel 1}
1029 $fakerowmenu add command -label "Make patch" -command mkpatch
1030 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1031 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1032 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
1034 set headctxmenu .headctxmenu
1035 menu $headctxmenu -tearoff 0
1036 $headctxmenu add command -label "Check out this branch" \
1038 $headctxmenu add command -label "Remove this branch" \
1042 set flist_menu .flistctxmenu
1043 menu $flist_menu -tearoff 0
1044 $flist_menu add command -label "Highlight this too" \
1045 -command {flist_hl 0}
1046 $flist_menu add command -label "Highlight this only" \
1047 -command {flist_hl 1}
1050 # Windows sends all mouse wheel events to the current focused window, not
1051 # the one where the mouse hovers, so bind those events here and redirect
1052 # to the correct window
1053 proc windows_mousewheel_redirector {W X Y D} {
1054 global canv canv2 canv3
1055 set w [winfo containing -displayof $W $X $Y]
1057 set u [expr {$D < 0 ? 5 : -5}]
1058 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1059 allcanvs yview scroll $u units
1062 $w yview scroll $u units
1068 # mouse-2 makes all windows scan vertically, but only the one
1069 # the cursor is in scans horizontally
1070 proc canvscan {op w x y} {
1071 global canv canv2 canv3
1072 foreach c [list $canv $canv2 $canv3] {
1081 proc scrollcanv {cscroll f0 f1} {
1082 $cscroll set $f0 $f1
1087 # when we make a key binding for the toplevel, make sure
1088 # it doesn't get triggered when that key is pressed in the
1089 # find string entry widget.
1090 proc bindkey {ev script} {
1093 set escript [bind Entry $ev]
1094 if {$escript == {}} {
1095 set escript [bind Entry <Key>]
1097 foreach e $entries {
1098 bind $e $ev "$escript; break"
1102 # set the focus back to the toplevel for any click outside
1105 global ctext entries
1106 foreach e [concat $entries $ctext] {
1107 if {$w == $e} return
1112 # Adjust the progress bar for a change in requested extent or canvas size
1113 proc adjustprogress {} {
1114 global progresscanv progressitem progresscoords
1115 global fprogitem fprogcoord lastprogupdate progupdatepending
1116 global rprogitem rprogcoord
1118 set w [expr {[winfo width $progresscanv] - 4}]
1119 set x0 [expr {$w * [lindex $progresscoords 0]}]
1120 set x1 [expr {$w * [lindex $progresscoords 1]}]
1121 set h [winfo height $progresscanv]
1122 $progresscanv coords $progressitem $x0 0 $x1 $h
1123 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1124 $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1125 set now [clock clicks -milliseconds]
1126 if {$now >= $lastprogupdate + 100} {
1127 set progupdatepending 0
1129 } elseif {!$progupdatepending} {
1130 set progupdatepending 1
1131 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1135 proc doprogupdate {} {
1136 global lastprogupdate progupdatepending
1138 if {$progupdatepending} {
1139 set progupdatepending 0
1140 set lastprogupdate [clock clicks -milliseconds]
1145 proc savestuff {w} {
1146 global canv canv2 canv3 mainfont textfont uifont tabstop
1147 global stuffsaved findmergefiles maxgraphpct
1148 global maxwidth showneartags showlocalchanges
1149 global viewname viewfiles viewargs viewperm nextviewnum
1150 global cmitmode wrapcomment datetimeformat
1151 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1153 if {$stuffsaved} return
1154 if {![winfo viewable .]} return
1156 set f [open "~/.gitk-new" w]
1157 puts $f [list set mainfont $mainfont]
1158 puts $f [list set textfont $textfont]
1159 puts $f [list set uifont $uifont]
1160 puts $f [list set tabstop $tabstop]
1161 puts $f [list set findmergefiles $findmergefiles]
1162 puts $f [list set maxgraphpct $maxgraphpct]
1163 puts $f [list set maxwidth $maxwidth]
1164 puts $f [list set cmitmode $cmitmode]
1165 puts $f [list set wrapcomment $wrapcomment]
1166 puts $f [list set showneartags $showneartags]
1167 puts $f [list set showlocalchanges $showlocalchanges]
1168 puts $f [list set datetimeformat $datetimeformat]
1169 puts $f [list set bgcolor $bgcolor]
1170 puts $f [list set fgcolor $fgcolor]
1171 puts $f [list set colors $colors]
1172 puts $f [list set diffcolors $diffcolors]
1173 puts $f [list set diffcontext $diffcontext]
1174 puts $f [list set selectbgcolor $selectbgcolor]
1176 puts $f "set geometry(main) [wm geometry .]"
1177 puts $f "set geometry(topwidth) [winfo width .tf]"
1178 puts $f "set geometry(topheight) [winfo height .tf]"
1179 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1180 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1181 puts $f "set geometry(botwidth) [winfo width .bleft]"
1182 puts $f "set geometry(botheight) [winfo height .bleft]"
1184 puts -nonewline $f "set permviews {"
1185 for {set v 0} {$v < $nextviewnum} {incr v} {
1186 if {$viewperm($v)} {
1187 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1192 file rename -force "~/.gitk-new" "~/.gitk"
1197 proc resizeclistpanes {win w} {
1199 if {[info exists oldwidth($win)]} {
1200 set s0 [$win sash coord 0]
1201 set s1 [$win sash coord 1]
1203 set sash0 [expr {int($w/2 - 2)}]
1204 set sash1 [expr {int($w*5/6 - 2)}]
1206 set factor [expr {1.0 * $w / $oldwidth($win)}]
1207 set sash0 [expr {int($factor * [lindex $s0 0])}]
1208 set sash1 [expr {int($factor * [lindex $s1 0])}]
1212 if {$sash1 < $sash0 + 20} {
1213 set sash1 [expr {$sash0 + 20}]
1215 if {$sash1 > $w - 10} {
1216 set sash1 [expr {$w - 10}]
1217 if {$sash0 > $sash1 - 20} {
1218 set sash0 [expr {$sash1 - 20}]
1222 $win sash place 0 $sash0 [lindex $s0 1]
1223 $win sash place 1 $sash1 [lindex $s1 1]
1225 set oldwidth($win) $w
1228 proc resizecdetpanes {win w} {
1230 if {[info exists oldwidth($win)]} {
1231 set s0 [$win sash coord 0]
1233 set sash0 [expr {int($w*3/4 - 2)}]
1235 set factor [expr {1.0 * $w / $oldwidth($win)}]
1236 set sash0 [expr {int($factor * [lindex $s0 0])}]
1240 if {$sash0 > $w - 15} {
1241 set sash0 [expr {$w - 15}]
1244 $win sash place 0 $sash0 [lindex $s0 1]
1246 set oldwidth($win) $w
1249 proc allcanvs args {
1250 global canv canv2 canv3
1256 proc bindall {event action} {
1257 global canv canv2 canv3
1258 bind $canv $event $action
1259 bind $canv2 $event $action
1260 bind $canv3 $event $action
1266 if {[winfo exists $w]} {
1271 wm title $w "About gitk"
1272 message $w.m -text {
1273 Gitk - a commit viewer for git
1275 Copyright © 2005-2006 Paul Mackerras
1277 Use and redistribute under the terms of the GNU General Public License} \
1278 -justify center -aspect 400 -border 2 -bg white -relief groove
1279 pack $w.m -side top -fill x -padx 2 -pady 2
1280 $w.m configure -font uifont
1281 button $w.ok -text Close -command "destroy $w" -default active
1282 pack $w.ok -side bottom
1283 $w.ok configure -font uifont
1284 bind $w <Visibility> "focus $w.ok"
1285 bind $w <Key-Escape> "destroy $w"
1286 bind $w <Key-Return> "destroy $w"
1292 if {[winfo exists $w]} {
1296 if {[tk windowingsystem] eq {aqua}} {
1302 wm title $w "Gitk key bindings"
1303 message $w.m -text "
1307 <Home> Move to first commit
1308 <End> Move to last commit
1309 <Up>, p, i Move up one commit
1310 <Down>, n, k Move down one commit
1311 <Left>, z, j Go back in history list
1312 <Right>, x, l Go forward in history list
1313 <PageUp> Move up one page in commit list
1314 <PageDown> Move down one page in commit list
1315 <$M1T-Home> Scroll to top of commit list
1316 <$M1T-End> Scroll to bottom of commit list
1317 <$M1T-Up> Scroll commit list up one line
1318 <$M1T-Down> Scroll commit list down one line
1319 <$M1T-PageUp> Scroll commit list up one page
1320 <$M1T-PageDown> Scroll commit list down one page
1321 <Shift-Up> Move to previous highlighted line
1322 <Shift-Down> Move to next highlighted line
1323 <Delete>, b Scroll diff view up one page
1324 <Backspace> Scroll diff view up one page
1325 <Space> Scroll diff view down one page
1326 u Scroll diff view up 18 lines
1327 d Scroll diff view down 18 lines
1329 <$M1T-G> Move to next find hit
1330 <Return> Move to next find hit
1331 / Move to next find hit, or redo find
1332 ? Move to previous find hit
1333 f Scroll diff view to next file
1334 <$M1T-S> Search for next hit in diff view
1335 <$M1T-R> Search for previous hit in diff view
1336 <$M1T-KP+> Increase font size
1337 <$M1T-plus> Increase font size
1338 <$M1T-KP-> Decrease font size
1339 <$M1T-minus> Decrease font size
1342 -justify left -bg white -border 2 -relief groove
1343 pack $w.m -side top -fill both -padx 2 -pady 2
1344 $w.m configure -font uifont
1345 button $w.ok -text Close -command "destroy $w" -default active
1346 pack $w.ok -side bottom
1347 $w.ok configure -font uifont
1348 bind $w <Visibility> "focus $w.ok"
1349 bind $w <Key-Escape> "destroy $w"
1350 bind $w <Key-Return> "destroy $w"
1353 # Procedures for manipulating the file list window at the
1354 # bottom right of the overall window.
1356 proc treeview {w l openlevs} {
1357 global treecontents treediropen treeheight treeparent treeindex
1367 set treecontents() {}
1368 $w conf -state normal
1370 while {[string range $f 0 $prefixend] ne $prefix} {
1371 if {$lev <= $openlevs} {
1372 $w mark set e:$treeindex($prefix) "end -1c"
1373 $w mark gravity e:$treeindex($prefix) left
1375 set treeheight($prefix) $ht
1376 incr ht [lindex $htstack end]
1377 set htstack [lreplace $htstack end end]
1378 set prefixend [lindex $prefendstack end]
1379 set prefendstack [lreplace $prefendstack end end]
1380 set prefix [string range $prefix 0 $prefixend]
1383 set tail [string range $f [expr {$prefixend+1}] end]
1384 while {[set slash [string first "/" $tail]] >= 0} {
1387 lappend prefendstack $prefixend
1388 incr prefixend [expr {$slash + 1}]
1389 set d [string range $tail 0 $slash]
1390 lappend treecontents($prefix) $d
1391 set oldprefix $prefix
1393 set treecontents($prefix) {}
1394 set treeindex($prefix) [incr ix]
1395 set treeparent($prefix) $oldprefix
1396 set tail [string range $tail [expr {$slash+1}] end]
1397 if {$lev <= $openlevs} {
1399 set treediropen($prefix) [expr {$lev < $openlevs}]
1400 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1401 $w mark set d:$ix "end -1c"
1402 $w mark gravity d:$ix left
1404 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1406 $w image create end -align center -image $bm -padx 1 \
1408 $w insert end $d [highlight_tag $prefix]
1409 $w mark set s:$ix "end -1c"
1410 $w mark gravity s:$ix left
1415 if {$lev <= $openlevs} {
1418 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1420 $w insert end $tail [highlight_tag $f]
1422 lappend treecontents($prefix) $tail
1425 while {$htstack ne {}} {
1426 set treeheight($prefix) $ht
1427 incr ht [lindex $htstack end]
1428 set htstack [lreplace $htstack end end]
1429 set prefixend [lindex $prefendstack end]
1430 set prefendstack [lreplace $prefendstack end end]
1431 set prefix [string range $prefix 0 $prefixend]
1433 $w conf -state disabled
1436 proc linetoelt {l} {
1437 global treeheight treecontents
1442 foreach e $treecontents($prefix) {
1447 if {[string index $e end] eq "/"} {
1448 set n $treeheight($prefix$e)
1460 proc highlight_tree {y prefix} {
1461 global treeheight treecontents cflist
1463 foreach e $treecontents($prefix) {
1465 if {[highlight_tag $path] ne {}} {
1466 $cflist tag add bold $y.0 "$y.0 lineend"
1469 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1470 set y [highlight_tree $y $path]
1476 proc treeclosedir {w dir} {
1477 global treediropen treeheight treeparent treeindex
1479 set ix $treeindex($dir)
1480 $w conf -state normal
1481 $w delete s:$ix e:$ix
1482 set treediropen($dir) 0
1483 $w image configure a:$ix -image tri-rt
1484 $w conf -state disabled
1485 set n [expr {1 - $treeheight($dir)}]
1486 while {$dir ne {}} {
1487 incr treeheight($dir) $n
1488 set dir $treeparent($dir)
1492 proc treeopendir {w dir} {
1493 global treediropen treeheight treeparent treecontents treeindex
1495 set ix $treeindex($dir)
1496 $w conf -state normal
1497 $w image configure a:$ix -image tri-dn
1498 $w mark set e:$ix s:$ix
1499 $w mark gravity e:$ix right
1502 set n [llength $treecontents($dir)]
1503 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1506 incr treeheight($x) $n
1508 foreach e $treecontents($dir) {
1510 if {[string index $e end] eq "/"} {
1511 set iy $treeindex($de)
1512 $w mark set d:$iy e:$ix
1513 $w mark gravity d:$iy left
1514 $w insert e:$ix $str
1515 set treediropen($de) 0
1516 $w image create e:$ix -align center -image tri-rt -padx 1 \
1518 $w insert e:$ix $e [highlight_tag $de]
1519 $w mark set s:$iy e:$ix
1520 $w mark gravity s:$iy left
1521 set treeheight($de) 1
1523 $w insert e:$ix $str
1524 $w insert e:$ix $e [highlight_tag $de]
1527 $w mark gravity e:$ix left
1528 $w conf -state disabled
1529 set treediropen($dir) 1
1530 set top [lindex [split [$w index @0,0] .] 0]
1531 set ht [$w cget -height]
1532 set l [lindex [split [$w index s:$ix] .] 0]
1535 } elseif {$l + $n + 1 > $top + $ht} {
1536 set top [expr {$l + $n + 2 - $ht}]
1544 proc treeclick {w x y} {
1545 global treediropen cmitmode ctext cflist cflist_top
1547 if {$cmitmode ne "tree"} return
1548 if {![info exists cflist_top]} return
1549 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1550 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1551 $cflist tag add highlight $l.0 "$l.0 lineend"
1557 set e [linetoelt $l]
1558 if {[string index $e end] ne "/"} {
1560 } elseif {$treediropen($e)} {
1567 proc setfilelist {id} {
1568 global treefilelist cflist
1570 treeview $cflist $treefilelist($id) 0
1573 image create bitmap tri-rt -background black -foreground blue -data {
1574 #define tri-rt_width 13
1575 #define tri-rt_height 13
1576 static unsigned char tri-rt_bits[] = {
1577 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1578 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1581 #define tri-rt-mask_width 13
1582 #define tri-rt-mask_height 13
1583 static unsigned char tri-rt-mask_bits[] = {
1584 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1585 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1588 image create bitmap tri-dn -background black -foreground blue -data {
1589 #define tri-dn_width 13
1590 #define tri-dn_height 13
1591 static unsigned char tri-dn_bits[] = {
1592 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1593 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1596 #define tri-dn-mask_width 13
1597 #define tri-dn-mask_height 13
1598 static unsigned char tri-dn-mask_bits[] = {
1599 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1600 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1604 image create bitmap reficon-T -background black -foreground yellow -data {
1605 #define tagicon_width 13
1606 #define tagicon_height 9
1607 static unsigned char tagicon_bits[] = {
1608 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1609 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1611 #define tagicon-mask_width 13
1612 #define tagicon-mask_height 9
1613 static unsigned char tagicon-mask_bits[] = {
1614 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1615 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1618 #define headicon_width 13
1619 #define headicon_height 9
1620 static unsigned char headicon_bits[] = {
1621 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1622 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1625 #define headicon-mask_width 13
1626 #define headicon-mask_height 9
1627 static unsigned char headicon-mask_bits[] = {
1628 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1629 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1631 image create bitmap reficon-H -background black -foreground green \
1632 -data $rectdata -maskdata $rectmask
1633 image create bitmap reficon-o -background black -foreground "#ddddff" \
1634 -data $rectdata -maskdata $rectmask
1636 proc init_flist {first} {
1637 global cflist cflist_top selectedline difffilestart
1639 $cflist conf -state normal
1640 $cflist delete 0.0 end
1642 $cflist insert end $first
1644 $cflist tag add highlight 1.0 "1.0 lineend"
1646 catch {unset cflist_top}
1648 $cflist conf -state disabled
1649 set difffilestart {}
1652 proc highlight_tag {f} {
1653 global highlight_paths
1655 foreach p $highlight_paths {
1656 if {[string match $p $f]} {
1663 proc highlight_filelist {} {
1664 global cmitmode cflist
1666 $cflist conf -state normal
1667 if {$cmitmode ne "tree"} {
1668 set end [lindex [split [$cflist index end] .] 0]
1669 for {set l 2} {$l < $end} {incr l} {
1670 set line [$cflist get $l.0 "$l.0 lineend"]
1671 if {[highlight_tag $line] ne {}} {
1672 $cflist tag add bold $l.0 "$l.0 lineend"
1678 $cflist conf -state disabled
1681 proc unhighlight_filelist {} {
1684 $cflist conf -state normal
1685 $cflist tag remove bold 1.0 end
1686 $cflist conf -state disabled
1689 proc add_flist {fl} {
1692 $cflist conf -state normal
1694 $cflist insert end "\n"
1695 $cflist insert end $f [highlight_tag $f]
1697 $cflist conf -state disabled
1700 proc sel_flist {w x y} {
1701 global ctext difffilestart cflist cflist_top cmitmode
1703 if {$cmitmode eq "tree"} return
1704 if {![info exists cflist_top]} return
1705 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1706 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1707 $cflist tag add highlight $l.0 "$l.0 lineend"
1712 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1716 proc pop_flist_menu {w X Y x y} {
1717 global ctext cflist cmitmode flist_menu flist_menu_file
1718 global treediffs diffids
1721 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1723 if {$cmitmode eq "tree"} {
1724 set e [linetoelt $l]
1725 if {[string index $e end] eq "/"} return
1727 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1729 set flist_menu_file $e
1730 tk_popup $flist_menu $X $Y
1733 proc flist_hl {only} {
1734 global flist_menu_file findstring gdttype
1736 set x [shellquote $flist_menu_file]
1737 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1740 append findstring " " $x
1742 set gdttype "touching paths:"
1745 # Functions for adding and removing shell-type quoting
1747 proc shellquote {str} {
1748 if {![string match "*\['\"\\ \t]*" $str]} {
1751 if {![string match "*\['\"\\]*" $str]} {
1754 if {![string match "*'*" $str]} {
1757 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1760 proc shellarglist {l} {
1766 append str [shellquote $a]
1771 proc shelldequote {str} {
1776 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1777 append ret [string range $str $used end]
1778 set used [string length $str]
1781 set first [lindex $first 0]
1782 set ch [string index $str $first]
1783 if {$first > $used} {
1784 append ret [string range $str $used [expr {$first - 1}]]
1787 if {$ch eq " " || $ch eq "\t"} break
1790 set first [string first "'" $str $used]
1792 error "unmatched single-quote"
1794 append ret [string range $str $used [expr {$first - 1}]]
1799 if {$used >= [string length $str]} {
1800 error "trailing backslash"
1802 append ret [string index $str $used]
1807 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1808 error "unmatched double-quote"
1810 set first [lindex $first 0]
1811 set ch [string index $str $first]
1812 if {$first > $used} {
1813 append ret [string range $str $used [expr {$first - 1}]]
1816 if {$ch eq "\""} break
1818 append ret [string index $str $used]
1822 return [list $used $ret]
1825 proc shellsplit {str} {
1828 set str [string trimleft $str]
1829 if {$str eq {}} break
1830 set dq [shelldequote $str]
1831 set n [lindex $dq 0]
1832 set word [lindex $dq 1]
1833 set str [string range $str $n end]
1839 # Code to implement multiple views
1841 proc newview {ishighlight} {
1842 global nextviewnum newviewname newviewperm uifont newishighlight
1843 global newviewargs revtreeargs
1845 set newishighlight $ishighlight
1847 if {[winfo exists $top]} {
1851 set newviewname($nextviewnum) "View $nextviewnum"
1852 set newviewperm($nextviewnum) 0
1853 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1854 vieweditor $top $nextviewnum "Gitk view definition"
1859 global viewname viewperm newviewname newviewperm
1860 global viewargs newviewargs
1862 set top .gitkvedit-$curview
1863 if {[winfo exists $top]} {
1867 set newviewname($curview) $viewname($curview)
1868 set newviewperm($curview) $viewperm($curview)
1869 set newviewargs($curview) [shellarglist $viewargs($curview)]
1870 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1873 proc vieweditor {top n title} {
1874 global newviewname newviewperm viewfiles
1878 wm title $top $title
1879 label $top.nl -text "Name" -font uifont
1880 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1881 grid $top.nl $top.name -sticky w -pady 5
1882 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1884 grid $top.perm - -pady 5 -sticky w
1885 message $top.al -aspect 1000 -font uifont \
1886 -text "Commits to include (arguments to git rev-list):"
1887 grid $top.al - -sticky w -pady 5
1888 entry $top.args -width 50 -textvariable newviewargs($n) \
1889 -background white -font uifont
1890 grid $top.args - -sticky ew -padx 5
1891 message $top.l -aspect 1000 -font uifont \
1892 -text "Enter files and directories to include, one per line:"
1893 grid $top.l - -sticky w
1894 text $top.t -width 40 -height 10 -background white -font uifont
1895 if {[info exists viewfiles($n)]} {
1896 foreach f $viewfiles($n) {
1897 $top.t insert end $f
1898 $top.t insert end "\n"
1900 $top.t delete {end - 1c} end
1901 $top.t mark set insert 0.0
1903 grid $top.t - -sticky ew -padx 5
1905 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1907 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1909 grid $top.buts.ok $top.buts.can
1910 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1911 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1912 grid $top.buts - -pady 10 -sticky ew
1916 proc doviewmenu {m first cmd op argv} {
1917 set nmenu [$m index end]
1918 for {set i $first} {$i <= $nmenu} {incr i} {
1919 if {[$m entrycget $i -command] eq $cmd} {
1920 eval $m $op $i $argv
1926 proc allviewmenus {n op args} {
1929 doviewmenu .bar.view 5 [list showview $n] $op $args
1930 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1933 proc newviewok {top n} {
1934 global nextviewnum newviewperm newviewname newishighlight
1935 global viewname viewfiles viewperm selectedview curview
1936 global viewargs newviewargs viewhlmenu
1939 set newargs [shellsplit $newviewargs($n)]
1941 error_popup "Error in commit selection arguments: $err"
1947 foreach f [split [$top.t get 0.0 end] "\n"] {
1948 set ft [string trim $f]
1953 if {![info exists viewfiles($n)]} {
1954 # creating a new view
1956 set viewname($n) $newviewname($n)
1957 set viewperm($n) $newviewperm($n)
1958 set viewfiles($n) $files
1959 set viewargs($n) $newargs
1961 if {!$newishighlight} {
1964 run addvhighlight $n
1967 # editing an existing view
1968 set viewperm($n) $newviewperm($n)
1969 if {$newviewname($n) ne $viewname($n)} {
1970 set viewname($n) $newviewname($n)
1971 doviewmenu .bar.view 5 [list showview $n] \
1972 entryconf [list -label $viewname($n)]
1973 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1974 # entryconf [list -label $viewname($n) -value $viewname($n)]
1976 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1977 set viewfiles($n) $files
1978 set viewargs($n) $newargs
1979 if {$curview == $n} {
1984 catch {destroy $top}
1988 global curview viewdata viewperm hlview selectedhlview
1990 if {$curview == 0} return
1991 if {[info exists hlview] && $hlview == $curview} {
1992 set selectedhlview None
1995 allviewmenus $curview delete
1996 set viewdata($curview) {}
1997 set viewperm($curview) 0
2001 proc addviewmenu {n} {
2002 global viewname viewhlmenu
2004 .bar.view add radiobutton -label $viewname($n) \
2005 -command [list showview $n] -variable selectedview -value $n
2006 #$viewhlmenu add radiobutton -label $viewname($n) \
2007 # -command [list addvhighlight $n] -variable selectedhlview
2010 proc flatten {var} {
2014 foreach i [array names $var] {
2015 lappend ret $i [set $var\($i\)]
2020 proc unflatten {var l} {
2030 global curview viewdata viewfiles
2031 global displayorder parentlist rowidlist rowisopt rowfinal
2032 global colormap rowtextx commitrow nextcolor canvxmax
2033 global numcommits commitlisted
2034 global selectedline currentid canv canvy0
2036 global pending_select phase
2039 global selectedview selectfirst
2040 global vparentlist vdisporder vcmitlisted
2041 global hlview selectedhlview commitinterest
2043 if {$n == $curview} return
2045 if {[info exists selectedline]} {
2046 set selid $currentid
2047 set y [yc $selectedline]
2048 set ymax [lindex [$canv cget -scrollregion] 3]
2049 set span [$canv yview]
2050 set ytop [expr {[lindex $span 0] * $ymax}]
2051 set ybot [expr {[lindex $span 1] * $ymax}]
2052 if {$ytop < $y && $y < $ybot} {
2053 set yscreen [expr {$y - $ytop}]
2055 set yscreen [expr {($ybot - $ytop) / 2}]
2057 } elseif {[info exists pending_select]} {
2058 set selid $pending_select
2059 unset pending_select
2063 if {$curview >= 0} {
2064 set vparentlist($curview) $parentlist
2065 set vdisporder($curview) $displayorder
2066 set vcmitlisted($curview) $commitlisted
2068 ![info exists viewdata($curview)] ||
2069 [lindex $viewdata($curview) 0] ne {}} {
2070 set viewdata($curview) \
2071 [list $phase $rowidlist $rowisopt $rowfinal]
2074 catch {unset treediffs}
2076 if {[info exists hlview] && $hlview == $n} {
2078 set selectedhlview None
2080 catch {unset commitinterest}
2084 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2085 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2088 if {![info exists viewdata($n)]} {
2090 set pending_select $selid
2097 set phase [lindex $v 0]
2098 set displayorder $vdisporder($n)
2099 set parentlist $vparentlist($n)
2100 set commitlisted $vcmitlisted($n)
2101 set rowidlist [lindex $v 1]
2102 set rowisopt [lindex $v 2]
2103 set rowfinal [lindex $v 3]
2104 set numcommits $commitidx($n)
2106 catch {unset colormap}
2107 catch {unset rowtextx}
2109 set canvxmax [$canv cget -width]
2116 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2117 set row $commitrow($n,$selid)
2118 # try to get the selected row in the same position on the screen
2119 set ymax [lindex [$canv cget -scrollregion] 3]
2120 set ytop [expr {[yc $row] - $yscreen}]
2124 set yf [expr {$ytop * 1.0 / $ymax}]
2126 allcanvs yview moveto $yf
2130 } elseif {$selid ne {}} {
2131 set pending_select $selid
2133 set row [first_real_row]
2134 if {$row < $numcommits} {
2141 if {$phase eq "getcommits"} {
2142 show_status "Reading commits..."
2145 } elseif {$numcommits == 0} {
2146 show_status "No commits selected"
2150 # Stuff relating to the highlighting facility
2152 proc ishighlighted {row} {
2153 global vhighlights fhighlights nhighlights rhighlights
2155 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2156 return $nhighlights($row)
2158 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2159 return $vhighlights($row)
2161 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2162 return $fhighlights($row)
2164 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2165 return $rhighlights($row)
2170 proc bolden {row font} {
2171 global canv linehtag selectedline boldrows
2173 lappend boldrows $row
2174 $canv itemconf $linehtag($row) -font $font
2175 if {[info exists selectedline] && $row == $selectedline} {
2177 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2178 -outline {{}} -tags secsel \
2179 -fill [$canv cget -selectbackground]]
2184 proc bolden_name {row font} {
2185 global canv2 linentag selectedline boldnamerows
2187 lappend boldnamerows $row
2188 $canv2 itemconf $linentag($row) -font $font
2189 if {[info exists selectedline] && $row == $selectedline} {
2190 $canv2 delete secsel
2191 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2192 -outline {{}} -tags secsel \
2193 -fill [$canv2 cget -selectbackground]]
2202 foreach row $boldrows {
2203 if {![ishighlighted $row]} {
2204 bolden $row mainfont
2206 lappend stillbold $row
2209 set boldrows $stillbold
2212 proc addvhighlight {n} {
2213 global hlview curview viewdata vhl_done vhighlights commitidx
2215 if {[info exists hlview]} {
2219 if {$n != $curview && ![info exists viewdata($n)]} {
2220 set viewdata($n) [list getcommits {{}} 0 0 0]
2221 set vparentlist($n) {}
2222 set vdisporder($n) {}
2223 set vcmitlisted($n) {}
2226 set vhl_done $commitidx($hlview)
2227 if {$vhl_done > 0} {
2232 proc delvhighlight {} {
2233 global hlview vhighlights
2235 if {![info exists hlview]} return
2237 catch {unset vhighlights}
2241 proc vhighlightmore {} {
2242 global hlview vhl_done commitidx vhighlights
2243 global displayorder vdisporder curview
2245 set max $commitidx($hlview)
2246 if {$hlview == $curview} {
2247 set disp $displayorder
2249 set disp $vdisporder($hlview)
2251 set vr [visiblerows]
2252 set r0 [lindex $vr 0]
2253 set r1 [lindex $vr 1]
2254 for {set i $vhl_done} {$i < $max} {incr i} {
2255 set id [lindex $disp $i]
2256 if {[info exists commitrow($curview,$id)]} {
2257 set row $commitrow($curview,$id)
2258 if {$r0 <= $row && $row <= $r1} {
2259 if {![highlighted $row]} {
2260 bolden $row mainfontbold
2262 set vhighlights($row) 1
2269 proc askvhighlight {row id} {
2270 global hlview vhighlights commitrow iddrawn
2272 if {[info exists commitrow($hlview,$id)]} {
2273 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2274 bolden $row mainfontbold
2276 set vhighlights($row) 1
2278 set vhighlights($row) 0
2282 proc hfiles_change {} {
2283 global highlight_files filehighlight fhighlights fh_serial
2284 global highlight_paths gdttype
2286 if {[info exists filehighlight]} {
2287 # delete previous highlights
2288 catch {close $filehighlight}
2290 catch {unset fhighlights}
2292 unhighlight_filelist
2294 set highlight_paths {}
2295 after cancel do_file_hl $fh_serial
2297 if {$highlight_files ne {}} {
2298 after 300 do_file_hl $fh_serial
2302 proc gdttype_change {name ix op} {
2303 global gdttype highlight_files findstring findpattern
2306 if {$findstring ne {}} {
2307 if {$gdttype eq "containing:"} {
2308 if {$highlight_files ne {}} {
2309 set highlight_files {}
2314 if {$findpattern ne {}} {
2318 set highlight_files $findstring
2323 # enable/disable findtype/findloc menus too
2326 proc find_change {name ix op} {
2327 global gdttype findstring highlight_files
2330 if {$gdttype eq "containing:"} {
2333 if {$highlight_files ne $findstring} {
2334 set highlight_files $findstring
2341 proc findcom_change args {
2342 global nhighlights boldnamerows
2343 global findpattern findtype findstring gdttype
2346 # delete previous highlights, if any
2347 foreach row $boldnamerows {
2348 bolden_name $row mainfont
2351 catch {unset nhighlights}
2354 if {$gdttype ne "containing:" || $findstring eq {}} {
2356 } elseif {$findtype eq "Regexp"} {
2357 set findpattern $findstring
2359 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2361 set findpattern "*$e*"
2365 proc makepatterns {l} {
2368 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2369 if {[string index $ee end] eq "/"} {
2379 proc do_file_hl {serial} {
2380 global highlight_files filehighlight highlight_paths gdttype fhl_list
2382 if {$gdttype eq "touching paths:"} {
2383 if {[catch {set paths [shellsplit $highlight_files]}]} return
2384 set highlight_paths [makepatterns $paths]
2386 set gdtargs [concat -- $paths]
2387 } elseif {$gdttype eq "adding/removing string:"} {
2388 set gdtargs [list "-S$highlight_files"]
2390 # must be "containing:", i.e. we're searching commit info
2393 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2394 set filehighlight [open $cmd r+]
2395 fconfigure $filehighlight -blocking 0
2396 filerun $filehighlight readfhighlight
2402 proc flushhighlights {} {
2403 global filehighlight fhl_list
2405 if {[info exists filehighlight]} {
2407 puts $filehighlight ""
2408 flush $filehighlight
2412 proc askfilehighlight {row id} {
2413 global filehighlight fhighlights fhl_list
2415 lappend fhl_list $id
2416 set fhighlights($row) -1
2417 puts $filehighlight $id
2420 proc readfhighlight {} {
2421 global filehighlight fhighlights commitrow curview iddrawn
2422 global fhl_list find_dirn
2424 if {![info exists filehighlight]} {
2428 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2429 set line [string trim $line]
2430 set i [lsearch -exact $fhl_list $line]
2431 if {$i < 0} continue
2432 for {set j 0} {$j < $i} {incr j} {
2433 set id [lindex $fhl_list $j]
2434 if {[info exists commitrow($curview,$id)]} {
2435 set fhighlights($commitrow($curview,$id)) 0
2438 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2439 if {$line eq {}} continue
2440 if {![info exists commitrow($curview,$line)]} continue
2441 set row $commitrow($curview,$line)
2442 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2443 bolden $row mainfontbold
2445 set fhighlights($row) 1
2447 if {[eof $filehighlight]} {
2449 puts "oops, git diff-tree died"
2450 catch {close $filehighlight}
2454 if {[info exists find_dirn]} {
2455 if {$find_dirn > 0} {
2464 proc doesmatch {f} {
2465 global findtype findpattern
2467 if {$findtype eq "Regexp"} {
2468 return [regexp $findpattern $f]
2469 } elseif {$findtype eq "IgnCase"} {
2470 return [string match -nocase $findpattern $f]
2472 return [string match $findpattern $f]
2476 proc askfindhighlight {row id} {
2477 global nhighlights commitinfo iddrawn
2479 global markingmatches
2481 if {![info exists commitinfo($id)]} {
2484 set info $commitinfo($id)
2486 set fldtypes {Headline Author Date Committer CDate Comments}
2487 foreach f $info ty $fldtypes {
2488 if {($findloc eq "All fields" || $findloc eq $ty) &&
2490 if {$ty eq "Author"} {
2497 if {$isbold && [info exists iddrawn($id)]} {
2498 if {![ishighlighted $row]} {
2499 bolden $row mainfontbold
2501 bolden_name $row mainfontbold
2504 if {$markingmatches} {
2505 markrowmatches $row $id
2508 set nhighlights($row) $isbold
2511 proc markrowmatches {row id} {
2512 global canv canv2 linehtag linentag commitinfo findloc
2514 set headline [lindex $commitinfo($id) 0]
2515 set author [lindex $commitinfo($id) 1]
2516 $canv delete match$row
2517 $canv2 delete match$row
2518 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2519 set m [findmatches $headline]
2521 markmatches $canv $row $headline $linehtag($row) $m \
2522 [$canv itemcget $linehtag($row) -font] $row
2525 if {$findloc eq "All fields" || $findloc eq "Author"} {
2526 set m [findmatches $author]
2528 markmatches $canv2 $row $author $linentag($row) $m \
2529 [$canv2 itemcget $linentag($row) -font] $row
2534 proc vrel_change {name ix op} {
2535 global highlight_related
2538 if {$highlight_related ne "None"} {
2543 # prepare for testing whether commits are descendents or ancestors of a
2544 proc rhighlight_sel {a} {
2545 global descendent desc_todo ancestor anc_todo
2546 global highlight_related rhighlights
2548 catch {unset descendent}
2549 set desc_todo [list $a]
2550 catch {unset ancestor}
2551 set anc_todo [list $a]
2552 if {$highlight_related ne "None"} {
2558 proc rhighlight_none {} {
2561 catch {unset rhighlights}
2565 proc is_descendent {a} {
2566 global curview children commitrow descendent desc_todo
2569 set la $commitrow($v,$a)
2573 for {set i 0} {$i < [llength $todo]} {incr i} {
2574 set do [lindex $todo $i]
2575 if {$commitrow($v,$do) < $la} {
2576 lappend leftover $do
2579 foreach nk $children($v,$do) {
2580 if {![info exists descendent($nk)]} {
2581 set descendent($nk) 1
2589 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2593 set descendent($a) 0
2594 set desc_todo $leftover
2597 proc is_ancestor {a} {
2598 global curview parentlist commitrow ancestor anc_todo
2601 set la $commitrow($v,$a)
2605 for {set i 0} {$i < [llength $todo]} {incr i} {
2606 set do [lindex $todo $i]
2607 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2608 lappend leftover $do
2611 foreach np [lindex $parentlist $commitrow($v,$do)] {
2612 if {![info exists ancestor($np)]} {
2621 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2626 set anc_todo $leftover
2629 proc askrelhighlight {row id} {
2630 global descendent highlight_related iddrawn rhighlights
2631 global selectedline ancestor
2633 if {![info exists selectedline]} return
2635 if {$highlight_related eq "Descendent" ||
2636 $highlight_related eq "Not descendent"} {
2637 if {![info exists descendent($id)]} {
2640 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2643 } elseif {$highlight_related eq "Ancestor" ||
2644 $highlight_related eq "Not ancestor"} {
2645 if {![info exists ancestor($id)]} {
2648 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2652 if {[info exists iddrawn($id)]} {
2653 if {$isbold && ![ishighlighted $row]} {
2654 bolden $row mainfontbold
2657 set rhighlights($row) $isbold
2660 # Graph layout functions
2662 proc shortids {ids} {
2665 if {[llength $id] > 1} {
2666 lappend res [shortids $id]
2667 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2668 lappend res [string range $id 0 7]
2679 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2680 if {($n & $mask) != 0} {
2681 set ret [concat $ret $o]
2683 set o [concat $o $o]
2688 # Work out where id should go in idlist so that order-token
2689 # values increase from left to right
2690 proc idcol {idlist id {i 0}} {
2691 global ordertok curview
2693 set t $ordertok($curview,$id)
2694 if {$i >= [llength $idlist] ||
2695 $t < $ordertok($curview,[lindex $idlist $i])} {
2696 if {$i > [llength $idlist]} {
2697 set i [llength $idlist]
2699 while {[incr i -1] >= 0 &&
2700 $t < $ordertok($curview,[lindex $idlist $i])} {}
2703 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2704 while {[incr i] < [llength $idlist] &&
2705 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2711 proc initlayout {} {
2712 global rowidlist rowisopt rowfinal displayorder commitlisted
2713 global numcommits canvxmax canv
2716 global colormap rowtextx
2727 set canvxmax [$canv cget -width]
2728 catch {unset colormap}
2729 catch {unset rowtextx}
2733 proc setcanvscroll {} {
2734 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2736 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2737 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2738 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2739 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2742 proc visiblerows {} {
2743 global canv numcommits linespc
2745 set ymax [lindex [$canv cget -scrollregion] 3]
2746 if {$ymax eq {} || $ymax == 0} return
2748 set y0 [expr {int([lindex $f 0] * $ymax)}]
2749 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2753 set y1 [expr {int([lindex $f 1] * $ymax)}]
2754 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2755 if {$r1 >= $numcommits} {
2756 set r1 [expr {$numcommits - 1}]
2758 return [list $r0 $r1]
2761 proc layoutmore {} {
2762 global commitidx viewcomplete numcommits
2763 global uparrowlen downarrowlen mingaplen curview
2765 set show $commitidx($curview)
2766 if {$show > $numcommits || $viewcomplete($curview)} {
2767 showstuff $show $viewcomplete($curview)
2771 proc showstuff {canshow last} {
2772 global numcommits commitrow pending_select selectedline curview
2773 global mainheadid displayorder selectfirst
2774 global lastscrollset commitinterest
2776 if {$numcommits == 0} {
2778 set phase "incrdraw"
2782 set prev $numcommits
2783 set numcommits $canshow
2784 set t [clock clicks -milliseconds]
2785 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2786 set lastscrollset $t
2789 set rows [visiblerows]
2790 set r1 [lindex $rows 1]
2791 if {$r1 >= $canshow} {
2792 set r1 [expr {$canshow - 1}]
2797 if {[info exists pending_select] &&
2798 [info exists commitrow($curview,$pending_select)] &&
2799 $commitrow($curview,$pending_select) < $numcommits} {
2800 selectline $commitrow($curview,$pending_select) 1
2803 if {[info exists selectedline] || [info exists pending_select]} {
2806 set l [first_real_row]
2813 proc doshowlocalchanges {} {
2814 global curview mainheadid phase commitrow
2816 if {[info exists commitrow($curview,$mainheadid)] &&
2817 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2819 } elseif {$phase ne {}} {
2820 lappend commitinterest($mainheadid) {}
2824 proc dohidelocalchanges {} {
2825 global localfrow localirow lserial
2827 if {$localfrow >= 0} {
2828 removerow $localfrow
2830 if {$localirow > 0} {
2834 if {$localirow >= 0} {
2835 removerow $localirow
2841 # spawn off a process to do git diff-index --cached HEAD
2842 proc dodiffindex {} {
2843 global localirow localfrow lserial showlocalchanges
2845 if {!$showlocalchanges} return
2849 set fd [open "|git diff-index --cached HEAD" r]
2850 fconfigure $fd -blocking 0
2851 filerun $fd [list readdiffindex $fd $lserial]
2854 proc readdiffindex {fd serial} {
2855 global localirow commitrow mainheadid nullid2 curview
2856 global commitinfo commitdata lserial
2859 if {[gets $fd line] < 0} {
2865 # we only need to see one line and we don't really care what it says...
2868 # now see if there are any local changes not checked in to the index
2869 if {$serial == $lserial} {
2870 set fd [open "|git diff-files" r]
2871 fconfigure $fd -blocking 0
2872 filerun $fd [list readdifffiles $fd $serial]
2875 if {$isdiff && $serial == $lserial && $localirow == -1} {
2876 # add the line for the changes in the index to the graph
2877 set localirow $commitrow($curview,$mainheadid)
2878 set hl "Local changes checked in to index but not committed"
2879 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2880 set commitdata($nullid2) "\n $hl\n"
2881 insertrow $localirow $nullid2
2886 proc readdifffiles {fd serial} {
2887 global localirow localfrow commitrow mainheadid nullid curview
2888 global commitinfo commitdata lserial
2891 if {[gets $fd line] < 0} {
2897 # we only need to see one line and we don't really care what it says...
2900 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2901 # add the line for the local diff to the graph
2902 if {$localirow >= 0} {
2903 set localfrow $localirow
2906 set localfrow $commitrow($curview,$mainheadid)
2908 set hl "Local uncommitted changes, not checked in to index"
2909 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2910 set commitdata($nullid) "\n $hl\n"
2911 insertrow $localfrow $nullid
2916 proc nextuse {id row} {
2917 global commitrow curview children
2919 if {[info exists children($curview,$id)]} {
2920 foreach kid $children($curview,$id) {
2921 if {![info exists commitrow($curview,$kid)]} {
2924 if {$commitrow($curview,$kid) > $row} {
2925 return $commitrow($curview,$kid)
2929 if {[info exists commitrow($curview,$id)]} {
2930 return $commitrow($curview,$id)
2935 proc prevuse {id row} {
2936 global commitrow curview children
2939 if {[info exists children($curview,$id)]} {
2940 foreach kid $children($curview,$id) {
2941 if {![info exists commitrow($curview,$kid)]} break
2942 if {$commitrow($curview,$kid) < $row} {
2943 set ret $commitrow($curview,$kid)
2950 proc make_idlist {row} {
2951 global displayorder parentlist uparrowlen downarrowlen mingaplen
2952 global commitidx curview ordertok children commitrow
2954 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2958 set ra [expr {$row - $downarrowlen}]
2962 set rb [expr {$row + $uparrowlen}]
2963 if {$rb > $commitidx($curview)} {
2964 set rb $commitidx($curview)
2967 for {} {$r < $ra} {incr r} {
2968 set nextid [lindex $displayorder [expr {$r + 1}]]
2969 foreach p [lindex $parentlist $r] {
2970 if {$p eq $nextid} continue
2971 set rn [nextuse $p $r]
2973 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2974 lappend ids [list $ordertok($curview,$p) $p]
2978 for {} {$r < $row} {incr r} {
2979 set nextid [lindex $displayorder [expr {$r + 1}]]
2980 foreach p [lindex $parentlist $r] {
2981 if {$p eq $nextid} continue
2982 set rn [nextuse $p $r]
2983 if {$rn < 0 || $rn >= $row} {
2984 lappend ids [list $ordertok($curview,$p) $p]
2988 set id [lindex $displayorder $row]
2989 lappend ids [list $ordertok($curview,$id) $id]
2991 foreach p [lindex $parentlist $r] {
2992 set firstkid [lindex $children($curview,$p) 0]
2993 if {$commitrow($curview,$firstkid) < $row} {
2994 lappend ids [list $ordertok($curview,$p) $p]
2998 set id [lindex $displayorder $r]
3000 set firstkid [lindex $children($curview,$id) 0]
3001 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3002 lappend ids [list $ordertok($curview,$id) $id]
3007 foreach idx [lsort -unique $ids] {
3008 lappend idlist [lindex $idx 1]
3013 proc rowsequal {a b} {
3014 while {[set i [lsearch -exact $a {}]] >= 0} {
3015 set a [lreplace $a $i $i]
3017 while {[set i [lsearch -exact $b {}]] >= 0} {
3018 set b [lreplace $b $i $i]
3020 return [expr {$a eq $b}]
3023 proc makeupline {id row rend col} {
3024 global rowidlist uparrowlen downarrowlen mingaplen
3026 for {set r $rend} {1} {set r $rstart} {
3027 set rstart [prevuse $id $r]
3028 if {$rstart < 0} return
3029 if {$rstart < $row} break
3031 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3032 set rstart [expr {$rend - $uparrowlen - 1}]
3034 for {set r $rstart} {[incr r] <= $row} {} {
3035 set idlist [lindex $rowidlist $r]
3036 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3037 set col [idcol $idlist $id $col]
3038 lset rowidlist $r [linsert $idlist $col $id]
3044 proc layoutrows {row endrow} {
3045 global rowidlist rowisopt rowfinal displayorder
3046 global uparrowlen downarrowlen maxwidth mingaplen
3047 global children parentlist
3048 global commitidx viewcomplete curview commitrow
3052 set rm1 [expr {$row - 1}]
3053 foreach id [lindex $rowidlist $rm1] {
3058 set final [lindex $rowfinal $rm1]
3060 for {} {$row < $endrow} {incr row} {
3061 set rm1 [expr {$row - 1}]
3062 if {$rm1 < 0 || $idlist eq {}} {
3063 set idlist [make_idlist $row]
3066 set id [lindex $displayorder $rm1]
3067 set col [lsearch -exact $idlist $id]
3068 set idlist [lreplace $idlist $col $col]
3069 foreach p [lindex $parentlist $rm1] {
3070 if {[lsearch -exact $idlist $p] < 0} {
3071 set col [idcol $idlist $p $col]
3072 set idlist [linsert $idlist $col $p]
3073 # if not the first child, we have to insert a line going up
3074 if {$id ne [lindex $children($curview,$p) 0]} {
3075 makeupline $p $rm1 $row $col
3079 set id [lindex $displayorder $row]
3080 if {$row > $downarrowlen} {
3081 set termrow [expr {$row - $downarrowlen - 1}]
3082 foreach p [lindex $parentlist $termrow] {
3083 set i [lsearch -exact $idlist $p]
3084 if {$i < 0} continue
3085 set nr [nextuse $p $termrow]
3086 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3087 set idlist [lreplace $idlist $i $i]
3091 set col [lsearch -exact $idlist $id]
3093 set col [idcol $idlist $id]
3094 set idlist [linsert $idlist $col $id]
3095 if {$children($curview,$id) ne {}} {
3096 makeupline $id $rm1 $row $col
3099 set r [expr {$row + $uparrowlen - 1}]
3100 if {$r < $commitidx($curview)} {
3102 foreach p [lindex $parentlist $r] {
3103 if {[lsearch -exact $idlist $p] >= 0} continue
3104 set fk [lindex $children($curview,$p) 0]
3105 if {$commitrow($curview,$fk) < $row} {
3106 set x [idcol $idlist $p $x]
3107 set idlist [linsert $idlist $x $p]
3110 if {[incr r] < $commitidx($curview)} {
3111 set p [lindex $displayorder $r]
3112 if {[lsearch -exact $idlist $p] < 0} {
3113 set fk [lindex $children($curview,$p) 0]
3114 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3115 set x [idcol $idlist $p $x]
3116 set idlist [linsert $idlist $x $p]
3122 if {$final && !$viewcomplete($curview) &&
3123 $row + $uparrowlen + $mingaplen + $downarrowlen
3124 >= $commitidx($curview)} {
3127 set l [llength $rowidlist]
3129 lappend rowidlist $idlist
3131 lappend rowfinal $final
3132 } elseif {$row < $l} {
3133 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3134 lset rowidlist $row $idlist
3137 lset rowfinal $row $final
3139 set pad [ntimes [expr {$row - $l}] {}]
3140 set rowidlist [concat $rowidlist $pad]
3141 lappend rowidlist $idlist
3142 set rowfinal [concat $rowfinal $pad]
3143 lappend rowfinal $final
3144 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3150 proc changedrow {row} {
3151 global displayorder iddrawn rowisopt need_redisplay
3153 set l [llength $rowisopt]
3155 lset rowisopt $row 0
3156 if {$row + 1 < $l} {
3157 lset rowisopt [expr {$row + 1}] 0
3158 if {$row + 2 < $l} {
3159 lset rowisopt [expr {$row + 2}] 0
3163 set id [lindex $displayorder $row]
3164 if {[info exists iddrawn($id)]} {
3165 set need_redisplay 1
3169 proc insert_pad {row col npad} {
3172 set pad [ntimes $npad {}]
3173 set idlist [lindex $rowidlist $row]
3174 set bef [lrange $idlist 0 [expr {$col - 1}]]
3175 set aft [lrange $idlist $col end]
3176 set i [lsearch -exact $aft {}]
3178 set aft [lreplace $aft $i $i]
3180 lset rowidlist $row [concat $bef $pad $aft]
3184 proc optimize_rows {row col endrow} {
3185 global rowidlist rowisopt displayorder curview children
3190 for {} {$row < $endrow} {incr row; set col 0} {
3191 if {[lindex $rowisopt $row]} continue
3193 set y0 [expr {$row - 1}]
3194 set ym [expr {$row - 2}]
3195 set idlist [lindex $rowidlist $row]
3196 set previdlist [lindex $rowidlist $y0]
3197 if {$idlist eq {} || $previdlist eq {}} continue
3199 set pprevidlist [lindex $rowidlist $ym]
3200 if {$pprevidlist eq {}} continue
3206 for {} {$col < [llength $idlist]} {incr col} {
3207 set id [lindex $idlist $col]
3208 if {[lindex $previdlist $col] eq $id} continue
3213 set x0 [lsearch -exact $previdlist $id]
3214 if {$x0 < 0} continue
3215 set z [expr {$x0 - $col}]
3219 set xm [lsearch -exact $pprevidlist $id]
3221 set z0 [expr {$xm - $x0}]
3225 # if row y0 is the first child of $id then it's not an arrow
3226 if {[lindex $children($curview,$id) 0] ne
3227 [lindex $displayorder $y0]} {
3231 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3232 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3235 # Looking at lines from this row to the previous row,
3236 # make them go straight up if they end in an arrow on
3237 # the previous row; otherwise make them go straight up
3239 if {$z < -1 || ($z < 0 && $isarrow)} {
3240 # Line currently goes left too much;
3241 # insert pads in the previous row, then optimize it
3242 set npad [expr {-1 - $z + $isarrow}]
3243 insert_pad $y0 $x0 $npad
3245 optimize_rows $y0 $x0 $row
3247 set previdlist [lindex $rowidlist $y0]
3248 set x0 [lsearch -exact $previdlist $id]
3249 set z [expr {$x0 - $col}]
3251 set pprevidlist [lindex $rowidlist $ym]
3252 set xm [lsearch -exact $pprevidlist $id]
3253 set z0 [expr {$xm - $x0}]
3255 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3256 # Line currently goes right too much;
3257 # insert pads in this line
3258 set npad [expr {$z - 1 + $isarrow}]
3259 insert_pad $row $col $npad
3260 set idlist [lindex $rowidlist $row]
3262 set z [expr {$x0 - $col}]
3265 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3266 # this line links to its first child on row $row-2
3267 set id [lindex $displayorder $ym]
3268 set xc [lsearch -exact $pprevidlist $id]
3270 set z0 [expr {$xc - $x0}]
3273 # avoid lines jigging left then immediately right
3274 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3275 insert_pad $y0 $x0 1
3277 optimize_rows $y0 $x0 $row
3278 set previdlist [lindex $rowidlist $y0]
3282 # Find the first column that doesn't have a line going right
3283 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3284 set id [lindex $idlist $col]
3285 if {$id eq {}} break
3286 set x0 [lsearch -exact $previdlist $id]
3288 # check if this is the link to the first child
3289 set kid [lindex $displayorder $y0]
3290 if {[lindex $children($curview,$id) 0] eq $kid} {
3291 # it is, work out offset to child
3292 set x0 [lsearch -exact $previdlist $kid]
3295 if {$x0 <= $col} break
3297 # Insert a pad at that column as long as it has a line and
3298 # isn't the last column
3299 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3300 set idlist [linsert $idlist $col {}]
3301 lset rowidlist $row $idlist
3309 global canvx0 linespc
3310 return [expr {$canvx0 + $col * $linespc}]
3314 global canvy0 linespc
3315 return [expr {$canvy0 + $row * $linespc}]
3318 proc linewidth {id} {
3319 global thickerline lthickness
3322 if {[info exists thickerline] && $id eq $thickerline} {
3323 set wid [expr {2 * $lthickness}]
3328 proc rowranges {id} {
3329 global commitrow curview children uparrowlen downarrowlen
3332 set kids $children($curview,$id)
3338 foreach child $kids {
3339 if {![info exists commitrow($curview,$child)]} break
3340 set row $commitrow($curview,$child)
3341 if {![info exists prev]} {
3342 lappend ret [expr {$row + 1}]
3344 if {$row <= $prevrow} {
3345 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3347 # see if the line extends the whole way from prevrow to row
3348 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3349 [lsearch -exact [lindex $rowidlist \
3350 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3351 # it doesn't, see where it ends
3352 set r [expr {$prevrow + $downarrowlen}]
3353 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3354 while {[incr r -1] > $prevrow &&
3355 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3357 while {[incr r] <= $row &&
3358 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3362 # see where it starts up again
3363 set r [expr {$row - $uparrowlen}]
3364 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3365 while {[incr r] < $row &&
3366 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3368 while {[incr r -1] >= $prevrow &&
3369 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3375 if {$child eq $id} {
3384 proc drawlineseg {id row endrow arrowlow} {
3385 global rowidlist displayorder iddrawn linesegs
3386 global canv colormap linespc curview maxlinelen parentlist
3388 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3389 set le [expr {$row + 1}]
3392 set c [lsearch -exact [lindex $rowidlist $le] $id]
3398 set x [lindex $displayorder $le]
3403 if {[info exists iddrawn($x)] || $le == $endrow} {
3404 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3420 if {[info exists linesegs($id)]} {
3421 set lines $linesegs($id)
3423 set r0 [lindex $li 0]
3425 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3435 set li [lindex $lines [expr {$i-1}]]
3436 set r1 [lindex $li 1]
3437 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3442 set x [lindex $cols [expr {$le - $row}]]
3443 set xp [lindex $cols [expr {$le - 1 - $row}]]
3444 set dir [expr {$xp - $x}]
3446 set ith [lindex $lines $i 2]
3447 set coords [$canv coords $ith]
3448 set ah [$canv itemcget $ith -arrow]
3449 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3450 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3451 if {$x2 ne {} && $x - $x2 == $dir} {
3452 set coords [lrange $coords 0 end-2]
3455 set coords [list [xc $le $x] [yc $le]]
3458 set itl [lindex $lines [expr {$i-1}] 2]
3459 set al [$canv itemcget $itl -arrow]
3460 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3461 } elseif {$arrowlow} {
3462 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3463 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3467 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3468 for {set y $le} {[incr y -1] > $row} {} {
3470 set xp [lindex $cols [expr {$y - 1 - $row}]]
3471 set ndir [expr {$xp - $x}]
3472 if {$dir != $ndir || $xp < 0} {
3473 lappend coords [xc $y $x] [yc $y]
3479 # join parent line to first child
3480 set ch [lindex $displayorder $row]
3481 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3483 puts "oops: drawlineseg: child $ch not on row $row"
3484 } elseif {$xc != $x} {
3485 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3486 set d [expr {int(0.5 * $linespc)}]
3489 set x2 [expr {$x1 - $d}]
3491 set x2 [expr {$x1 + $d}]
3494 set y1 [expr {$y2 + $d}]
3495 lappend coords $x1 $y1 $x2 $y2
3496 } elseif {$xc < $x - 1} {
3497 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3498 } elseif {$xc > $x + 1} {
3499 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3503 lappend coords [xc $row $x] [yc $row]
3505 set xn [xc $row $xp]
3507 lappend coords $xn $yn
3511 set t [$canv create line $coords -width [linewidth $id] \
3512 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3515 set lines [linsert $lines $i [list $row $le $t]]
3517 $canv coords $ith $coords
3518 if {$arrow ne $ah} {
3519 $canv itemconf $ith -arrow $arrow
3521 lset lines $i 0 $row
3524 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3525 set ndir [expr {$xo - $xp}]
3526 set clow [$canv coords $itl]
3527 if {$dir == $ndir} {
3528 set clow [lrange $clow 2 end]
3530 set coords [concat $coords $clow]
3532 lset lines [expr {$i-1}] 1 $le
3534 # coalesce two pieces
3536 set b [lindex $lines [expr {$i-1}] 0]
3537 set e [lindex $lines $i 1]
3538 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3540 $canv coords $itl $coords
3541 if {$arrow ne $al} {
3542 $canv itemconf $itl -arrow $arrow
3546 set linesegs($id) $lines
3550 proc drawparentlinks {id row} {
3551 global rowidlist canv colormap curview parentlist
3552 global idpos linespc
3554 set rowids [lindex $rowidlist $row]
3555 set col [lsearch -exact $rowids $id]
3556 if {$col < 0} return
3557 set olds [lindex $parentlist $row]
3558 set row2 [expr {$row + 1}]
3559 set x [xc $row $col]
3562 set d [expr {int(0.5 * $linespc)}]
3563 set ymid [expr {$y + $d}]
3564 set ids [lindex $rowidlist $row2]
3565 # rmx = right-most X coord used
3568 set i [lsearch -exact $ids $p]
3570 puts "oops, parent $p of $id not in list"
3573 set x2 [xc $row2 $i]
3577 set j [lsearch -exact $rowids $p]
3579 # drawlineseg will do this one for us
3583 # should handle duplicated parents here...
3584 set coords [list $x $y]
3586 # if attaching to a vertical segment, draw a smaller
3587 # slant for visual distinctness
3590 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3592 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3594 } elseif {$i < $col && $i < $j} {
3595 # segment slants towards us already
3596 lappend coords [xc $row $j] $y
3598 if {$i < $col - 1} {
3599 lappend coords [expr {$x2 + $linespc}] $y
3600 } elseif {$i > $col + 1} {
3601 lappend coords [expr {$x2 - $linespc}] $y
3603 lappend coords $x2 $y2
3606 lappend coords $x2 $y2
3608 set t [$canv create line $coords -width [linewidth $p] \
3609 -fill $colormap($p) -tags lines.$p]
3613 if {$rmx > [lindex $idpos($id) 1]} {
3614 lset idpos($id) 1 $rmx
3619 proc drawlines {id} {
3622 $canv itemconf lines.$id -width [linewidth $id]
3625 proc drawcmittext {id row col} {
3626 global linespc canv canv2 canv3 canvy0 fgcolor curview
3627 global commitlisted commitinfo rowidlist parentlist
3628 global rowtextx idpos idtags idheads idotherrefs
3629 global linehtag linentag linedtag selectedline
3630 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3632 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3633 set listed [lindex $commitlisted $row]
3634 if {$id eq $nullid} {
3636 } elseif {$id eq $nullid2} {
3639 set ofill [expr {$listed != 0? "blue": "white"}]
3641 set x [xc $row $col]
3643 set orad [expr {$linespc / 3}]
3645 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3646 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3647 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3648 } elseif {$listed == 2} {
3649 # triangle pointing left for left-side commits
3650 set t [$canv create polygon \
3651 [expr {$x - $orad}] $y \
3652 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3653 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3654 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3656 # triangle pointing right for right-side commits
3657 set t [$canv create polygon \
3658 [expr {$x + $orad - 1}] $y \
3659 [expr {$x - $orad}] [expr {$y - $orad}] \
3660 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3661 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3664 $canv bind $t <1> {selcanvline {} %x %y}
3665 set rmx [llength [lindex $rowidlist $row]]
3666 set olds [lindex $parentlist $row]
3668 set nextids [lindex $rowidlist [expr {$row + 1}]]
3670 set i [lsearch -exact $nextids $p]
3676 set xt [xc $row $rmx]
3677 set rowtextx($row) $xt
3678 set idpos($id) [list $x $xt $y]
3679 if {[info exists idtags($id)] || [info exists idheads($id)]
3680 || [info exists idotherrefs($id)]} {
3681 set xt [drawtags $id $x $xt $y]
3683 set headline [lindex $commitinfo($id) 0]
3684 set name [lindex $commitinfo($id) 1]
3685 set date [lindex $commitinfo($id) 2]
3686 set date [formatdate $date]
3689 set isbold [ishighlighted $row]
3691 lappend boldrows $row
3692 set font mainfontbold
3694 lappend boldnamerows $row
3695 set nfont mainfontbold
3698 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3699 -text $headline -font $font -tags text]
3700 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3701 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3702 -text $name -font $nfont -tags text]
3703 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3704 -text $date -font mainfont -tags text]
3705 if {[info exists selectedline] && $selectedline == $row} {
3708 set xr [expr {$xt + [font measure $font $headline]}]
3709 if {$xr > $canvxmax} {
3715 proc drawcmitrow {row} {
3716 global displayorder rowidlist nrows_drawn
3717 global iddrawn markingmatches
3718 global commitinfo parentlist numcommits
3719 global filehighlight fhighlights findpattern nhighlights
3720 global hlview vhighlights
3721 global highlight_related rhighlights
3723 if {$row >= $numcommits} return
3725 set id [lindex $displayorder $row]
3726 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3727 askvhighlight $row $id
3729 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3730 askfilehighlight $row $id
3732 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3733 askfindhighlight $row $id
3735 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3736 askrelhighlight $row $id
3738 if {![info exists iddrawn($id)]} {
3739 set col [lsearch -exact [lindex $rowidlist $row] $id]
3741 puts "oops, row $row id $id not in list"
3744 if {![info exists commitinfo($id)]} {
3748 drawcmittext $id $row $col
3752 if {$markingmatches} {
3753 markrowmatches $row $id
3757 proc drawcommits {row {endrow {}}} {
3758 global numcommits iddrawn displayorder curview need_redisplay
3759 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3764 if {$endrow eq {}} {
3767 if {$endrow >= $numcommits} {
3768 set endrow [expr {$numcommits - 1}]
3771 set rl1 [expr {$row - $downarrowlen - 3}]
3775 set ro1 [expr {$row - 3}]
3779 set r2 [expr {$endrow + $uparrowlen + 3}]
3780 if {$r2 > $numcommits} {
3783 for {set r $rl1} {$r < $r2} {incr r} {
3784 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3788 set rl1 [expr {$r + 1}]
3794 optimize_rows $ro1 0 $r2
3795 if {$need_redisplay || $nrows_drawn > 2000} {
3800 # make the lines join to already-drawn rows either side
3801 set r [expr {$row - 1}]
3802 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3805 set er [expr {$endrow + 1}]
3806 if {$er >= $numcommits ||
3807 ![info exists iddrawn([lindex $displayorder $er])]} {
3810 for {} {$r <= $er} {incr r} {
3811 set id [lindex $displayorder $r]
3812 set wasdrawn [info exists iddrawn($id)]
3814 if {$r == $er} break
3815 set nextid [lindex $displayorder [expr {$r + 1}]]
3816 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3817 catch {unset prevlines}
3820 drawparentlinks $id $r
3822 if {[info exists lineends($r)]} {
3823 foreach lid $lineends($r) {
3824 unset prevlines($lid)
3827 set rowids [lindex $rowidlist $r]
3828 foreach lid $rowids {
3829 if {$lid eq {}} continue
3831 # see if this is the first child of any of its parents
3832 foreach p [lindex $parentlist $r] {
3833 if {[lsearch -exact $rowids $p] < 0} {
3834 # make this line extend up to the child
3835 set le [drawlineseg $p $r $er 0]
3836 lappend lineends($le) $p
3840 } elseif {![info exists prevlines($lid)]} {
3841 set le [drawlineseg $lid $r $er 1]
3842 lappend lineends($le) $lid
3843 set prevlines($lid) 1
3849 proc drawfrac {f0 f1} {
3852 set ymax [lindex [$canv cget -scrollregion] 3]
3853 if {$ymax eq {} || $ymax == 0} return
3854 set y0 [expr {int($f0 * $ymax)}]
3855 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3856 set y1 [expr {int($f1 * $ymax)}]
3857 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3858 drawcommits $row $endrow
3861 proc drawvisible {} {
3863 eval drawfrac [$canv yview]
3866 proc clear_display {} {
3867 global iddrawn linesegs need_redisplay nrows_drawn
3868 global vhighlights fhighlights nhighlights rhighlights
3871 catch {unset iddrawn}
3872 catch {unset linesegs}
3873 catch {unset vhighlights}
3874 catch {unset fhighlights}
3875 catch {unset nhighlights}
3876 catch {unset rhighlights}
3877 set need_redisplay 0
3881 proc findcrossings {id} {
3882 global rowidlist parentlist numcommits displayorder
3886 foreach {s e} [rowranges $id] {
3887 if {$e >= $numcommits} {
3888 set e [expr {$numcommits - 1}]
3890 if {$e <= $s} continue
3891 for {set row $e} {[incr row -1] >= $s} {} {
3892 set x [lsearch -exact [lindex $rowidlist $row] $id]
3894 set olds [lindex $parentlist $row]
3895 set kid [lindex $displayorder $row]
3896 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3897 if {$kidx < 0} continue
3898 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3900 set px [lsearch -exact $nextrow $p]
3901 if {$px < 0} continue
3902 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3903 if {[lsearch -exact $ccross $p] >= 0} continue
3904 if {$x == $px + ($kidx < $px? -1: 1)} {
3906 } elseif {[lsearch -exact $cross $p] < 0} {
3913 return [concat $ccross {{}} $cross]
3916 proc assigncolor {id} {
3917 global colormap colors nextcolor
3918 global commitrow parentlist children children curview
3920 if {[info exists colormap($id)]} return
3921 set ncolors [llength $colors]
3922 if {[info exists children($curview,$id)]} {
3923 set kids $children($curview,$id)
3927 if {[llength $kids] == 1} {
3928 set child [lindex $kids 0]
3929 if {[info exists colormap($child)]
3930 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3931 set colormap($id) $colormap($child)
3937 foreach x [findcrossings $id] {
3939 # delimiter between corner crossings and other crossings
3940 if {[llength $badcolors] >= $ncolors - 1} break
3941 set origbad $badcolors
3943 if {[info exists colormap($x)]
3944 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3945 lappend badcolors $colormap($x)
3948 if {[llength $badcolors] >= $ncolors} {
3949 set badcolors $origbad
3951 set origbad $badcolors
3952 if {[llength $badcolors] < $ncolors - 1} {
3953 foreach child $kids {
3954 if {[info exists colormap($child)]
3955 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3956 lappend badcolors $colormap($child)
3958 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3959 if {[info exists colormap($p)]
3960 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3961 lappend badcolors $colormap($p)
3965 if {[llength $badcolors] >= $ncolors} {
3966 set badcolors $origbad
3969 for {set i 0} {$i <= $ncolors} {incr i} {
3970 set c [lindex $colors $nextcolor]
3971 if {[incr nextcolor] >= $ncolors} {
3974 if {[lsearch -exact $badcolors $c]} break
3976 set colormap($id) $c
3979 proc bindline {t id} {
3982 $canv bind $t <Enter> "lineenter %x %y $id"
3983 $canv bind $t <Motion> "linemotion %x %y $id"
3984 $canv bind $t <Leave> "lineleave $id"
3985 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3988 proc drawtags {id x xt y1} {
3989 global idtags idheads idotherrefs mainhead
3990 global linespc lthickness
3991 global canv commitrow rowtextx curview fgcolor bgcolor
3996 if {[info exists idtags($id)]} {
3997 set marks $idtags($id)
3998 set ntags [llength $marks]
4000 if {[info exists idheads($id)]} {
4001 set marks [concat $marks $idheads($id)]
4002 set nheads [llength $idheads($id)]
4004 if {[info exists idotherrefs($id)]} {
4005 set marks [concat $marks $idotherrefs($id)]
4011 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4012 set yt [expr {$y1 - 0.5 * $linespc}]
4013 set yb [expr {$yt + $linespc - 1}]
4017 foreach tag $marks {
4019 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4020 set wid [font measure mainfontbold $tag]
4022 set wid [font measure mainfont $tag]
4026 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4028 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4029 -width $lthickness -fill black -tags tag.$id]
4031 foreach tag $marks x $xvals wid $wvals {
4032 set xl [expr {$x + $delta}]
4033 set xr [expr {$x + $delta + $wid + $lthickness}]
4035 if {[incr ntags -1] >= 0} {
4037 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4038 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4039 -width 1 -outline black -fill yellow -tags tag.$id]
4040 $canv bind $t <1> [list showtag $tag 1]
4041 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4043 # draw a head or other ref
4044 if {[incr nheads -1] >= 0} {
4046 if {$tag eq $mainhead} {
4047 set font mainfontbold
4052 set xl [expr {$xl - $delta/2}]
4053 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4054 -width 1 -outline black -fill $col -tags tag.$id
4055 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4056 set rwid [font measure mainfont $remoteprefix]
4057 set xi [expr {$x + 1}]
4058 set yti [expr {$yt + 1}]
4059 set xri [expr {$x + $rwid}]
4060 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4061 -width 0 -fill "#ffddaa" -tags tag.$id
4064 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4065 -font $font -tags [list tag.$id text]]
4067 $canv bind $t <1> [list showtag $tag 1]
4068 } elseif {$nheads >= 0} {
4069 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4075 proc xcoord {i level ln} {
4076 global canvx0 xspc1 xspc2
4078 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4079 if {$i > 0 && $i == $level} {
4080 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4081 } elseif {$i > $level} {
4082 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4087 proc show_status {msg} {
4091 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4092 -tags text -fill $fgcolor
4095 # Insert a new commit as the child of the commit on row $row.
4096 # The new commit will be displayed on row $row and the commits
4097 # on that row and below will move down one row.
4098 proc insertrow {row newcmit} {
4099 global displayorder parentlist commitlisted children
4100 global commitrow curview rowidlist rowisopt rowfinal numcommits
4102 global selectedline commitidx ordertok
4104 if {$row >= $numcommits} {
4105 puts "oops, inserting new row $row but only have $numcommits rows"
4108 set p [lindex $displayorder $row]
4109 set displayorder [linsert $displayorder $row $newcmit]
4110 set parentlist [linsert $parentlist $row $p]
4111 set kids $children($curview,$p)
4112 lappend kids $newcmit
4113 set children($curview,$p) $kids
4114 set children($curview,$newcmit) {}
4115 set commitlisted [linsert $commitlisted $row 1]
4116 set l [llength $displayorder]
4117 for {set r $row} {$r < $l} {incr r} {
4118 set id [lindex $displayorder $r]
4119 set commitrow($curview,$id) $r
4121 incr commitidx($curview)
4122 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4124 if {$row < [llength $rowidlist]} {
4125 set idlist [lindex $rowidlist $row]
4126 if {$idlist ne {}} {
4127 if {[llength $kids] == 1} {
4128 set col [lsearch -exact $idlist $p]
4129 lset idlist $col $newcmit
4131 set col [llength $idlist]
4132 lappend idlist $newcmit
4135 set rowidlist [linsert $rowidlist $row $idlist]
4136 set rowisopt [linsert $rowisopt $row 0]
4137 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4142 if {[info exists selectedline] && $selectedline >= $row} {
4148 # Remove a commit that was inserted with insertrow on row $row.
4149 proc removerow {row} {
4150 global displayorder parentlist commitlisted children
4151 global commitrow curview rowidlist rowisopt rowfinal numcommits
4153 global linesegends selectedline commitidx
4155 if {$row >= $numcommits} {
4156 puts "oops, removing row $row but only have $numcommits rows"
4159 set rp1 [expr {$row + 1}]
4160 set id [lindex $displayorder $row]
4161 set p [lindex $parentlist $row]
4162 set displayorder [lreplace $displayorder $row $row]
4163 set parentlist [lreplace $parentlist $row $row]
4164 set commitlisted [lreplace $commitlisted $row $row]
4165 set kids $children($curview,$p)
4166 set i [lsearch -exact $kids $id]
4168 set kids [lreplace $kids $i $i]
4169 set children($curview,$p) $kids
4171 set l [llength $displayorder]
4172 for {set r $row} {$r < $l} {incr r} {
4173 set id [lindex $displayorder $r]
4174 set commitrow($curview,$id) $r
4176 incr commitidx($curview) -1
4178 if {$row < [llength $rowidlist]} {
4179 set rowidlist [lreplace $rowidlist $row $row]
4180 set rowisopt [lreplace $rowisopt $row $row]
4181 set rowfinal [lreplace $rowfinal $row $row]
4186 if {[info exists selectedline] && $selectedline > $row} {
4187 incr selectedline -1
4192 # Don't change the text pane cursor if it is currently the hand cursor,
4193 # showing that we are over a sha1 ID link.
4194 proc settextcursor {c} {
4195 global ctext curtextcursor
4197 if {[$ctext cget -cursor] == $curtextcursor} {
4198 $ctext config -cursor $c
4200 set curtextcursor $c
4203 proc nowbusy {what {name {}}} {
4204 global isbusy busyname statusw
4206 if {[array names isbusy] eq {}} {
4207 . config -cursor watch
4211 set busyname($what) $name
4213 $statusw conf -text $name
4217 proc notbusy {what} {
4218 global isbusy maincursor textcursor busyname statusw
4222 if {$busyname($what) ne {} &&
4223 [$statusw cget -text] eq $busyname($what)} {
4224 $statusw conf -text {}
4227 if {[array names isbusy] eq {}} {
4228 . config -cursor $maincursor
4229 settextcursor $textcursor
4233 proc findmatches {f} {
4234 global findtype findstring
4235 if {$findtype == "Regexp"} {
4236 set matches [regexp -indices -all -inline $findstring $f]
4239 if {$findtype == "IgnCase"} {
4240 set f [string tolower $f]
4241 set fs [string tolower $fs]
4245 set l [string length $fs]
4246 while {[set j [string first $fs $f $i]] >= 0} {
4247 lappend matches [list $j [expr {$j+$l-1}]]
4248 set i [expr {$j + $l}]
4254 proc dofind {{rev 0}} {
4255 global findstring findstartline findcurline selectedline numcommits
4256 global gdttype filehighlight fh_serial find_dirn
4260 if {$findstring eq {} || $numcommits == 0} return
4261 if {![info exists selectedline]} {
4262 set findstartline [lindex [visiblerows] $rev]
4264 set findstartline $selectedline
4266 set findcurline $findstartline
4267 nowbusy finding "Searching"
4268 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4269 after cancel do_file_hl $fh_serial
4270 do_file_hl $fh_serial
4281 proc stopfinding {} {
4282 global find_dirn findcurline fprogcoord
4284 if {[info exists find_dirn]} {
4293 proc findnext {restart} {
4294 global findcurline find_dirn
4296 if {[info exists find_dirn]} return
4297 if {![info exists findcurline]} {
4306 nowbusy finding "Searching"
4311 global findcurline find_dirn
4313 if {[info exists find_dirn]} return
4314 if {![info exists findcurline]} {
4319 nowbusy finding "Searching"
4324 global commitdata commitinfo numcommits findpattern findloc
4325 global findstartline findcurline displayorder
4326 global find_dirn gdttype fhighlights fprogcoord
4328 if {![info exists find_dirn]} {
4331 set fldtypes {Headline Author Date Committer CDate Comments}
4332 set l [expr {$findcurline + 1}]
4333 if {$l >= $numcommits} {
4336 if {$l <= $findstartline} {
4337 set lim [expr {$findstartline + 1}]
4341 if {$lim - $l > 500} {
4342 set lim [expr {$l + 500}]
4346 if {$gdttype eq "containing:"} {
4347 for {} {$l < $lim} {incr l} {
4348 set id [lindex $displayorder $l]
4349 # shouldn't happen unless git log doesn't give all the commits...
4350 if {![info exists commitdata($id)]} continue
4351 if {![doesmatch $commitdata($id)]} continue
4352 if {![info exists commitinfo($id)]} {
4355 set info $commitinfo($id)
4356 foreach f $info ty $fldtypes {
4357 if {($findloc eq "All fields" || $findloc eq $ty) &&
4366 for {} {$l < $lim} {incr l} {
4367 set id [lindex $displayorder $l]
4368 if {![info exists fhighlights($l)]} {
4369 askfilehighlight $l $id
4372 set findcurline [expr {$l - 1}]
4374 } elseif {$fhighlights($l)} {
4380 if {$found || ($domore && $l == $findstartline + 1)} {
4396 set findcurline [expr {$l - 1}]
4398 set n [expr {$findcurline - ($findstartline + 1)}]
4402 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4407 proc findmorerev {} {
4408 global commitdata commitinfo numcommits findpattern findloc
4409 global findstartline findcurline displayorder
4410 global find_dirn gdttype fhighlights fprogcoord
4412 if {![info exists find_dirn]} {
4415 set fldtypes {Headline Author Date Committer CDate Comments}
4421 if {$l >= $findstartline} {
4422 set lim [expr {$findstartline - 1}]
4426 if {$l - $lim > 500} {
4427 set lim [expr {$l - 500}]
4431 if {$gdttype eq "containing:"} {
4432 for {} {$l > $lim} {incr l -1} {
4433 set id [lindex $displayorder $l]
4434 if {![info exists commitdata($id)]} continue
4435 if {![doesmatch $commitdata($id)]} continue
4436 if {![info exists commitinfo($id)]} {
4439 set info $commitinfo($id)
4440 foreach f $info ty $fldtypes {
4441 if {($findloc eq "All fields" || $findloc eq $ty) &&
4450 for {} {$l > $lim} {incr l -1} {
4451 set id [lindex $displayorder $l]
4452 if {![info exists fhighlights($l)]} {
4453 askfilehighlight $l $id
4456 set findcurline [expr {$l + 1}]
4458 } elseif {$fhighlights($l)} {
4464 if {$found || ($domore && $l == $findstartline - 1)} {
4480 set findcurline [expr {$l + 1}]
4482 set n [expr {($findstartline - 1) - $findcurline}]
4486 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4491 proc findselectline {l} {
4492 global findloc commentend ctext findcurline markingmatches gdttype
4494 set markingmatches 1
4497 if {$findloc == "All fields" || $findloc == "Comments"} {
4498 # highlight the matches in the comments
4499 set f [$ctext get 1.0 $commentend]
4500 set matches [findmatches $f]
4501 foreach match $matches {
4502 set start [lindex $match 0]
4503 set end [expr {[lindex $match 1] + 1}]
4504 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4510 # mark the bits of a headline or author that match a find string
4511 proc markmatches {canv l str tag matches font row} {
4514 set bbox [$canv bbox $tag]
4515 set x0 [lindex $bbox 0]
4516 set y0 [lindex $bbox 1]
4517 set y1 [lindex $bbox 3]
4518 foreach match $matches {
4519 set start [lindex $match 0]
4520 set end [lindex $match 1]
4521 if {$start > $end} continue
4522 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4523 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4524 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4525 [expr {$x0+$xlen+2}] $y1 \
4526 -outline {} -tags [list match$l matches] -fill yellow]
4528 if {[info exists selectedline] && $row == $selectedline} {
4529 $canv raise $t secsel
4534 proc unmarkmatches {} {
4535 global markingmatches
4537 allcanvs delete matches
4538 set markingmatches 0
4542 proc selcanvline {w x y} {
4543 global canv canvy0 ctext linespc
4545 set ymax [lindex [$canv cget -scrollregion] 3]
4546 if {$ymax == {}} return
4547 set yfrac [lindex [$canv yview] 0]
4548 set y [expr {$y + $yfrac * $ymax}]
4549 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4554 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4560 proc commit_descriptor {p} {
4562 if {![info exists commitinfo($p)]} {
4566 if {[llength $commitinfo($p)] > 1} {
4567 set l [lindex $commitinfo($p) 0]
4572 # append some text to the ctext widget, and make any SHA1 ID
4573 # that we know about be a clickable link.
4574 proc appendwithlinks {text tags} {
4575 global ctext commitrow linknum curview pendinglinks
4577 set start [$ctext index "end - 1c"]
4578 $ctext insert end $text $tags
4579 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4583 set linkid [string range $text $s $e]
4585 $ctext tag delete link$linknum
4586 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4587 setlink $linkid link$linknum
4592 proc setlink {id lk} {
4593 global curview commitrow ctext pendinglinks commitinterest
4595 if {[info exists commitrow($curview,$id)]} {
4596 $ctext tag conf $lk -foreground blue -underline 1
4597 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4598 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4599 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4601 lappend pendinglinks($id) $lk
4602 lappend commitinterest($id) {makelink %I}
4606 proc makelink {id} {
4609 if {![info exists pendinglinks($id)]} return
4610 foreach lk $pendinglinks($id) {
4613 unset pendinglinks($id)
4616 proc linkcursor {w inc} {
4617 global linkentercount curtextcursor
4619 if {[incr linkentercount $inc] > 0} {
4620 $w configure -cursor hand2
4622 $w configure -cursor $curtextcursor
4623 if {$linkentercount < 0} {
4624 set linkentercount 0
4629 proc viewnextline {dir} {
4633 set ymax [lindex [$canv cget -scrollregion] 3]
4634 set wnow [$canv yview]
4635 set wtop [expr {[lindex $wnow 0] * $ymax}]
4636 set newtop [expr {$wtop + $dir * $linespc}]
4639 } elseif {$newtop > $ymax} {
4642 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4645 # add a list of tag or branch names at position pos
4646 # returns the number of names inserted
4647 proc appendrefs {pos ids var} {
4648 global ctext commitrow linknum curview $var maxrefs
4650 if {[catch {$ctext index $pos}]} {
4653 $ctext conf -state normal
4654 $ctext delete $pos "$pos lineend"
4657 foreach tag [set $var\($id\)] {
4658 lappend tags [list $tag $id]
4661 if {[llength $tags] > $maxrefs} {
4662 $ctext insert $pos "many ([llength $tags])"
4664 set tags [lsort -index 0 -decreasing $tags]
4667 set id [lindex $ti 1]
4670 $ctext tag delete $lk
4671 $ctext insert $pos $sep
4672 $ctext insert $pos [lindex $ti 0] $lk
4677 $ctext conf -state disabled
4678 return [llength $tags]
4681 # called when we have finished computing the nearby tags
4682 proc dispneartags {delay} {
4683 global selectedline currentid showneartags tagphase
4685 if {![info exists selectedline] || !$showneartags} return
4686 after cancel dispnexttag
4688 after 200 dispnexttag
4691 after idle dispnexttag
4696 proc dispnexttag {} {
4697 global selectedline currentid showneartags tagphase ctext
4699 if {![info exists selectedline] || !$showneartags} return
4700 switch -- $tagphase {
4702 set dtags [desctags $currentid]
4704 appendrefs precedes $dtags idtags
4708 set atags [anctags $currentid]
4710 appendrefs follows $atags idtags
4714 set dheads [descheads $currentid]
4715 if {$dheads ne {}} {
4716 if {[appendrefs branch $dheads idheads] > 1
4717 && [$ctext get "branch -3c"] eq "h"} {
4718 # turn "Branch" into "Branches"
4719 $ctext conf -state normal
4720 $ctext insert "branch -2c" "es"
4721 $ctext conf -state disabled
4726 if {[incr tagphase] <= 2} {
4727 after idle dispnexttag
4731 proc make_secsel {l} {
4732 global linehtag linentag linedtag canv canv2 canv3
4734 if {![info exists linehtag($l)]} return
4736 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4737 -tags secsel -fill [$canv cget -selectbackground]]
4739 $canv2 delete secsel
4740 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4741 -tags secsel -fill [$canv2 cget -selectbackground]]
4743 $canv3 delete secsel
4744 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4745 -tags secsel -fill [$canv3 cget -selectbackground]]
4749 proc selectline {l isnew} {
4750 global canv ctext commitinfo selectedline
4752 global canvy0 linespc parentlist children curview
4753 global currentid sha1entry
4754 global commentend idtags linknum
4755 global mergemax numcommits pending_select
4756 global cmitmode showneartags allcommits
4758 catch {unset pending_select}
4763 if {$l < 0 || $l >= $numcommits} return
4764 set y [expr {$canvy0 + $l * $linespc}]
4765 set ymax [lindex [$canv cget -scrollregion] 3]
4766 set ytop [expr {$y - $linespc - 1}]
4767 set ybot [expr {$y + $linespc + 1}]
4768 set wnow [$canv yview]
4769 set wtop [expr {[lindex $wnow 0] * $ymax}]
4770 set wbot [expr {[lindex $wnow 1] * $ymax}]
4771 set wh [expr {$wbot - $wtop}]
4773 if {$ytop < $wtop} {
4774 if {$ybot < $wtop} {
4775 set newtop [expr {$y - $wh / 2.0}]
4778 if {$newtop > $wtop - $linespc} {
4779 set newtop [expr {$wtop - $linespc}]
4782 } elseif {$ybot > $wbot} {
4783 if {$ytop > $wbot} {
4784 set newtop [expr {$y - $wh / 2.0}]
4786 set newtop [expr {$ybot - $wh}]
4787 if {$newtop < $wtop + $linespc} {
4788 set newtop [expr {$wtop + $linespc}]
4792 if {$newtop != $wtop} {
4796 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4803 addtohistory [list selectline $l 0]
4808 set id [lindex $displayorder $l]
4810 $sha1entry delete 0 end
4811 $sha1entry insert 0 $id
4812 $sha1entry selection from 0
4813 $sha1entry selection to end
4816 $ctext conf -state normal
4819 set info $commitinfo($id)
4820 set date [formatdate [lindex $info 2]]
4821 $ctext insert end "Author: [lindex $info 1] $date\n"
4822 set date [formatdate [lindex $info 4]]
4823 $ctext insert end "Committer: [lindex $info 3] $date\n"
4824 if {[info exists idtags($id)]} {
4825 $ctext insert end "Tags:"
4826 foreach tag $idtags($id) {
4827 $ctext insert end " $tag"
4829 $ctext insert end "\n"
4833 set olds [lindex $parentlist $l]
4834 if {[llength $olds] > 1} {
4837 if {$np >= $mergemax} {
4842 $ctext insert end "Parent: " $tag
4843 appendwithlinks [commit_descriptor $p] {}
4848 append headers "Parent: [commit_descriptor $p]"
4852 foreach c $children($curview,$id) {
4853 append headers "Child: [commit_descriptor $c]"
4856 # make anything that looks like a SHA1 ID be a clickable link
4857 appendwithlinks $headers {}
4858 if {$showneartags} {
4859 if {![info exists allcommits]} {
4862 $ctext insert end "Branch: "
4863 $ctext mark set branch "end -1c"
4864 $ctext mark gravity branch left
4865 $ctext insert end "\nFollows: "
4866 $ctext mark set follows "end -1c"
4867 $ctext mark gravity follows left
4868 $ctext insert end "\nPrecedes: "
4869 $ctext mark set precedes "end -1c"
4870 $ctext mark gravity precedes left
4871 $ctext insert end "\n"
4874 $ctext insert end "\n"
4875 set comment [lindex $info 5]
4876 if {[string first "\r" $comment] >= 0} {
4877 set comment [string map {"\r" "\n "} $comment]
4879 appendwithlinks $comment {comment}
4881 $ctext tag remove found 1.0 end
4882 $ctext conf -state disabled
4883 set commentend [$ctext index "end - 1c"]
4885 init_flist "Comments"
4886 if {$cmitmode eq "tree"} {
4888 } elseif {[llength $olds] <= 1} {
4895 proc selfirstline {} {
4900 proc sellastline {} {
4903 set l [expr {$numcommits - 1}]
4907 proc selnextline {dir} {
4910 if {![info exists selectedline]} return
4911 set l [expr {$selectedline + $dir}]
4916 proc selnextpage {dir} {
4917 global canv linespc selectedline numcommits
4919 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4923 allcanvs yview scroll [expr {$dir * $lpp}] units
4925 if {![info exists selectedline]} return
4926 set l [expr {$selectedline + $dir * $lpp}]
4929 } elseif {$l >= $numcommits} {
4930 set l [expr $numcommits - 1]
4936 proc unselectline {} {
4937 global selectedline currentid
4939 catch {unset selectedline}
4940 catch {unset currentid}
4941 allcanvs delete secsel
4945 proc reselectline {} {
4948 if {[info exists selectedline]} {
4949 selectline $selectedline 0
4953 proc addtohistory {cmd} {
4954 global history historyindex curview
4956 set elt [list $curview $cmd]
4957 if {$historyindex > 0
4958 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4962 if {$historyindex < [llength $history]} {
4963 set history [lreplace $history $historyindex end $elt]
4965 lappend history $elt
4968 if {$historyindex > 1} {
4969 .tf.bar.leftbut conf -state normal
4971 .tf.bar.leftbut conf -state disabled
4973 .tf.bar.rightbut conf -state disabled
4979 set view [lindex $elt 0]
4980 set cmd [lindex $elt 1]
4981 if {$curview != $view} {
4988 global history historyindex
4991 if {$historyindex > 1} {
4992 incr historyindex -1
4993 godo [lindex $history [expr {$historyindex - 1}]]
4994 .tf.bar.rightbut conf -state normal
4996 if {$historyindex <= 1} {
4997 .tf.bar.leftbut conf -state disabled
5002 global history historyindex
5005 if {$historyindex < [llength $history]} {
5006 set cmd [lindex $history $historyindex]
5009 .tf.bar.leftbut conf -state normal
5011 if {$historyindex >= [llength $history]} {
5012 .tf.bar.rightbut conf -state disabled
5017 global treefilelist treeidlist diffids diffmergeid treepending
5018 global nullid nullid2
5021 catch {unset diffmergeid}
5022 if {![info exists treefilelist($id)]} {
5023 if {![info exists treepending]} {
5024 if {$id eq $nullid} {
5025 set cmd [list | git ls-files]
5026 } elseif {$id eq $nullid2} {
5027 set cmd [list | git ls-files --stage -t]
5029 set cmd [list | git ls-tree -r $id]
5031 if {[catch {set gtf [open $cmd r]}]} {
5035 set treefilelist($id) {}
5036 set treeidlist($id) {}
5037 fconfigure $gtf -blocking 0
5038 filerun $gtf [list gettreeline $gtf $id]
5045 proc gettreeline {gtf id} {
5046 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5049 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5050 if {$diffids eq $nullid} {
5053 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5054 set i [string first "\t" $line]
5055 if {$i < 0} continue
5056 set sha1 [lindex $line 2]
5057 set fname [string range $line [expr {$i+1}] end]
5058 if {[string index $fname 0] eq "\""} {
5059 set fname [lindex $fname 0]
5061 lappend treeidlist($id) $sha1
5063 lappend treefilelist($id) $fname
5066 return [expr {$nl >= 1000? 2: 1}]
5070 if {$cmitmode ne "tree"} {
5071 if {![info exists diffmergeid]} {
5072 gettreediffs $diffids
5074 } elseif {$id ne $diffids} {
5083 global treefilelist treeidlist diffids nullid nullid2
5084 global ctext commentend
5086 set i [lsearch -exact $treefilelist($diffids) $f]
5088 puts "oops, $f not in list for id $diffids"
5091 if {$diffids eq $nullid} {
5092 if {[catch {set bf [open $f r]} err]} {
5093 puts "oops, can't read $f: $err"
5097 set blob [lindex $treeidlist($diffids) $i]
5098 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5099 puts "oops, error reading blob $blob: $err"
5103 fconfigure $bf -blocking 0
5104 filerun $bf [list getblobline $bf $diffids]
5105 $ctext config -state normal
5106 clear_ctext $commentend
5107 $ctext insert end "\n"
5108 $ctext insert end "$f\n" filesep
5109 $ctext config -state disabled
5110 $ctext yview $commentend
5114 proc getblobline {bf id} {
5115 global diffids cmitmode ctext
5117 if {$id ne $diffids || $cmitmode ne "tree"} {
5121 $ctext config -state normal
5123 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5124 $ctext insert end "$line\n"
5127 # delete last newline
5128 $ctext delete "end - 2c" "end - 1c"
5132 $ctext config -state disabled
5133 return [expr {$nl >= 1000? 2: 1}]
5136 proc mergediff {id l} {
5137 global diffmergeid mdifffd
5143 # this doesn't seem to actually affect anything...
5144 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5145 if {[catch {set mdf [open $cmd r]} err]} {
5146 error_popup "Error getting merge diffs: $err"
5149 fconfigure $mdf -blocking 0
5150 set mdifffd($id) $mdf
5151 set np [llength [lindex $parentlist $l]]
5153 filerun $mdf [list getmergediffline $mdf $id $np]
5156 proc getmergediffline {mdf id np} {
5157 global diffmergeid ctext cflist mergemax
5158 global difffilestart mdifffd
5160 $ctext conf -state normal
5162 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5163 if {![info exists diffmergeid] || $id != $diffmergeid
5164 || $mdf != $mdifffd($id)} {
5168 if {[regexp {^diff --cc (.*)} $line match fname]} {
5169 # start of a new file
5170 $ctext insert end "\n"
5171 set here [$ctext index "end - 1c"]
5172 lappend difffilestart $here
5173 add_flist [list $fname]
5174 set l [expr {(78 - [string length $fname]) / 2}]
5175 set pad [string range "----------------------------------------" 1 $l]
5176 $ctext insert end "$pad $fname $pad\n" filesep
5177 } elseif {[regexp {^@@} $line]} {
5178 $ctext insert end "$line\n" hunksep
5179 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5182 # parse the prefix - one ' ', '-' or '+' for each parent
5187 for {set j 0} {$j < $np} {incr j} {
5188 set c [string range $line $j $j]
5191 } elseif {$c == "-"} {
5193 } elseif {$c == "+"} {
5202 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5203 # line doesn't appear in result, parents in $minuses have the line
5204 set num [lindex $minuses 0]
5205 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5206 # line appears in result, parents in $pluses don't have the line
5207 lappend tags mresult
5208 set num [lindex $spaces 0]
5211 if {$num >= $mergemax} {
5216 $ctext insert end "$line\n" $tags
5219 $ctext conf -state disabled
5224 return [expr {$nr >= 1000? 2: 1}]
5227 proc startdiff {ids} {
5228 global treediffs diffids treepending diffmergeid nullid nullid2
5232 catch {unset diffmergeid}
5233 if {![info exists treediffs($ids)] ||
5234 [lsearch -exact $ids $nullid] >= 0 ||
5235 [lsearch -exact $ids $nullid2] >= 0} {
5236 if {![info exists treepending]} {
5244 proc addtocflist {ids} {
5245 global treediffs cflist
5246 add_flist $treediffs($ids)
5250 proc diffcmd {ids flags} {
5251 global nullid nullid2
5253 set i [lsearch -exact $ids $nullid]
5254 set j [lsearch -exact $ids $nullid2]
5256 if {[llength $ids] > 1 && $j < 0} {
5257 # comparing working directory with some specific revision
5258 set cmd [concat | git diff-index $flags]
5260 lappend cmd -R [lindex $ids 1]
5262 lappend cmd [lindex $ids 0]
5265 # comparing working directory with index
5266 set cmd [concat | git diff-files $flags]
5271 } elseif {$j >= 0} {
5272 set cmd [concat | git diff-index --cached $flags]
5273 if {[llength $ids] > 1} {
5274 # comparing index with specific revision
5276 lappend cmd -R [lindex $ids 1]
5278 lappend cmd [lindex $ids 0]
5281 # comparing index with HEAD
5285 set cmd [concat | git diff-tree -r $flags $ids]
5290 proc gettreediffs {ids} {
5291 global treediff treepending
5293 set treepending $ids
5295 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5296 fconfigure $gdtf -blocking 0
5297 filerun $gdtf [list gettreediffline $gdtf $ids]
5300 proc gettreediffline {gdtf ids} {
5301 global treediff treediffs treepending diffids diffmergeid
5305 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5306 set i [string first "\t" $line]
5308 set file [string range $line [expr {$i+1}] end]
5309 if {[string index $file 0] eq "\""} {
5310 set file [lindex $file 0]
5312 lappend treediff $file
5316 return [expr {$nr >= 1000? 2: 1}]
5319 set treediffs($ids) $treediff
5321 if {$cmitmode eq "tree"} {
5323 } elseif {$ids != $diffids} {
5324 if {![info exists diffmergeid]} {
5325 gettreediffs $diffids
5333 # empty string or positive integer
5334 proc diffcontextvalidate {v} {
5335 return [regexp {^(|[1-9][0-9]*)$} $v]
5338 proc diffcontextchange {n1 n2 op} {
5339 global diffcontextstring diffcontext
5341 if {[string is integer -strict $diffcontextstring]} {
5342 if {$diffcontextstring > 0} {
5343 set diffcontext $diffcontextstring
5349 proc getblobdiffs {ids} {
5350 global blobdifffd diffids env
5351 global diffinhdr treediffs
5354 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5355 puts "error getting diffs: $err"
5359 fconfigure $bdf -blocking 0
5360 set blobdifffd($ids) $bdf
5361 filerun $bdf [list getblobdiffline $bdf $diffids]
5364 proc setinlist {var i val} {
5367 while {[llength [set $var]] < $i} {
5370 if {[llength [set $var]] == $i} {
5377 proc makediffhdr {fname ids} {
5378 global ctext curdiffstart treediffs
5380 set i [lsearch -exact $treediffs($ids) $fname]
5382 setinlist difffilestart $i $curdiffstart
5384 set l [expr {(78 - [string length $fname]) / 2}]
5385 set pad [string range "----------------------------------------" 1 $l]
5386 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5389 proc getblobdiffline {bdf ids} {
5390 global diffids blobdifffd ctext curdiffstart
5391 global diffnexthead diffnextnote difffilestart
5392 global diffinhdr treediffs
5395 $ctext conf -state normal
5396 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5397 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5401 if {![string compare -length 11 "diff --git " $line]} {
5402 # trim off "diff --git "
5403 set line [string range $line 11 end]
5405 # start of a new file
5406 $ctext insert end "\n"
5407 set curdiffstart [$ctext index "end - 1c"]
5408 $ctext insert end "\n" filesep
5409 # If the name hasn't changed the length will be odd,
5410 # the middle char will be a space, and the two bits either
5411 # side will be a/name and b/name, or "a/name" and "b/name".
5412 # If the name has changed we'll get "rename from" and
5413 # "rename to" or "copy from" and "copy to" lines following this,
5414 # and we'll use them to get the filenames.
5415 # This complexity is necessary because spaces in the filename(s)
5416 # don't get escaped.
5417 set l [string length $line]
5418 set i [expr {$l / 2}]
5419 if {!(($l & 1) && [string index $line $i] eq " " &&
5420 [string range $line 2 [expr {$i - 1}]] eq \
5421 [string range $line [expr {$i + 3}] end])} {
5424 # unescape if quoted and chop off the a/ from the front
5425 if {[string index $line 0] eq "\""} {
5426 set fname [string range [lindex $line 0] 2 end]
5428 set fname [string range $line 2 [expr {$i - 1}]]
5430 makediffhdr $fname $ids
5432 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5433 $line match f1l f1c f2l f2c rest]} {
5434 $ctext insert end "$line\n" hunksep
5437 } elseif {$diffinhdr} {
5438 if {![string compare -length 12 "rename from " $line] ||
5439 ![string compare -length 10 "copy from " $line]} {
5440 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5441 if {[string index $fname 0] eq "\""} {
5442 set fname [lindex $fname 0]
5444 set i [lsearch -exact $treediffs($ids) $fname]
5446 setinlist difffilestart $i $curdiffstart
5448 } elseif {![string compare -length 10 $line "rename to "] ||
5449 ![string compare -length 8 $line "copy to "]} {
5450 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5451 if {[string index $fname 0] eq "\""} {
5452 set fname [lindex $fname 0]
5454 makediffhdr $fname $ids
5455 } elseif {[string compare -length 3 $line "---"] == 0} {
5458 } elseif {[string compare -length 3 $line "+++"] == 0} {
5462 $ctext insert end "$line\n" filesep
5465 set x [string range $line 0 0]
5466 if {$x == "-" || $x == "+"} {
5467 set tag [expr {$x == "+"}]
5468 $ctext insert end "$line\n" d$tag
5469 } elseif {$x == " "} {
5470 $ctext insert end "$line\n"
5472 # "\ No newline at end of file",
5473 # or something else we don't recognize
5474 $ctext insert end "$line\n" hunksep
5478 $ctext conf -state disabled
5483 return [expr {$nr >= 1000? 2: 1}]
5486 proc changediffdisp {} {
5487 global ctext diffelide
5489 $ctext tag conf d0 -elide [lindex $diffelide 0]
5490 $ctext tag conf d1 -elide [lindex $diffelide 1]
5494 global difffilestart ctext
5495 set prev [lindex $difffilestart 0]
5496 set here [$ctext index @0,0]
5497 foreach loc $difffilestart {
5498 if {[$ctext compare $loc >= $here]} {
5508 global difffilestart ctext
5509 set here [$ctext index @0,0]
5510 foreach loc $difffilestart {
5511 if {[$ctext compare $loc > $here]} {
5518 proc clear_ctext {{first 1.0}} {
5519 global ctext smarktop smarkbot
5522 set l [lindex [split $first .] 0]
5523 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5526 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5529 $ctext delete $first end
5530 if {$first eq "1.0"} {
5531 catch {unset pendinglinks}
5535 proc settabs {{firstab {}}} {
5536 global firsttabstop tabstop ctext have_tk85
5538 if {$firstab ne {} && $have_tk85} {
5539 set firsttabstop $firstab
5541 set w [font measure textfont "0"]
5542 if {$firsttabstop != 0} {
5543 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5544 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5545 } elseif {$have_tk85 || $tabstop != 8} {
5546 $ctext conf -tabs [expr {$tabstop * $w}]
5548 $ctext conf -tabs {}
5552 proc incrsearch {name ix op} {
5553 global ctext searchstring searchdirn
5555 $ctext tag remove found 1.0 end
5556 if {[catch {$ctext index anchor}]} {
5557 # no anchor set, use start of selection, or of visible area
5558 set sel [$ctext tag ranges sel]
5560 $ctext mark set anchor [lindex $sel 0]
5561 } elseif {$searchdirn eq "-forwards"} {
5562 $ctext mark set anchor @0,0
5564 $ctext mark set anchor @0,[winfo height $ctext]
5567 if {$searchstring ne {}} {
5568 set here [$ctext search $searchdirn -- $searchstring anchor]
5577 global sstring ctext searchstring searchdirn
5580 $sstring icursor end
5581 set searchdirn -forwards
5582 if {$searchstring ne {}} {
5583 set sel [$ctext tag ranges sel]
5585 set start "[lindex $sel 0] + 1c"
5586 } elseif {[catch {set start [$ctext index anchor]}]} {
5589 set match [$ctext search -count mlen -- $searchstring $start]
5590 $ctext tag remove sel 1.0 end
5596 set mend "$match + $mlen c"
5597 $ctext tag add sel $match $mend
5598 $ctext mark unset anchor
5602 proc dosearchback {} {
5603 global sstring ctext searchstring searchdirn
5606 $sstring icursor end
5607 set searchdirn -backwards
5608 if {$searchstring ne {}} {
5609 set sel [$ctext tag ranges sel]
5611 set start [lindex $sel 0]
5612 } elseif {[catch {set start [$ctext index anchor]}]} {
5613 set start @0,[winfo height $ctext]
5615 set match [$ctext search -backwards -count ml -- $searchstring $start]
5616 $ctext tag remove sel 1.0 end
5622 set mend "$match + $ml c"
5623 $ctext tag add sel $match $mend
5624 $ctext mark unset anchor
5628 proc searchmark {first last} {
5629 global ctext searchstring
5633 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5634 if {$match eq {}} break
5635 set mend "$match + $mlen c"
5636 $ctext tag add found $match $mend
5640 proc searchmarkvisible {doall} {
5641 global ctext smarktop smarkbot
5643 set topline [lindex [split [$ctext index @0,0] .] 0]
5644 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5645 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5646 # no overlap with previous
5647 searchmark $topline $botline
5648 set smarktop $topline
5649 set smarkbot $botline
5651 if {$topline < $smarktop} {
5652 searchmark $topline [expr {$smarktop-1}]
5653 set smarktop $topline
5655 if {$botline > $smarkbot} {
5656 searchmark [expr {$smarkbot+1}] $botline
5657 set smarkbot $botline
5662 proc scrolltext {f0 f1} {
5665 .bleft.sb set $f0 $f1
5666 if {$searchstring ne {}} {
5672 global linespc charspc canvx0 canvy0
5673 global xspc1 xspc2 lthickness
5675 set linespc [font metrics mainfont -linespace]
5676 set charspc [font measure mainfont "m"]
5677 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5678 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5679 set lthickness [expr {int($linespc / 9) + 1}]
5680 set xspc1(0) $linespc
5688 set ymax [lindex [$canv cget -scrollregion] 3]
5689 if {$ymax eq {} || $ymax == 0} return
5690 set span [$canv yview]
5693 allcanvs yview moveto [lindex $span 0]
5695 if {[info exists selectedline]} {
5696 selectline $selectedline 0
5697 allcanvs yview moveto [lindex $span 0]
5701 proc parsefont {f n} {
5704 set fontattr($f,family) [lindex $n 0]
5706 if {$s eq {} || $s == 0} {
5709 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5711 set fontattr($f,size) $s
5712 set fontattr($f,weight) normal
5713 set fontattr($f,slant) roman
5714 foreach style [lrange $n 2 end] {
5717 "bold" {set fontattr($f,weight) $style}
5719 "italic" {set fontattr($f,slant) $style}
5724 proc fontflags {f {isbold 0}} {
5727 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5728 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5729 -slant $fontattr($f,slant)]
5735 set n [list $fontattr($f,family) $fontattr($f,size)]
5736 if {$fontattr($f,weight) eq "bold"} {
5739 if {$fontattr($f,slant) eq "italic"} {
5745 proc incrfont {inc} {
5746 global mainfont textfont ctext canv phase cflist showrefstop
5747 global stopped entries fontattr
5750 set s $fontattr(mainfont,size)
5755 set fontattr(mainfont,size) $s
5756 font config mainfont -size $s
5757 font config mainfontbold -size $s
5758 set mainfont [fontname mainfont]
5759 set s $fontattr(textfont,size)
5764 set fontattr(textfont,size) $s
5765 font config textfont -size $s
5766 font config textfontbold -size $s
5767 set textfont [fontname textfont]
5774 global sha1entry sha1string
5775 if {[string length $sha1string] == 40} {
5776 $sha1entry delete 0 end
5780 proc sha1change {n1 n2 op} {
5781 global sha1string currentid sha1but
5782 if {$sha1string == {}
5783 || ([info exists currentid] && $sha1string == $currentid)} {
5788 if {[$sha1but cget -state] == $state} return
5789 if {$state == "normal"} {
5790 $sha1but conf -state normal -relief raised -text "Goto: "
5792 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5796 proc gotocommit {} {
5797 global sha1string currentid commitrow tagids headids
5798 global displayorder numcommits curview
5800 if {$sha1string == {}
5801 || ([info exists currentid] && $sha1string == $currentid)} return
5802 if {[info exists tagids($sha1string)]} {
5803 set id $tagids($sha1string)
5804 } elseif {[info exists headids($sha1string)]} {
5805 set id $headids($sha1string)
5807 set id [string tolower $sha1string]
5808 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5810 foreach i $displayorder {
5811 if {[string match $id* $i]} {
5815 if {$matches ne {}} {
5816 if {[llength $matches] > 1} {
5817 error_popup "Short SHA1 id $id is ambiguous"
5820 set id [lindex $matches 0]
5824 if {[info exists commitrow($curview,$id)]} {
5825 selectline $commitrow($curview,$id) 1
5828 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5833 error_popup "$type $sha1string is not known"
5836 proc lineenter {x y id} {
5837 global hoverx hovery hoverid hovertimer
5838 global commitinfo canv
5840 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5844 if {[info exists hovertimer]} {
5845 after cancel $hovertimer
5847 set hovertimer [after 500 linehover]
5851 proc linemotion {x y id} {
5852 global hoverx hovery hoverid hovertimer
5854 if {[info exists hoverid] && $id == $hoverid} {
5857 if {[info exists hovertimer]} {
5858 after cancel $hovertimer
5860 set hovertimer [after 500 linehover]
5864 proc lineleave {id} {
5865 global hoverid hovertimer canv
5867 if {[info exists hoverid] && $id == $hoverid} {
5869 if {[info exists hovertimer]} {
5870 after cancel $hovertimer
5878 global hoverx hovery hoverid hovertimer
5879 global canv linespc lthickness
5882 set text [lindex $commitinfo($hoverid) 0]
5883 set ymax [lindex [$canv cget -scrollregion] 3]
5884 if {$ymax == {}} return
5885 set yfrac [lindex [$canv yview] 0]
5886 set x [expr {$hoverx + 2 * $linespc}]
5887 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5888 set x0 [expr {$x - 2 * $lthickness}]
5889 set y0 [expr {$y - 2 * $lthickness}]
5890 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5891 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5892 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5893 -fill \#ffff80 -outline black -width 1 -tags hover]
5895 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5900 proc clickisonarrow {id y} {
5903 set ranges [rowranges $id]
5904 set thresh [expr {2 * $lthickness + 6}]
5905 set n [expr {[llength $ranges] - 1}]
5906 for {set i 1} {$i < $n} {incr i} {
5907 set row [lindex $ranges $i]
5908 if {abs([yc $row] - $y) < $thresh} {
5915 proc arrowjump {id n y} {
5918 # 1 <-> 2, 3 <-> 4, etc...
5919 set n [expr {(($n - 1) ^ 1) + 1}]
5920 set row [lindex [rowranges $id] $n]
5922 set ymax [lindex [$canv cget -scrollregion] 3]
5923 if {$ymax eq {} || $ymax <= 0} return
5924 set view [$canv yview]
5925 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5926 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5930 allcanvs yview moveto $yfrac
5933 proc lineclick {x y id isnew} {
5934 global ctext commitinfo children canv thickerline curview commitrow
5936 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5941 # draw this line thicker than normal
5945 set ymax [lindex [$canv cget -scrollregion] 3]
5946 if {$ymax eq {}} return
5947 set yfrac [lindex [$canv yview] 0]
5948 set y [expr {$y + $yfrac * $ymax}]
5950 set dirn [clickisonarrow $id $y]
5952 arrowjump $id $dirn $y
5957 addtohistory [list lineclick $x $y $id 0]
5959 # fill the details pane with info about this line
5960 $ctext conf -state normal
5963 $ctext insert end "Parent:\t"
5964 $ctext insert end $id link0
5966 set info $commitinfo($id)
5967 $ctext insert end "\n\t[lindex $info 0]\n"
5968 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5969 set date [formatdate [lindex $info 2]]
5970 $ctext insert end "\tDate:\t$date\n"
5971 set kids $children($curview,$id)
5973 $ctext insert end "\nChildren:"
5975 foreach child $kids {
5977 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5978 set info $commitinfo($child)
5979 $ctext insert end "\n\t"
5980 $ctext insert end $child link$i
5981 setlink $child link$i
5982 $ctext insert end "\n\t[lindex $info 0]"
5983 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5984 set date [formatdate [lindex $info 2]]
5985 $ctext insert end "\n\tDate:\t$date\n"
5988 $ctext conf -state disabled
5992 proc normalline {} {
5994 if {[info exists thickerline]} {
6002 global commitrow curview
6003 if {[info exists commitrow($curview,$id)]} {
6004 selectline $commitrow($curview,$id) 1
6010 if {![info exists startmstime]} {
6011 set startmstime [clock clicks -milliseconds]
6013 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
6016 proc rowmenu {x y id} {
6017 global rowctxmenu commitrow selectedline rowmenuid curview
6018 global nullid nullid2 fakerowmenu mainhead
6022 if {![info exists selectedline]
6023 || $commitrow($curview,$id) eq $selectedline} {
6028 if {$id ne $nullid && $id ne $nullid2} {
6029 set menu $rowctxmenu
6030 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6032 set menu $fakerowmenu
6034 $menu entryconfigure "Diff this*" -state $state
6035 $menu entryconfigure "Diff selected*" -state $state
6036 $menu entryconfigure "Make patch" -state $state
6037 tk_popup $menu $x $y
6040 proc diffvssel {dirn} {
6041 global rowmenuid selectedline displayorder
6043 if {![info exists selectedline]} return
6045 set oldid [lindex $displayorder $selectedline]
6046 set newid $rowmenuid
6048 set oldid $rowmenuid
6049 set newid [lindex $displayorder $selectedline]
6051 addtohistory [list doseldiff $oldid $newid]
6052 doseldiff $oldid $newid
6055 proc doseldiff {oldid newid} {
6059 $ctext conf -state normal
6062 $ctext insert end "From "
6063 $ctext insert end $oldid link0
6064 setlink $oldid link0
6065 $ctext insert end "\n "
6066 $ctext insert end [lindex $commitinfo($oldid) 0]
6067 $ctext insert end "\n\nTo "
6068 $ctext insert end $newid link1
6069 setlink $newid link1
6070 $ctext insert end "\n "
6071 $ctext insert end [lindex $commitinfo($newid) 0]
6072 $ctext insert end "\n"
6073 $ctext conf -state disabled
6074 $ctext tag remove found 1.0 end
6075 startdiff [list $oldid $newid]
6079 global rowmenuid currentid commitinfo patchtop patchnum
6081 if {![info exists currentid]} return
6082 set oldid $currentid
6083 set oldhead [lindex $commitinfo($oldid) 0]
6084 set newid $rowmenuid
6085 set newhead [lindex $commitinfo($newid) 0]
6088 catch {destroy $top}
6090 label $top.title -text "Generate patch"
6091 grid $top.title - -pady 10
6092 label $top.from -text "From:"
6093 entry $top.fromsha1 -width 40 -relief flat
6094 $top.fromsha1 insert 0 $oldid
6095 $top.fromsha1 conf -state readonly
6096 grid $top.from $top.fromsha1 -sticky w
6097 entry $top.fromhead -width 60 -relief flat
6098 $top.fromhead insert 0 $oldhead
6099 $top.fromhead conf -state readonly
6100 grid x $top.fromhead -sticky w
6101 label $top.to -text "To:"
6102 entry $top.tosha1 -width 40 -relief flat
6103 $top.tosha1 insert 0 $newid
6104 $top.tosha1 conf -state readonly
6105 grid $top.to $top.tosha1 -sticky w
6106 entry $top.tohead -width 60 -relief flat
6107 $top.tohead insert 0 $newhead
6108 $top.tohead conf -state readonly
6109 grid x $top.tohead -sticky w
6110 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6111 grid $top.rev x -pady 10
6112 label $top.flab -text "Output file:"
6113 entry $top.fname -width 60
6114 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6116 grid $top.flab $top.fname -sticky w
6118 button $top.buts.gen -text "Generate" -command mkpatchgo
6119 button $top.buts.can -text "Cancel" -command mkpatchcan
6120 grid $top.buts.gen $top.buts.can
6121 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6122 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6123 grid $top.buts - -pady 10 -sticky ew
6127 proc mkpatchrev {} {
6130 set oldid [$patchtop.fromsha1 get]
6131 set oldhead [$patchtop.fromhead get]
6132 set newid [$patchtop.tosha1 get]
6133 set newhead [$patchtop.tohead get]
6134 foreach e [list fromsha1 fromhead tosha1 tohead] \
6135 v [list $newid $newhead $oldid $oldhead] {
6136 $patchtop.$e conf -state normal
6137 $patchtop.$e delete 0 end
6138 $patchtop.$e insert 0 $v
6139 $patchtop.$e conf -state readonly
6144 global patchtop nullid nullid2
6146 set oldid [$patchtop.fromsha1 get]
6147 set newid [$patchtop.tosha1 get]
6148 set fname [$patchtop.fname get]
6149 set cmd [diffcmd [list $oldid $newid] -p]
6150 # trim off the initial "|"
6151 set cmd [lrange $cmd 1 end]
6152 lappend cmd >$fname &
6153 if {[catch {eval exec $cmd} err]} {
6154 error_popup "Error creating patch: $err"
6156 catch {destroy $patchtop}
6160 proc mkpatchcan {} {
6163 catch {destroy $patchtop}
6168 global rowmenuid mktagtop commitinfo
6172 catch {destroy $top}
6174 label $top.title -text "Create tag"
6175 grid $top.title - -pady 10
6176 label $top.id -text "ID:"
6177 entry $top.sha1 -width 40 -relief flat
6178 $top.sha1 insert 0 $rowmenuid
6179 $top.sha1 conf -state readonly
6180 grid $top.id $top.sha1 -sticky w
6181 entry $top.head -width 60 -relief flat
6182 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6183 $top.head conf -state readonly
6184 grid x $top.head -sticky w
6185 label $top.tlab -text "Tag name:"
6186 entry $top.tag -width 60
6187 grid $top.tlab $top.tag -sticky w
6189 button $top.buts.gen -text "Create" -command mktaggo
6190 button $top.buts.can -text "Cancel" -command mktagcan
6191 grid $top.buts.gen $top.buts.can
6192 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6193 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6194 grid $top.buts - -pady 10 -sticky ew
6199 global mktagtop env tagids idtags
6201 set id [$mktagtop.sha1 get]
6202 set tag [$mktagtop.tag get]
6204 error_popup "No tag name specified"
6207 if {[info exists tagids($tag)]} {
6208 error_popup "Tag \"$tag\" already exists"
6213 set fname [file join $dir "refs/tags" $tag]
6214 set f [open $fname w]
6218 error_popup "Error creating tag: $err"
6222 set tagids($tag) $id
6223 lappend idtags($id) $tag
6230 proc redrawtags {id} {
6231 global canv linehtag commitrow idpos selectedline curview
6232 global canvxmax iddrawn
6234 if {![info exists commitrow($curview,$id)]} return
6235 if {![info exists iddrawn($id)]} return
6236 drawcommits $commitrow($curview,$id)
6237 $canv delete tag.$id
6238 set xt [eval drawtags $id $idpos($id)]
6239 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6240 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6241 set xr [expr {$xt + [font measure mainfont $text]}]
6242 if {$xr > $canvxmax} {
6246 if {[info exists selectedline]
6247 && $selectedline == $commitrow($curview,$id)} {
6248 selectline $selectedline 0
6255 catch {destroy $mktagtop}
6264 proc writecommit {} {
6265 global rowmenuid wrcomtop commitinfo wrcomcmd
6267 set top .writecommit
6269 catch {destroy $top}
6271 label $top.title -text "Write commit to file"
6272 grid $top.title - -pady 10
6273 label $top.id -text "ID:"
6274 entry $top.sha1 -width 40 -relief flat
6275 $top.sha1 insert 0 $rowmenuid
6276 $top.sha1 conf -state readonly
6277 grid $top.id $top.sha1 -sticky w
6278 entry $top.head -width 60 -relief flat
6279 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6280 $top.head conf -state readonly
6281 grid x $top.head -sticky w
6282 label $top.clab -text "Command:"
6283 entry $top.cmd -width 60 -textvariable wrcomcmd
6284 grid $top.clab $top.cmd -sticky w -pady 10
6285 label $top.flab -text "Output file:"
6286 entry $top.fname -width 60
6287 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6288 grid $top.flab $top.fname -sticky w
6290 button $top.buts.gen -text "Write" -command wrcomgo
6291 button $top.buts.can -text "Cancel" -command wrcomcan
6292 grid $top.buts.gen $top.buts.can
6293 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6294 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6295 grid $top.buts - -pady 10 -sticky ew
6302 set id [$wrcomtop.sha1 get]
6303 set cmd "echo $id | [$wrcomtop.cmd get]"
6304 set fname [$wrcomtop.fname get]
6305 if {[catch {exec sh -c $cmd >$fname &} err]} {
6306 error_popup "Error writing commit: $err"
6308 catch {destroy $wrcomtop}
6315 catch {destroy $wrcomtop}
6320 global rowmenuid mkbrtop
6323 catch {destroy $top}
6325 label $top.title -text "Create new branch"
6326 grid $top.title - -pady 10
6327 label $top.id -text "ID:"
6328 entry $top.sha1 -width 40 -relief flat
6329 $top.sha1 insert 0 $rowmenuid
6330 $top.sha1 conf -state readonly
6331 grid $top.id $top.sha1 -sticky w
6332 label $top.nlab -text "Name:"
6333 entry $top.name -width 40
6334 grid $top.nlab $top.name -sticky w
6336 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6337 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6338 grid $top.buts.go $top.buts.can
6339 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6340 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6341 grid $top.buts - -pady 10 -sticky ew
6346 global headids idheads
6348 set name [$top.name get]
6349 set id [$top.sha1 get]
6351 error_popup "Please specify a name for the new branch"
6354 catch {destroy $top}
6358 exec git branch $name $id
6363 set headids($name) $id
6364 lappend idheads($id) $name
6373 proc cherrypick {} {
6374 global rowmenuid curview commitrow
6377 set oldhead [exec git rev-parse HEAD]
6378 set dheads [descheads $rowmenuid]
6379 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6380 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6381 included in branch $mainhead -- really re-apply it?"]
6384 nowbusy cherrypick "Cherry-picking"
6386 # Unfortunately git-cherry-pick writes stuff to stderr even when
6387 # no error occurs, and exec takes that as an indication of error...
6388 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6393 set newhead [exec git rev-parse HEAD]
6394 if {$newhead eq $oldhead} {
6396 error_popup "No changes committed"
6399 addnewchild $newhead $oldhead
6400 if {[info exists commitrow($curview,$oldhead)]} {
6401 insertrow $commitrow($curview,$oldhead) $newhead
6402 if {$mainhead ne {}} {
6403 movehead $newhead $mainhead
6404 movedhead $newhead $mainhead
6413 global mainheadid mainhead rowmenuid confirm_ok resettype
6416 set w ".confirmreset"
6419 wm title $w "Confirm reset"
6420 message $w.m -text \
6421 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6422 -justify center -aspect 1000
6423 pack $w.m -side top -fill x -padx 20 -pady 20
6424 frame $w.f -relief sunken -border 2
6425 message $w.f.rt -text "Reset type:" -aspect 1000
6426 grid $w.f.rt -sticky w
6428 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6429 -text "Soft: Leave working tree and index untouched"
6430 grid $w.f.soft -sticky w
6431 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6432 -text "Mixed: Leave working tree untouched, reset index"
6433 grid $w.f.mixed -sticky w
6434 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6435 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6436 grid $w.f.hard -sticky w
6437 pack $w.f -side top -fill x
6438 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6439 pack $w.ok -side left -fill x -padx 20 -pady 20
6440 button $w.cancel -text Cancel -command "destroy $w"
6441 pack $w.cancel -side right -fill x -padx 20 -pady 20
6442 bind $w <Visibility> "grab $w; focus $w"
6444 if {!$confirm_ok} return
6445 if {[catch {set fd [open \
6446 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6450 filerun $fd [list readresetstat $fd]
6451 nowbusy reset "Resetting"
6455 proc readresetstat {fd} {
6456 global mainhead mainheadid showlocalchanges rprogcoord
6458 if {[gets $fd line] >= 0} {
6459 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6460 set rprogcoord [expr {1.0 * $m / $n}]
6468 if {[catch {close $fd} err]} {
6471 set oldhead $mainheadid
6472 set newhead [exec git rev-parse HEAD]
6473 if {$newhead ne $oldhead} {
6474 movehead $newhead $mainhead
6475 movedhead $newhead $mainhead
6476 set mainheadid $newhead
6480 if {$showlocalchanges} {
6486 # context menu for a head
6487 proc headmenu {x y id head} {
6488 global headmenuid headmenuhead headctxmenu mainhead
6492 set headmenuhead $head
6494 if {$head eq $mainhead} {
6497 $headctxmenu entryconfigure 0 -state $state
6498 $headctxmenu entryconfigure 1 -state $state
6499 tk_popup $headctxmenu $x $y
6503 global headmenuid headmenuhead mainhead headids
6504 global showlocalchanges mainheadid
6506 # check the tree is clean first??
6507 set oldmainhead $mainhead
6508 nowbusy checkout "Checking out"
6512 exec git checkout -q $headmenuhead
6518 set mainhead $headmenuhead
6519 set mainheadid $headmenuid
6520 if {[info exists headids($oldmainhead)]} {
6521 redrawtags $headids($oldmainhead)
6523 redrawtags $headmenuid
6525 if {$showlocalchanges} {
6531 global headmenuid headmenuhead mainhead
6534 set head $headmenuhead
6536 # this check shouldn't be needed any more...
6537 if {$head eq $mainhead} {
6538 error_popup "Cannot delete the currently checked-out branch"
6541 set dheads [descheads $id]
6542 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6543 # the stuff on this branch isn't on any other branch
6544 if {![confirm_popup "The commits on branch $head aren't on any other\
6545 branch.\nReally delete branch $head?"]} return
6549 if {[catch {exec git branch -D $head} err]} {
6554 removehead $id $head
6555 removedhead $id $head
6562 # Display a list of tags and heads
6564 global showrefstop bgcolor fgcolor selectbgcolor
6565 global bglist fglist reflistfilter reflist maincursor
6568 set showrefstop $top
6569 if {[winfo exists $top]} {
6575 wm title $top "Tags and heads: [file tail [pwd]]"
6576 text $top.list -background $bgcolor -foreground $fgcolor \
6577 -selectbackground $selectbgcolor -font mainfont \
6578 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6579 -width 30 -height 20 -cursor $maincursor \
6580 -spacing1 1 -spacing3 1 -state disabled
6581 $top.list tag configure highlight -background $selectbgcolor
6582 lappend bglist $top.list
6583 lappend fglist $top.list
6584 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6585 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6586 grid $top.list $top.ysb -sticky nsew
6587 grid $top.xsb x -sticky ew
6589 label $top.f.l -text "Filter: " -font uifont
6590 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6591 set reflistfilter "*"
6592 trace add variable reflistfilter write reflistfilter_change
6593 pack $top.f.e -side right -fill x -expand 1
6594 pack $top.f.l -side left
6595 grid $top.f - -sticky ew -pady 2
6596 button $top.close -command [list destroy $top] -text "Close" \
6599 grid columnconfigure $top 0 -weight 1
6600 grid rowconfigure $top 0 -weight 1
6601 bind $top.list <1> {break}
6602 bind $top.list <B1-Motion> {break}
6603 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6608 proc sel_reflist {w x y} {
6609 global showrefstop reflist headids tagids otherrefids
6611 if {![winfo exists $showrefstop]} return
6612 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6613 set ref [lindex $reflist [expr {$l-1}]]
6614 set n [lindex $ref 0]
6615 switch -- [lindex $ref 1] {
6616 "H" {selbyid $headids($n)}
6617 "T" {selbyid $tagids($n)}
6618 "o" {selbyid $otherrefids($n)}
6620 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6623 proc unsel_reflist {} {
6626 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6627 $showrefstop.list tag remove highlight 0.0 end
6630 proc reflistfilter_change {n1 n2 op} {
6631 global reflistfilter
6633 after cancel refill_reflist
6634 after 200 refill_reflist
6637 proc refill_reflist {} {
6638 global reflist reflistfilter showrefstop headids tagids otherrefids
6639 global commitrow curview commitinterest
6641 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6643 foreach n [array names headids] {
6644 if {[string match $reflistfilter $n]} {
6645 if {[info exists commitrow($curview,$headids($n))]} {
6646 lappend refs [list $n H]
6648 set commitinterest($headids($n)) {run refill_reflist}
6652 foreach n [array names tagids] {
6653 if {[string match $reflistfilter $n]} {
6654 if {[info exists commitrow($curview,$tagids($n))]} {
6655 lappend refs [list $n T]
6657 set commitinterest($tagids($n)) {run refill_reflist}
6661 foreach n [array names otherrefids] {
6662 if {[string match $reflistfilter $n]} {
6663 if {[info exists commitrow($curview,$otherrefids($n))]} {
6664 lappend refs [list $n o]
6666 set commitinterest($otherrefids($n)) {run refill_reflist}
6670 set refs [lsort -index 0 $refs]
6671 if {$refs eq $reflist} return
6673 # Update the contents of $showrefstop.list according to the
6674 # differences between $reflist (old) and $refs (new)
6675 $showrefstop.list conf -state normal
6676 $showrefstop.list insert end "\n"
6679 while {$i < [llength $reflist] || $j < [llength $refs]} {
6680 if {$i < [llength $reflist]} {
6681 if {$j < [llength $refs]} {
6682 set cmp [string compare [lindex $reflist $i 0] \
6683 [lindex $refs $j 0]]
6685 set cmp [string compare [lindex $reflist $i 1] \
6686 [lindex $refs $j 1]]
6696 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6704 set l [expr {$j + 1}]
6705 $showrefstop.list image create $l.0 -align baseline \
6706 -image reficon-[lindex $refs $j 1] -padx 2
6707 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6713 # delete last newline
6714 $showrefstop.list delete end-2c end-1c
6715 $showrefstop.list conf -state disabled
6718 # Stuff for finding nearby tags
6719 proc getallcommits {} {
6720 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6721 global idheads idtags idotherrefs allparents tagobjid
6723 if {![info exists allcommits]} {
6729 set allccache [file join [gitdir] "gitk.cache"]
6731 set f [open $allccache r]
6740 set cmd [list | git rev-list --parents]
6741 set allcupdate [expr {$seeds ne {}}]
6745 set refs [concat [array names idheads] [array names idtags] \
6746 [array names idotherrefs]]
6749 foreach name [array names tagobjid] {
6750 lappend tagobjs $tagobjid($name)
6752 foreach id [lsort -unique $refs] {
6753 if {![info exists allparents($id)] &&
6754 [lsearch -exact $tagobjs $id] < 0} {
6765 set fd [open [concat $cmd $ids] r]
6766 fconfigure $fd -blocking 0
6769 filerun $fd [list getallclines $fd]
6775 # Since most commits have 1 parent and 1 child, we group strings of
6776 # such commits into "arcs" joining branch/merge points (BMPs), which
6777 # are commits that either don't have 1 parent or don't have 1 child.
6779 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6780 # arcout(id) - outgoing arcs for BMP
6781 # arcids(a) - list of IDs on arc including end but not start
6782 # arcstart(a) - BMP ID at start of arc
6783 # arcend(a) - BMP ID at end of arc
6784 # growing(a) - arc a is still growing
6785 # arctags(a) - IDs out of arcids (excluding end) that have tags
6786 # archeads(a) - IDs out of arcids (excluding end) that have heads
6787 # The start of an arc is at the descendent end, so "incoming" means
6788 # coming from descendents, and "outgoing" means going towards ancestors.
6790 proc getallclines {fd} {
6791 global allparents allchildren idtags idheads nextarc
6792 global arcnos arcids arctags arcout arcend arcstart archeads growing
6793 global seeds allcommits cachedarcs allcupdate
6796 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6797 set id [lindex $line 0]
6798 if {[info exists allparents($id)]} {
6803 set olds [lrange $line 1 end]
6804 set allparents($id) $olds
6805 if {![info exists allchildren($id)]} {
6806 set allchildren($id) {}
6811 if {[llength $olds] == 1 && [llength $a] == 1} {
6812 lappend arcids($a) $id
6813 if {[info exists idtags($id)]} {
6814 lappend arctags($a) $id
6816 if {[info exists idheads($id)]} {
6817 lappend archeads($a) $id
6819 if {[info exists allparents($olds)]} {
6820 # seen parent already
6821 if {![info exists arcout($olds)]} {
6824 lappend arcids($a) $olds
6825 set arcend($a) $olds
6828 lappend allchildren($olds) $id
6829 lappend arcnos($olds) $a
6833 foreach a $arcnos($id) {
6834 lappend arcids($a) $id
6841 lappend allchildren($p) $id
6842 set a [incr nextarc]
6843 set arcstart($a) $id
6850 if {[info exists allparents($p)]} {
6851 # seen it already, may need to make a new branch
6852 if {![info exists arcout($p)]} {
6855 lappend arcids($a) $p
6859 lappend arcnos($p) $a
6864 global cached_dheads cached_dtags cached_atags
6865 catch {unset cached_dheads}
6866 catch {unset cached_dtags}
6867 catch {unset cached_atags}
6870 return [expr {$nid >= 1000? 2: 1}]
6874 fconfigure $fd -blocking 1
6877 # got an error reading the list of commits
6878 # if we were updating, try rereading the whole thing again
6884 error_popup "Error reading commit topology information;\
6885 branch and preceding/following tag information\
6886 will be incomplete.\n($err)"
6889 if {[incr allcommits -1] == 0} {
6899 proc recalcarc {a} {
6900 global arctags archeads arcids idtags idheads
6904 foreach id [lrange $arcids($a) 0 end-1] {
6905 if {[info exists idtags($id)]} {
6908 if {[info exists idheads($id)]} {
6913 set archeads($a) $ah
6917 global arcnos arcids nextarc arctags archeads idtags idheads
6918 global arcstart arcend arcout allparents growing
6921 if {[llength $a] != 1} {
6922 puts "oops splitarc called but [llength $a] arcs already"
6926 set i [lsearch -exact $arcids($a) $p]
6928 puts "oops splitarc $p not in arc $a"
6931 set na [incr nextarc]
6932 if {[info exists arcend($a)]} {
6933 set arcend($na) $arcend($a)
6935 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6936 set j [lsearch -exact $arcnos($l) $a]
6937 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6939 set tail [lrange $arcids($a) [expr {$i+1}] end]
6940 set arcids($a) [lrange $arcids($a) 0 $i]
6942 set arcstart($na) $p
6944 set arcids($na) $tail
6945 if {[info exists growing($a)]} {
6951 if {[llength $arcnos($id)] == 1} {
6954 set j [lsearch -exact $arcnos($id) $a]
6955 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6959 # reconstruct tags and heads lists
6960 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6965 set archeads($na) {}
6969 # Update things for a new commit added that is a child of one
6970 # existing commit. Used when cherry-picking.
6971 proc addnewchild {id p} {
6972 global allparents allchildren idtags nextarc
6973 global arcnos arcids arctags arcout arcend arcstart archeads growing
6974 global seeds allcommits
6976 if {![info exists allcommits]} return
6977 set allparents($id) [list $p]
6978 set allchildren($id) {}
6981 lappend allchildren($p) $id
6982 set a [incr nextarc]
6983 set arcstart($a) $id
6986 set arcids($a) [list $p]
6988 if {![info exists arcout($p)]} {
6991 lappend arcnos($p) $a
6992 set arcout($id) [list $a]
6995 # This implements a cache for the topology information.
6996 # The cache saves, for each arc, the start and end of the arc,
6997 # the ids on the arc, and the outgoing arcs from the end.
6998 proc readcache {f} {
6999 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
7000 global idtags idheads allparents cachedarcs possible_seeds seeds growing
7005 if {$lim - $a > 500} {
7006 set lim [expr {$a + 500}]
7010 # finish reading the cache and setting up arctags, etc.
7012 if {$line ne "1"} {error "bad final version"}
7014 foreach id [array names idtags] {
7015 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7016 [llength $allparents($id)] == 1} {
7017 set a [lindex $arcnos($id) 0]
7018 if {$arctags($a) eq {}} {
7023 foreach id [array names idheads] {
7024 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7025 [llength $allparents($id)] == 1} {
7026 set a [lindex $arcnos($id) 0]
7027 if {$archeads($a) eq {}} {
7032 foreach id [lsort -unique $possible_seeds] {
7033 if {$arcnos($id) eq {}} {
7039 while {[incr a] <= $lim} {
7041 if {[llength $line] != 3} {error "bad line"}
7042 set s [lindex $line 0]
7044 lappend arcout($s) $a
7045 if {![info exists arcnos($s)]} {
7046 lappend possible_seeds $s
7049 set e [lindex $line 1]
7054 if {![info exists arcout($e)]} {
7058 set arcids($a) [lindex $line 2]
7059 foreach id $arcids($a) {
7060 lappend allparents($s) $id
7062 lappend arcnos($id) $a
7064 if {![info exists allparents($s)]} {
7065 set allparents($s) {}
7070 set nextarc [expr {$a - 1}]
7083 global nextarc cachedarcs possible_seeds
7087 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7088 # make sure it's an integer
7089 set cachedarcs [expr {int([lindex $line 1])}]
7090 if {$cachedarcs < 0} {error "bad number of arcs"}
7092 set possible_seeds {}
7100 proc dropcache {err} {
7101 global allcwait nextarc cachedarcs seeds
7103 #puts "dropping cache ($err)"
7104 foreach v {arcnos arcout arcids arcstart arcend growing \
7105 arctags archeads allparents allchildren} {
7116 proc writecache {f} {
7117 global cachearc cachedarcs allccache
7118 global arcstart arcend arcnos arcids arcout
7122 if {$lim - $a > 1000} {
7123 set lim [expr {$a + 1000}]
7126 while {[incr a] <= $lim} {
7127 if {[info exists arcend($a)]} {
7128 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7130 puts $f [list $arcstart($a) {} $arcids($a)]
7135 catch {file delete $allccache}
7136 #puts "writing cache failed ($err)"
7139 set cachearc [expr {$a - 1}]
7140 if {$a > $cachedarcs} {
7149 global nextarc cachedarcs cachearc allccache
7151 if {$nextarc == $cachedarcs} return
7153 set cachedarcs $nextarc
7155 set f [open $allccache w]
7156 puts $f [list 1 $cachedarcs]
7161 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7162 # or 0 if neither is true.
7163 proc anc_or_desc {a b} {
7164 global arcout arcstart arcend arcnos cached_isanc
7166 if {$arcnos($a) eq $arcnos($b)} {
7167 # Both are on the same arc(s); either both are the same BMP,
7168 # or if one is not a BMP, the other is also not a BMP or is
7169 # the BMP at end of the arc (and it only has 1 incoming arc).
7170 # Or both can be BMPs with no incoming arcs.
7171 if {$a eq $b || $arcnos($a) eq {}} {
7174 # assert {[llength $arcnos($a)] == 1}
7175 set arc [lindex $arcnos($a) 0]
7176 set i [lsearch -exact $arcids($arc) $a]
7177 set j [lsearch -exact $arcids($arc) $b]
7178 if {$i < 0 || $i > $j} {
7185 if {![info exists arcout($a)]} {
7186 set arc [lindex $arcnos($a) 0]
7187 if {[info exists arcend($arc)]} {
7188 set aend $arcend($arc)
7192 set a $arcstart($arc)
7196 if {![info exists arcout($b)]} {
7197 set arc [lindex $arcnos($b) 0]
7198 if {[info exists arcend($arc)]} {
7199 set bend $arcend($arc)
7203 set b $arcstart($arc)
7213 if {[info exists cached_isanc($a,$bend)]} {
7214 if {$cached_isanc($a,$bend)} {
7218 if {[info exists cached_isanc($b,$aend)]} {
7219 if {$cached_isanc($b,$aend)} {
7222 if {[info exists cached_isanc($a,$bend)]} {
7227 set todo [list $a $b]
7230 for {set i 0} {$i < [llength $todo]} {incr i} {
7231 set x [lindex $todo $i]
7232 if {$anc($x) eq {}} {
7235 foreach arc $arcnos($x) {
7236 set xd $arcstart($arc)
7238 set cached_isanc($a,$bend) 1
7239 set cached_isanc($b,$aend) 0
7241 } elseif {$xd eq $aend} {
7242 set cached_isanc($b,$aend) 1
7243 set cached_isanc($a,$bend) 0
7246 if {![info exists anc($xd)]} {
7247 set anc($xd) $anc($x)
7249 } elseif {$anc($xd) ne $anc($x)} {
7254 set cached_isanc($a,$bend) 0
7255 set cached_isanc($b,$aend) 0
7259 # This identifies whether $desc has an ancestor that is
7260 # a growing tip of the graph and which is not an ancestor of $anc
7261 # and returns 0 if so and 1 if not.
7262 # If we subsequently discover a tag on such a growing tip, and that
7263 # turns out to be a descendent of $anc (which it could, since we
7264 # don't necessarily see children before parents), then $desc
7265 # isn't a good choice to display as a descendent tag of
7266 # $anc (since it is the descendent of another tag which is
7267 # a descendent of $anc). Similarly, $anc isn't a good choice to
7268 # display as a ancestor tag of $desc.
7270 proc is_certain {desc anc} {
7271 global arcnos arcout arcstart arcend growing problems
7274 if {[llength $arcnos($anc)] == 1} {
7275 # tags on the same arc are certain
7276 if {$arcnos($desc) eq $arcnos($anc)} {
7279 if {![info exists arcout($anc)]} {
7280 # if $anc is partway along an arc, use the start of the arc instead
7281 set a [lindex $arcnos($anc) 0]
7282 set anc $arcstart($a)
7285 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7288 set a [lindex $arcnos($desc) 0]
7294 set anclist [list $x]
7298 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7299 set x [lindex $anclist $i]
7304 foreach a $arcout($x) {
7305 if {[info exists growing($a)]} {
7306 if {![info exists growanc($x)] && $dl($x)} {
7312 if {[info exists dl($y)]} {
7316 if {![info exists done($y)]} {
7319 if {[info exists growanc($x)]} {
7323 for {set k 0} {$k < [llength $xl]} {incr k} {
7324 set z [lindex $xl $k]
7325 foreach c $arcout($z) {
7326 if {[info exists arcend($c)]} {
7328 if {[info exists dl($v)] && $dl($v)} {
7330 if {![info exists done($v)]} {
7333 if {[info exists growanc($v)]} {
7343 } elseif {$y eq $anc || !$dl($x)} {
7354 foreach x [array names growanc] {
7363 proc validate_arctags {a} {
7364 global arctags idtags
7368 foreach id $arctags($a) {
7370 if {![info exists idtags($id)]} {
7371 set na [lreplace $na $i $i]
7378 proc validate_archeads {a} {
7379 global archeads idheads
7382 set na $archeads($a)
7383 foreach id $archeads($a) {
7385 if {![info exists idheads($id)]} {
7386 set na [lreplace $na $i $i]
7390 set archeads($a) $na
7393 # Return the list of IDs that have tags that are descendents of id,
7394 # ignoring IDs that are descendents of IDs already reported.
7395 proc desctags {id} {
7396 global arcnos arcstart arcids arctags idtags allparents
7397 global growing cached_dtags
7399 if {![info exists allparents($id)]} {
7402 set t1 [clock clicks -milliseconds]
7404 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7405 # part-way along an arc; check that arc first
7406 set a [lindex $arcnos($id) 0]
7407 if {$arctags($a) ne {}} {
7409 set i [lsearch -exact $arcids($a) $id]
7411 foreach t $arctags($a) {
7412 set j [lsearch -exact $arcids($a) $t]
7420 set id $arcstart($a)
7421 if {[info exists idtags($id)]} {
7425 if {[info exists cached_dtags($id)]} {
7426 return $cached_dtags($id)
7433 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7434 set id [lindex $todo $i]
7436 set ta [info exists hastaggedancestor($id)]
7440 # ignore tags on starting node
7441 if {!$ta && $i > 0} {
7442 if {[info exists idtags($id)]} {
7445 } elseif {[info exists cached_dtags($id)]} {
7446 set tagloc($id) $cached_dtags($id)
7450 foreach a $arcnos($id) {
7452 if {!$ta && $arctags($a) ne {}} {
7454 if {$arctags($a) ne {}} {
7455 lappend tagloc($id) [lindex $arctags($a) end]
7458 if {$ta || $arctags($a) ne {}} {
7459 set tomark [list $d]
7460 for {set j 0} {$j < [llength $tomark]} {incr j} {
7461 set dd [lindex $tomark $j]
7462 if {![info exists hastaggedancestor($dd)]} {
7463 if {[info exists done($dd)]} {
7464 foreach b $arcnos($dd) {
7465 lappend tomark $arcstart($b)
7467 if {[info exists tagloc($dd)]} {
7470 } elseif {[info exists queued($dd)]} {
7473 set hastaggedancestor($dd) 1
7477 if {![info exists queued($d)]} {
7480 if {![info exists hastaggedancestor($d)]} {
7487 foreach id [array names tagloc] {
7488 if {![info exists hastaggedancestor($id)]} {
7489 foreach t $tagloc($id) {
7490 if {[lsearch -exact $tags $t] < 0} {
7496 set t2 [clock clicks -milliseconds]
7499 # remove tags that are descendents of other tags
7500 for {set i 0} {$i < [llength $tags]} {incr i} {
7501 set a [lindex $tags $i]
7502 for {set j 0} {$j < $i} {incr j} {
7503 set b [lindex $tags $j]
7504 set r [anc_or_desc $a $b]
7506 set tags [lreplace $tags $j $j]
7509 } elseif {$r == -1} {
7510 set tags [lreplace $tags $i $i]
7517 if {[array names growing] ne {}} {
7518 # graph isn't finished, need to check if any tag could get
7519 # eclipsed by another tag coming later. Simply ignore any
7520 # tags that could later get eclipsed.
7523 if {[is_certain $t $origid]} {
7527 if {$tags eq $ctags} {
7528 set cached_dtags($origid) $tags
7533 set cached_dtags($origid) $tags
7535 set t3 [clock clicks -milliseconds]
7536 if {0 && $t3 - $t1 >= 100} {
7537 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7538 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7544 global arcnos arcids arcout arcend arctags idtags allparents
7545 global growing cached_atags
7547 if {![info exists allparents($id)]} {
7550 set t1 [clock clicks -milliseconds]
7552 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7553 # part-way along an arc; check that arc first
7554 set a [lindex $arcnos($id) 0]
7555 if {$arctags($a) ne {}} {
7557 set i [lsearch -exact $arcids($a) $id]
7558 foreach t $arctags($a) {
7559 set j [lsearch -exact $arcids($a) $t]
7565 if {![info exists arcend($a)]} {
7569 if {[info exists idtags($id)]} {
7573 if {[info exists cached_atags($id)]} {
7574 return $cached_atags($id)
7582 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7583 set id [lindex $todo $i]
7585 set td [info exists hastaggeddescendent($id)]
7589 # ignore tags on starting node
7590 if {!$td && $i > 0} {
7591 if {[info exists idtags($id)]} {
7594 } elseif {[info exists cached_atags($id)]} {
7595 set tagloc($id) $cached_atags($id)
7599 foreach a $arcout($id) {
7600 if {!$td && $arctags($a) ne {}} {
7602 if {$arctags($a) ne {}} {
7603 lappend tagloc($id) [lindex $arctags($a) 0]
7606 if {![info exists arcend($a)]} continue
7608 if {$td || $arctags($a) ne {}} {
7609 set tomark [list $d]
7610 for {set j 0} {$j < [llength $tomark]} {incr j} {
7611 set dd [lindex $tomark $j]
7612 if {![info exists hastaggeddescendent($dd)]} {
7613 if {[info exists done($dd)]} {
7614 foreach b $arcout($dd) {
7615 if {[info exists arcend($b)]} {
7616 lappend tomark $arcend($b)
7619 if {[info exists tagloc($dd)]} {
7622 } elseif {[info exists queued($dd)]} {
7625 set hastaggeddescendent($dd) 1
7629 if {![info exists queued($d)]} {
7632 if {![info exists hastaggeddescendent($d)]} {
7638 set t2 [clock clicks -milliseconds]
7641 foreach id [array names tagloc] {
7642 if {![info exists hastaggeddescendent($id)]} {
7643 foreach t $tagloc($id) {
7644 if {[lsearch -exact $tags $t] < 0} {
7651 # remove tags that are ancestors of other tags
7652 for {set i 0} {$i < [llength $tags]} {incr i} {
7653 set a [lindex $tags $i]
7654 for {set j 0} {$j < $i} {incr j} {
7655 set b [lindex $tags $j]
7656 set r [anc_or_desc $a $b]
7658 set tags [lreplace $tags $j $j]
7661 } elseif {$r == 1} {
7662 set tags [lreplace $tags $i $i]
7669 if {[array names growing] ne {}} {
7670 # graph isn't finished, need to check if any tag could get
7671 # eclipsed by another tag coming later. Simply ignore any
7672 # tags that could later get eclipsed.
7675 if {[is_certain $origid $t]} {
7679 if {$tags eq $ctags} {
7680 set cached_atags($origid) $tags
7685 set cached_atags($origid) $tags
7687 set t3 [clock clicks -milliseconds]
7688 if {0 && $t3 - $t1 >= 100} {
7689 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7690 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7695 # Return the list of IDs that have heads that are descendents of id,
7696 # including id itself if it has a head.
7697 proc descheads {id} {
7698 global arcnos arcstart arcids archeads idheads cached_dheads
7701 if {![info exists allparents($id)]} {
7705 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7706 # part-way along an arc; check it first
7707 set a [lindex $arcnos($id) 0]
7708 if {$archeads($a) ne {}} {
7709 validate_archeads $a
7710 set i [lsearch -exact $arcids($a) $id]
7711 foreach t $archeads($a) {
7712 set j [lsearch -exact $arcids($a) $t]
7717 set id $arcstart($a)
7723 for {set i 0} {$i < [llength $todo]} {incr i} {
7724 set id [lindex $todo $i]
7725 if {[info exists cached_dheads($id)]} {
7726 set ret [concat $ret $cached_dheads($id)]
7728 if {[info exists idheads($id)]} {
7731 foreach a $arcnos($id) {
7732 if {$archeads($a) ne {}} {
7733 validate_archeads $a
7734 if {$archeads($a) ne {}} {
7735 set ret [concat $ret $archeads($a)]
7739 if {![info exists seen($d)]} {
7746 set ret [lsort -unique $ret]
7747 set cached_dheads($origid) $ret
7748 return [concat $ret $aret]
7751 proc addedtag {id} {
7752 global arcnos arcout cached_dtags cached_atags
7754 if {![info exists arcnos($id)]} return
7755 if {![info exists arcout($id)]} {
7756 recalcarc [lindex $arcnos($id) 0]
7758 catch {unset cached_dtags}
7759 catch {unset cached_atags}
7762 proc addedhead {hid head} {
7763 global arcnos arcout cached_dheads
7765 if {![info exists arcnos($hid)]} return
7766 if {![info exists arcout($hid)]} {
7767 recalcarc [lindex $arcnos($hid) 0]
7769 catch {unset cached_dheads}
7772 proc removedhead {hid head} {
7773 global cached_dheads
7775 catch {unset cached_dheads}
7778 proc movedhead {hid head} {
7779 global arcnos arcout cached_dheads
7781 if {![info exists arcnos($hid)]} return
7782 if {![info exists arcout($hid)]} {
7783 recalcarc [lindex $arcnos($hid) 0]
7785 catch {unset cached_dheads}
7788 proc changedrefs {} {
7789 global cached_dheads cached_dtags cached_atags
7790 global arctags archeads arcnos arcout idheads idtags
7792 foreach id [concat [array names idheads] [array names idtags]] {
7793 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7794 set a [lindex $arcnos($id) 0]
7795 if {![info exists donearc($a)]} {
7801 catch {unset cached_dtags}
7802 catch {unset cached_atags}
7803 catch {unset cached_dheads}
7806 proc rereadrefs {} {
7807 global idtags idheads idotherrefs mainhead
7809 set refids [concat [array names idtags] \
7810 [array names idheads] [array names idotherrefs]]
7811 foreach id $refids {
7812 if {![info exists ref($id)]} {
7813 set ref($id) [listrefs $id]
7816 set oldmainhead $mainhead
7819 set refids [lsort -unique [concat $refids [array names idtags] \
7820 [array names idheads] [array names idotherrefs]]]
7821 foreach id $refids {
7822 set v [listrefs $id]
7823 if {![info exists ref($id)] || $ref($id) != $v ||
7824 ($id eq $oldmainhead && $id ne $mainhead) ||
7825 ($id eq $mainhead && $id ne $oldmainhead)} {
7832 proc listrefs {id} {
7833 global idtags idheads idotherrefs
7836 if {[info exists idtags($id)]} {
7840 if {[info exists idheads($id)]} {
7844 if {[info exists idotherrefs($id)]} {
7845 set z $idotherrefs($id)
7847 return [list $x $y $z]
7850 proc showtag {tag isnew} {
7851 global ctext tagcontents tagids linknum tagobjid
7854 addtohistory [list showtag $tag 0]
7856 $ctext conf -state normal
7860 if {![info exists tagcontents($tag)]} {
7862 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7865 if {[info exists tagcontents($tag)]} {
7866 set text $tagcontents($tag)
7868 set text "Tag: $tag\nId: $tagids($tag)"
7870 appendwithlinks $text {}
7871 $ctext conf -state disabled
7882 proc mkfontdisp {font top which} {
7883 global fontattr fontpref $font
7885 set fontpref($font) [set $font]
7886 button $top.${font}but -text $which -font optionfont \
7887 -command [list choosefont $font $which]
7888 label $top.$font -relief flat -font $font \
7889 -text $fontattr($font,family) -justify left
7890 grid x $top.${font}but $top.$font -sticky w
7893 proc choosefont {font which} {
7894 global fontparam fontlist fonttop fontattr
7896 set fontparam(which) $which
7897 set fontparam(font) $font
7898 set fontparam(family) [font actual $font -family]
7899 set fontparam(size) $fontattr($font,size)
7900 set fontparam(weight) $fontattr($font,weight)
7901 set fontparam(slant) $fontattr($font,slant)
7904 if {![winfo exists $top]} {
7906 eval font config sample [font actual $font]
7908 wm title $top "Gitk font chooser"
7909 label $top.l -textvariable fontparam(which) -font uifont
7910 pack $top.l -side top
7911 set fontlist [lsort [font families]]
7913 listbox $top.f.fam -listvariable fontlist \
7914 -yscrollcommand [list $top.f.sb set]
7915 bind $top.f.fam <<ListboxSelect>> selfontfam
7916 scrollbar $top.f.sb -command [list $top.f.fam yview]
7917 pack $top.f.sb -side right -fill y
7918 pack $top.f.fam -side left -fill both -expand 1
7919 pack $top.f -side top -fill both -expand 1
7921 spinbox $top.g.size -from 4 -to 40 -width 4 \
7922 -textvariable fontparam(size) \
7923 -validatecommand {string is integer -strict %s}
7924 checkbutton $top.g.bold -padx 5 \
7925 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7926 -variable fontparam(weight) -onvalue bold -offvalue normal
7927 checkbutton $top.g.ital -padx 5 \
7928 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
7929 -variable fontparam(slant) -onvalue italic -offvalue roman
7930 pack $top.g.size $top.g.bold $top.g.ital -side left
7931 pack $top.g -side top
7932 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7934 $top.c create text 100 25 -anchor center -text $which -font sample \
7935 -fill black -tags text
7936 bind $top.c <Configure> [list centertext $top.c]
7937 pack $top.c -side top -fill x
7939 button $top.buts.ok -text "OK" -command fontok -default active \
7941 button $top.buts.can -text "Cancel" -command fontcan -default normal \
7943 grid $top.buts.ok $top.buts.can
7944 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7945 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7946 pack $top.buts -side bottom -fill x
7947 trace add variable fontparam write chg_fontparam
7950 $top.c itemconf text -text $which
7952 set i [lsearch -exact $fontlist $fontparam(family)]
7954 $top.f.fam selection set $i
7959 proc centertext {w} {
7960 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7964 global fontparam fontpref prefstop
7966 set f $fontparam(font)
7967 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7968 if {$fontparam(weight) eq "bold"} {
7969 lappend fontpref($f) "bold"
7971 if {$fontparam(slant) eq "italic"} {
7972 lappend fontpref($f) "italic"
7975 $w conf -text $fontparam(family) -font $fontpref($f)
7981 global fonttop fontparam
7983 if {[info exists fonttop]} {
7984 catch {destroy $fonttop}
7985 catch {font delete sample}
7991 proc selfontfam {} {
7992 global fonttop fontparam
7994 set i [$fonttop.f.fam curselection]
7996 set fontparam(family) [$fonttop.f.fam get $i]
8000 proc chg_fontparam {v sub op} {
8003 font config sample -$sub $fontparam($sub)
8007 global maxwidth maxgraphpct
8008 global oldprefs prefstop showneartags showlocalchanges
8009 global bgcolor fgcolor ctext diffcolors selectbgcolor
8010 global uifont tabstop
8014 if {[winfo exists $top]} {
8018 foreach v {maxwidth maxgraphpct showneartags showlocalchanges} {
8019 set oldprefs($v) [set $v]
8022 wm title $top "Gitk preferences"
8023 label $top.ldisp -text "Commit list display options"
8024 $top.ldisp configure -font uifont
8025 grid $top.ldisp - -sticky w -pady 10
8026 label $top.spacer -text " "
8027 label $top.maxwidthl -text "Maximum graph width (lines)" \
8029 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8030 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8031 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8033 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8034 grid x $top.maxpctl $top.maxpct -sticky w
8035 frame $top.showlocal
8036 label $top.showlocal.l -text "Show local changes" -font optionfont
8037 checkbutton $top.showlocal.b -variable showlocalchanges
8038 pack $top.showlocal.b $top.showlocal.l -side left
8039 grid x $top.showlocal -sticky w
8041 label $top.ddisp -text "Diff display options"
8042 $top.ddisp configure -font uifont
8043 grid $top.ddisp - -sticky w -pady 10
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
8145 global oldprefs prefstop showneartags showlocalchanges
8147 foreach v {maxwidth maxgraphpct 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 wrcomcmd "git diff-tree --stdin -p --pretty"
8486 set gitencoding [exec git config --get i18n.commitencoding]
8488 if {$gitencoding == ""} {
8489 set gitencoding "utf-8"
8491 set tclencoding [tcl_encoding $gitencoding]
8492 if {$tclencoding == {}} {
8493 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8496 set mainfont {Helvetica 9}
8497 set textfont {Courier 9}
8498 set uifont {Helvetica 9 bold}
8500 set findmergefiles 0
8508 set cmitmode "patch"
8509 set wrapcomment "none"
8513 set showlocalchanges 1
8514 set datetimeformat "%Y-%m-%d %H:%M:%S"
8516 set colors {green red blue magenta darkgrey brown orange}
8519 set diffcolors {red "#00a000" blue}
8521 set selectbgcolor gray85
8523 catch {source ~/.gitk}
8525 font create optionfont -family sans-serif -size -12
8527 parsefont mainfont $mainfont
8528 eval font create mainfont [fontflags mainfont]
8529 eval font create mainfontbold [fontflags mainfont 1]
8531 parsefont textfont $textfont
8532 eval font create textfont [fontflags textfont]
8533 eval font create textfontbold [fontflags textfont 1]
8535 parsefont uifont $uifont
8536 eval font create uifont [fontflags uifont]
8538 # check that we can find a .git directory somewhere...
8539 if {[catch {set gitdir [gitdir]}]} {
8540 show_error {} . "Cannot find a git repository here."
8543 if {![file isdirectory $gitdir]} {
8544 show_error {} . "Cannot find the git directory \"$gitdir\"."
8549 set cmdline_files {}
8554 "-d" { set datemode 1 }
8556 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8560 lappend revtreeargs $arg
8566 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8567 # no -- on command line, but some arguments (other than -d)
8569 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8570 set cmdline_files [split $f "\n"]
8571 set n [llength $cmdline_files]
8572 set revtreeargs [lrange $revtreeargs 0 end-$n]
8573 # Unfortunately git rev-parse doesn't produce an error when
8574 # something is both a revision and a filename. To be consistent
8575 # with git log and git rev-list, check revtreeargs for filenames.
8576 foreach arg $revtreeargs {
8577 if {[file exists $arg]} {
8578 show_error {} . "Ambiguous argument '$arg': both revision\
8584 # unfortunately we get both stdout and stderr in $err,
8585 # so look for "fatal:".
8586 set i [string first "fatal:" $err]
8588 set err [string range $err [expr {$i + 6}] end]
8590 show_error {} . "Bad arguments to gitk:\n$err"
8595 set nullid "0000000000000000000000000000000000000000"
8596 set nullid2 "0000000000000000000000000000000000000001"
8598 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8605 set highlight_paths {}
8607 set searchdirn -forwards
8611 set markingmatches 0
8612 set linkentercount 0
8613 set need_redisplay 0
8620 set selectedhlview None
8621 set highlight_related None
8622 set highlight_files {}
8636 # wait for the window to become visible
8638 wm title . "[file tail $argv0]: [file tail [pwd]]"
8641 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8642 # create a view for the files/dirs specified on the command line
8646 set viewname(1) "Command line"
8647 set viewfiles(1) $cmdline_files
8648 set viewargs(1) $revtreeargs
8651 .bar.view entryconf Edit* -state normal
8652 .bar.view entryconf Delete* -state normal
8655 if {[info exists permviews]} {
8656 foreach v $permviews {
8659 set viewname($n) [lindex $v 0]
8660 set viewfiles($n) [lindex $v 1]
8661 set viewargs($n) [lindex $v 2]