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
86 global lookingforhead showlocalchanges
88 set startmsecs
[clock clicks
-milliseconds]
89 set commitidx
($view) 0
90 set order
"--topo-order"
92 set order
"--date-order"
95 set fd
[open
[concat | git log
-z --pretty=raw
$order --parents \
96 --boundary $viewargs($view) "--" $viewfiles($view)] r
]
98 error_popup
"Error executing git rev-list: $err"
101 set commfd
($view) $fd
102 set leftover
($view) {}
103 set lookingforhead
$showlocalchanges
104 fconfigure
$fd -blocking 0 -translation lf
-eofchar {}
105 if {$tclencoding != {}} {
106 fconfigure
$fd -encoding $tclencoding
108 filerun
$fd [list getcommitlines
$fd $view]
112 proc stop_rev_list
{} {
113 global commfd curview
115 if {![info exists commfd
($curview)]} return
116 set fd
$commfd($curview)
122 unset commfd
($curview)
126 global phase canv mainfont curview
130 start_rev_list
$curview
131 show_status
"Reading commits..."
134 proc getcommitlines
{fd view
} {
136 global leftover commfd
137 global displayorder commitidx commitrow commitdata
138 global parentlist children curview hlview
139 global vparentlist vdisporder vcmitlisted
141 set stuff
[read $fd 500000]
149 # set it blocking so we wait for the process to terminate
150 fconfigure
$fd -blocking 1
151 if {[catch
{close
$fd} err
]} {
153 if {$view != $curview} {
154 set fv
" for the \"$viewname($view)\" view"
156 if {[string range
$err 0 4] == "usage"} {
157 set err
"Gitk: error reading commits$fv:\
158 bad arguments to git rev-list."
159 if {$viewname($view) eq
"Command line"} {
161 " (Note: arguments to gitk are passed to git rev-list\
162 to allow selection of commits to be displayed.)"
165 set err
"Error reading commits$fv: $err"
169 if {$view == $curview} {
170 run chewcommits
$view
177 set i
[string first
"\0" $stuff $start]
179 append leftover
($view) [string range
$stuff $start end
]
183 set cmit
$leftover($view)
184 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
185 set leftover
($view) {}
187 set cmit
[string range
$stuff $start [expr {$i - 1}]]
189 set start
[expr {$i + 1}]
190 set j
[string first
"\n" $cmit]
193 if {$j >= 0 && [string match
"commit *" $cmit]} {
194 set ids
[string range
$cmit 7 [expr {$j - 1}]]
195 if {[string match
{[-<>]*} $ids]} {
196 switch
-- [string index
$ids 0] {
201 set ids
[string range
$ids 1 end
]
205 if {[string length
$id] != 40} {
213 if {[string length
$shortcmit] > 80} {
214 set shortcmit
"[string range $shortcmit 0 80]..."
216 error_popup
"Can't parse git log output: {$shortcmit}"
219 set id
[lindex
$ids 0]
221 set olds
[lrange
$ids 1 end
]
224 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
225 lappend children
($view,$p) $id
232 if {![info exists children
($view,$id)]} {
233 set children
($view,$id) {}
235 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
236 set commitrow
($view,$id) $commitidx($view)
237 incr commitidx
($view)
238 if {$view == $curview} {
239 lappend parentlist
$olds
240 lappend displayorder
$id
241 lappend commitlisted
$listed
243 lappend vparentlist
($view) $olds
244 lappend vdisporder
($view) $id
245 lappend vcmitlisted
($view) $listed
250 run chewcommits
$view
255 proc chewcommits
{view
} {
256 global curview hlview commfd
257 global selectedline pending_select
260 if {$view == $curview} {
261 set allread
[expr {![info exists commfd
($view)]}]
262 set tlimit
[expr {[clock clicks
-milliseconds] + 50}]
263 set more [layoutmore
$tlimit $allread]
264 if {$allread && !$more} {
265 global displayorder commitidx phase
266 global numcommits startmsecs
268 if {[info exists pending_select
]} {
269 set row
[first_real_row
]
272 if {$commitidx($curview) > 0} {
273 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
274 #puts "overall $ms ms for $numcommits commits"
276 show_status
"No commits selected"
282 if {[info exists hlview
] && $view == $hlview} {
288 proc readcommit
{id
} {
289 if {[catch
{set contents
[exec git cat-file commit
$id]}]} return
290 parsecommit
$id $contents 0
293 proc updatecommits
{} {
294 global viewdata curview phase displayorder
295 global children commitrow selectedline thickerline
302 foreach id
$displayorder {
303 catch
{unset children
($n,$id)}
304 catch
{unset commitrow
($n,$id)}
307 catch
{unset selectedline
}
308 catch
{unset thickerline
}
309 catch
{unset viewdata
($n)}
316 proc parsecommit
{id contents listed
} {
317 global commitinfo cdate
326 set hdrend
[string first
"\n\n" $contents]
328 # should never happen...
329 set hdrend
[string length
$contents]
331 set header
[string range
$contents 0 [expr {$hdrend - 1}]]
332 set comment
[string range
$contents [expr {$hdrend + 2}] end
]
333 foreach line
[split $header "\n"] {
334 set tag
[lindex
$line 0]
335 if {$tag == "author"} {
336 set audate
[lindex
$line end-1
]
337 set auname
[lrange
$line 1 end-2
]
338 } elseif
{$tag == "committer"} {
339 set comdate
[lindex
$line end-1
]
340 set comname
[lrange
$line 1 end-2
]
344 # take the first non-blank line of the comment as the headline
345 set headline
[string trimleft
$comment]
346 set i
[string first
"\n" $headline]
348 set headline
[string range
$headline 0 $i]
350 set headline
[string trimright
$headline]
351 set i
[string first
"\r" $headline]
353 set headline
[string trimright
[string range
$headline 0 $i]]
356 # git rev-list indents the comment by 4 spaces;
357 # if we got this via git cat-file, add the indentation
359 foreach line
[split $comment "\n"] {
360 append newcomment
" "
361 append newcomment
$line
362 append newcomment
"\n"
364 set comment
$newcomment
366 if {$comdate != {}} {
367 set cdate
($id) $comdate
369 set commitinfo
($id) [list
$headline $auname $audate \
370 $comname $comdate $comment]
373 proc getcommit
{id
} {
374 global commitdata commitinfo
376 if {[info exists commitdata
($id)]} {
377 parsecommit
$id $commitdata($id) 1
380 if {![info exists commitinfo
($id)]} {
381 set commitinfo
($id) {"No commit information available"}
388 global tagids idtags headids idheads tagobjid
389 global otherrefids idotherrefs mainhead mainheadid
391 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
394 set refd
[open
[list | git show-ref
-d] r
]
395 while {[gets
$refd line
] >= 0} {
396 if {[string index
$line 40] ne
" "} continue
397 set id
[string range
$line 0 39]
398 set ref
[string range
$line 41 end
]
399 if {![string match
"refs/*" $ref]} continue
400 set name
[string range
$ref 5 end
]
401 if {[string match
"remotes/*" $name]} {
402 if {![string match
"*/HEAD" $name]} {
403 set headids
($name) $id
404 lappend idheads
($id) $name
406 } elseif
{[string match
"heads/*" $name]} {
407 set name
[string range
$name 6 end
]
408 set headids
($name) $id
409 lappend idheads
($id) $name
410 } elseif
{[string match
"tags/*" $name]} {
411 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
412 # which is what we want since the former is the commit ID
413 set name
[string range
$name 5 end
]
414 if {[string match
"*^{}" $name]} {
415 set name
[string range
$name 0 end-3
]
417 set tagobjid
($name) $id
419 set tagids
($name) $id
420 lappend idtags
($id) $name
422 set otherrefids
($name) $id
423 lappend idotherrefs
($id) $name
430 set thehead
[exec git symbolic-ref HEAD
]
431 if {[string match
"refs/heads/*" $thehead]} {
432 set mainhead
[string range
$thehead 11 end
]
433 if {[info exists headids
($mainhead)]} {
434 set mainheadid
$headids($mainhead)
440 # skip over fake commits
441 proc first_real_row
{} {
442 global nullid nullid2 displayorder numcommits
444 for {set row
0} {$row < $numcommits} {incr row
} {
445 set id
[lindex
$displayorder $row]
446 if {$id ne
$nullid && $id ne
$nullid2} {
453 # update things for a head moved to a child of its previous location
454 proc movehead
{id name
} {
455 global headids idheads
457 removehead
$headids($name) $name
458 set headids
($name) $id
459 lappend idheads
($id) $name
462 # update things when a head has been removed
463 proc removehead
{id name
} {
464 global headids idheads
466 if {$idheads($id) eq
$name} {
469 set i
[lsearch
-exact $idheads($id) $name]
471 set idheads
($id) [lreplace
$idheads($id) $i $i]
477 proc show_error
{w top msg
} {
478 message
$w.m
-text $msg -justify center
-aspect 400
479 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
480 button
$w.ok
-text OK
-command "destroy $top"
481 pack
$w.ok
-side bottom
-fill x
482 bind $top <Visibility
> "grab $top; focus $top"
483 bind $top <Key-Return
> "destroy $top"
487 proc error_popup msg
{
491 show_error
$w $w $msg
494 proc confirm_popup msg
{
500 message
$w.m
-text $msg -justify center
-aspect 400
501 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
502 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
503 pack
$w.ok
-side left
-fill x
504 button
$w.cancel
-text Cancel
-command "destroy $w"
505 pack
$w.cancel
-side right
-fill x
506 bind $w <Visibility
> "grab $w; focus $w"
512 global canv canv2 canv3 linespc charspc ctext cflist
513 global textfont mainfont uifont tabstop
514 global findtype findtypemenu findloc findstring fstring geometry
515 global entries sha1entry sha1string sha1but
516 global maincursor textcursor curtextcursor
517 global rowctxmenu fakerowmenu mergemax wrapcomment
518 global highlight_files gdttype
519 global searchstring sstring
520 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
524 .bar add cascade
-label "File" -menu .bar.
file
525 .bar configure
-font $uifont
527 .bar.
file add
command -label "Update" -command updatecommits
528 .bar.
file add
command -label "Reread references" -command rereadrefs
529 .bar.
file add
command -label "Quit" -command doquit
530 .bar.
file configure
-font $uifont
532 .bar add cascade
-label "Edit" -menu .bar.edit
533 .bar.edit add
command -label "Preferences" -command doprefs
534 .bar.edit configure
-font $uifont
536 menu .bar.view
-font $uifont
537 .bar add cascade
-label "View" -menu .bar.view
538 .bar.view add
command -label "New view..." -command {newview
0}
539 .bar.view add
command -label "Edit view..." -command editview \
541 .bar.view add
command -label "Delete view" -command delview
-state disabled
542 .bar.view add separator
543 .bar.view add radiobutton
-label "All files" -command {showview
0} \
544 -variable selectedview
-value 0
547 .bar add cascade
-label "Help" -menu .bar.
help
548 .bar.
help add
command -label "About gitk" -command about
549 .bar.
help add
command -label "Key bindings" -command keys
550 .bar.
help configure
-font $uifont
551 . configure
-menu .bar
553 # the gui has upper and lower half, parts of a paned window.
554 panedwindow .ctop
-orient vertical
556 # possibly use assumed geometry
557 if {![info exists geometry
(pwsash0
)]} {
558 set geometry
(topheight
) [expr {15 * $linespc}]
559 set geometry
(topwidth
) [expr {80 * $charspc}]
560 set geometry
(botheight
) [expr {15 * $linespc}]
561 set geometry
(botwidth
) [expr {50 * $charspc}]
562 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
563 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
566 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
567 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
569 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
571 # create three canvases
572 set cscroll .tf.histframe.csb
573 set canv .tf.histframe.pwclist.canv
575 -selectbackground $selectbgcolor \
576 -background $bgcolor -bd 0 \
577 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
578 .tf.histframe.pwclist add
$canv
579 set canv2 .tf.histframe.pwclist.canv2
581 -selectbackground $selectbgcolor \
582 -background $bgcolor -bd 0 -yscrollincr $linespc
583 .tf.histframe.pwclist add
$canv2
584 set canv3 .tf.histframe.pwclist.canv3
586 -selectbackground $selectbgcolor \
587 -background $bgcolor -bd 0 -yscrollincr $linespc
588 .tf.histframe.pwclist add
$canv3
589 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
590 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
592 # a scroll bar to rule them
593 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
594 pack
$cscroll -side right
-fill y
595 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
596 lappend bglist
$canv $canv2 $canv3
597 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
599 # we have two button bars at bottom of top frame. Bar 1
601 frame .tf.lbar
-height 15
603 set sha1entry .tf.bar.sha1
604 set entries
$sha1entry
605 set sha1but .tf.bar.sha1label
606 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
607 -command gotocommit
-width 8 -font $uifont
608 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
609 pack .tf.bar.sha1label
-side left
610 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
611 trace add variable sha1string
write sha1change
612 pack
$sha1entry -side left
-pady 2
614 image create bitmap bm-left
-data {
615 #define left_width 16
616 #define left_height 16
617 static unsigned char left_bits
[] = {
618 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
619 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
620 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
622 image create bitmap bm-right
-data {
623 #define right_width 16
624 #define right_height 16
625 static unsigned char right_bits
[] = {
626 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
627 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
628 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
630 button .tf.bar.leftbut
-image bm-left
-command goback \
631 -state disabled
-width 26
632 pack .tf.bar.leftbut
-side left
-fill y
633 button .tf.bar.rightbut
-image bm-right
-command goforw \
634 -state disabled
-width 26
635 pack .tf.bar.rightbut
-side left
-fill y
637 button .tf.bar.findbut
-text "Find" -command dofind
-font $uifont
638 pack .tf.bar.findbut
-side left
640 set fstring .tf.bar.findstring
641 lappend entries
$fstring
642 entry
$fstring -width 30 -font $textfont -textvariable findstring
643 trace add variable findstring
write find_change
644 pack
$fstring -side left
-expand 1 -fill x
-in .tf.bar
646 set findtypemenu
[tk_optionMenu .tf.bar.findtype \
647 findtype Exact IgnCase Regexp
]
648 trace add variable findtype
write find_change
649 .tf.bar.findtype configure
-font $uifont
650 .tf.bar.findtype.menu configure
-font $uifont
651 set findloc
"All fields"
652 tk_optionMenu .tf.bar.findloc findloc
"All fields" Headline \
653 Comments Author Committer
654 trace add variable findloc
write find_change
655 .tf.bar.findloc configure
-font $uifont
656 .tf.bar.findloc.menu configure
-font $uifont
657 pack .tf.bar.findloc
-side right
658 pack .tf.bar.findtype
-side right
660 # build up the bottom bar of upper window
661 label .tf.lbar.flabel
-text "Highlight: Commits " \
663 pack .tf.lbar.flabel
-side left
-fill y
664 set gdttype
"touching paths:"
665 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype
"touching paths:" \
666 "adding/removing string:"]
667 trace add variable gdttype
write hfiles_change
668 $gm conf
-font $uifont
669 .tf.lbar.gdttype conf
-font $uifont
670 pack .tf.lbar.gdttype
-side left
-fill y
671 entry .tf.lbar.fent
-width 25 -font $textfont \
672 -textvariable highlight_files
673 trace add variable highlight_files
write hfiles_change
674 lappend entries .tf.lbar.fent
675 pack .tf.lbar.fent
-side left
-fill x
-expand 1
676 label .tf.lbar.vlabel
-text " OR in view" -font $uifont
677 pack .tf.lbar.vlabel
-side left
-fill y
678 global viewhlmenu selectedhlview
679 set viewhlmenu
[tk_optionMenu .tf.lbar.vhl selectedhlview None
]
680 $viewhlmenu entryconf None
-command delvhighlight
681 $viewhlmenu conf
-font $uifont
682 .tf.lbar.vhl conf
-font $uifont
683 pack .tf.lbar.vhl
-side left
-fill y
684 label .tf.lbar.rlabel
-text " OR " -font $uifont
685 pack .tf.lbar.rlabel
-side left
-fill y
686 global highlight_related
687 set m
[tk_optionMenu .tf.lbar.relm highlight_related None \
688 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
689 $m conf
-font $uifont
690 .tf.lbar.relm conf
-font $uifont
691 trace add variable highlight_related
write vrel_change
692 pack .tf.lbar.relm
-side left
-fill y
694 # Finish putting the upper half of the viewer together
695 pack .tf.lbar
-in .tf
-side bottom
-fill x
696 pack .tf.bar
-in .tf
-side bottom
-fill x
697 pack .tf.histframe
-fill both
-side top
-expand 1
699 .ctop paneconfigure .tf
-height $geometry(topheight
)
700 .ctop paneconfigure .tf
-width $geometry(topwidth
)
702 # now build up the bottom
703 panedwindow .pwbottom
-orient horizontal
705 # lower left, a text box over search bar, scroll bar to the right
706 # if we know window height, then that will set the lower text height, otherwise
707 # we set lower text height which will drive window height
708 if {[info exists geometry
(main
)]} {
709 frame .bleft
-width $geometry(botwidth
)
711 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
716 button .bleft.top.search
-text "Search" -command dosearch \
718 pack .bleft.top.search
-side left
-padx 5
719 set sstring .bleft.top.sstring
720 entry
$sstring -width 20 -font $textfont -textvariable searchstring
721 lappend entries
$sstring
722 trace add variable searchstring
write incrsearch
723 pack
$sstring -side left
-expand 1 -fill x
724 radiobutton .bleft.mid.
diff -text "Diff" \
725 -command changediffdisp
-variable diffelide
-value {0 0}
726 radiobutton .bleft.mid.old
-text "Old version" \
727 -command changediffdisp
-variable diffelide
-value {0 1}
728 radiobutton .bleft.mid.new
-text "New version" \
729 -command changediffdisp
-variable diffelide
-value {1 0}
730 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
731 set ctext .bleft.ctext
732 text
$ctext -background $bgcolor -foreground $fgcolor \
733 -tabs "[expr {$tabstop * $charspc}]" \
734 -state disabled
-font $textfont \
735 -yscrollcommand scrolltext
-wrap none
736 scrollbar .bleft.sb
-command "$ctext yview"
737 pack .bleft.top
-side top
-fill x
738 pack .bleft.mid
-side top
-fill x
739 pack .bleft.sb
-side right
-fill y
740 pack
$ctext -side left
-fill both
-expand 1
741 lappend bglist
$ctext
742 lappend fglist
$ctext
744 $ctext tag conf comment
-wrap $wrapcomment
745 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
746 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
747 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
748 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
749 $ctext tag conf m0
-fore red
750 $ctext tag conf m1
-fore blue
751 $ctext tag conf m2
-fore green
752 $ctext tag conf m3
-fore purple
753 $ctext tag conf
m4 -fore brown
754 $ctext tag conf m5
-fore "#009090"
755 $ctext tag conf m6
-fore magenta
756 $ctext tag conf m7
-fore "#808000"
757 $ctext tag conf m8
-fore "#009000"
758 $ctext tag conf m9
-fore "#ff0080"
759 $ctext tag conf m10
-fore cyan
760 $ctext tag conf m11
-fore "#b07070"
761 $ctext tag conf m12
-fore "#70b0f0"
762 $ctext tag conf m13
-fore "#70f0b0"
763 $ctext tag conf m14
-fore "#f0b070"
764 $ctext tag conf m15
-fore "#ff70b0"
765 $ctext tag conf mmax
-fore darkgrey
767 $ctext tag conf mresult
-font [concat
$textfont bold
]
768 $ctext tag conf msep
-font [concat
$textfont bold
]
769 $ctext tag conf found
-back yellow
772 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
777 radiobutton .bright.mode.
patch -text "Patch" \
778 -command reselectline
-variable cmitmode
-value "patch"
779 .bright.mode.
patch configure
-font $uifont
780 radiobutton .bright.mode.tree
-text "Tree" \
781 -command reselectline
-variable cmitmode
-value "tree"
782 .bright.mode.tree configure
-font $uifont
783 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
784 pack .bright.mode
-side top
-fill x
785 set cflist .bright.cfiles
786 set indent
[font measure
$mainfont "nn"]
788 -selectbackground $selectbgcolor \
789 -background $bgcolor -foreground $fgcolor \
791 -tabs [list
$indent [expr {2 * $indent}]] \
792 -yscrollcommand ".bright.sb set" \
793 -cursor [. cget
-cursor] \
794 -spacing1 1 -spacing3 1
795 lappend bglist
$cflist
796 lappend fglist
$cflist
797 scrollbar .bright.sb
-command "$cflist yview"
798 pack .bright.sb
-side right
-fill y
799 pack
$cflist -side left
-fill both
-expand 1
800 $cflist tag configure highlight \
801 -background [$cflist cget
-selectbackground]
802 $cflist tag configure bold
-font [concat
$mainfont bold
]
804 .pwbottom add .bright
807 # restore window position if known
808 if {[info exists geometry
(main
)]} {
809 wm geometry .
"$geometry(main)"
812 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
813 pack .ctop
-fill both
-expand 1
814 bindall
<1> {selcanvline
%W
%x
%y
}
815 #bindall <B1-Motion> {selcanvline %W %x %y}
816 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
817 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
818 bindall
<2> "canvscan mark %W %x %y"
819 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
820 bindkey
<Home
> selfirstline
821 bindkey
<End
> sellastline
822 bind .
<Key-Up
> "selnextline -1"
823 bind .
<Key-Down
> "selnextline 1"
824 bind .
<Shift-Key-Up
> "next_highlight -1"
825 bind .
<Shift-Key-Down
> "next_highlight 1"
826 bindkey
<Key-Right
> "goforw"
827 bindkey
<Key-Left
> "goback"
828 bind .
<Key-Prior
> "selnextpage -1"
829 bind .
<Key-Next
> "selnextpage 1"
830 bind .
<Control-Home
> "allcanvs yview moveto 0.0"
831 bind .
<Control-End
> "allcanvs yview moveto 1.0"
832 bind .
<Control-Key-Up
> "allcanvs yview scroll -1 units"
833 bind .
<Control-Key-Down
> "allcanvs yview scroll 1 units"
834 bind .
<Control-Key-Prior
> "allcanvs yview scroll -1 pages"
835 bind .
<Control-Key-Next
> "allcanvs yview scroll 1 pages"
836 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
837 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
838 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
839 bindkey p
"selnextline -1"
840 bindkey n
"selnextline 1"
843 bindkey i
"selnextline -1"
844 bindkey k
"selnextline 1"
847 bindkey b
"$ctext yview scroll -1 pages"
848 bindkey d
"$ctext yview scroll 18 units"
849 bindkey u
"$ctext yview scroll -18 units"
850 bindkey
/ {findnext
1}
851 bindkey
<Key-Return
> {findnext
0}
854 bindkey
<F5
> updatecommits
855 bind .
<Control-q
> doquit
856 bind .
<Control-f
> dofind
857 bind .
<Control-g
> {findnext
0}
858 bind .
<Control-r
> dosearchback
859 bind .
<Control-s
> dosearch
860 bind .
<Control-equal
> {incrfont
1}
861 bind .
<Control-KP_Add
> {incrfont
1}
862 bind .
<Control-minus
> {incrfont
-1}
863 bind .
<Control-KP_Subtract
> {incrfont
-1}
864 wm protocol . WM_DELETE_WINDOW doquit
865 bind .
<Button-1
> "click %W"
866 bind $fstring <Key-Return
> dofind
867 bind $sha1entry <Key-Return
> gotocommit
868 bind $sha1entry <<PasteSelection>> clearsha1
869 bind $cflist <1> {sel_flist %W %x %y; break}
870 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
871 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
873 set maincursor [. cget -cursor]
874 set textcursor [$ctext cget -cursor]
875 set curtextcursor $textcursor
877 set rowctxmenu .rowctxmenu
878 menu $rowctxmenu -tearoff 0
879 $rowctxmenu add command -label "Diff this -> selected" \
880 -command {diffvssel 0}
881 $rowctxmenu add command -label "Diff selected -> this" \
882 -command {diffvssel 1}
883 $rowctxmenu add command -label "Make patch" -command mkpatch
884 $rowctxmenu add command -label "Create tag" -command mktag
885 $rowctxmenu add command -label "Write commit to file" -command writecommit
886 $rowctxmenu add command -label "Create new branch" -command mkbranch
887 $rowctxmenu add command -label "Cherry-pick this commit" \
889 $rowctxmenu add command -label "Reset HEAD branch to here" \
892 set fakerowmenu .fakerowmenu
893 menu $fakerowmenu -tearoff 0
894 $fakerowmenu add command -label "Diff this -> selected" \
895 -command {diffvssel 0}
896 $fakerowmenu add command -label "Diff selected -> this" \
897 -command {diffvssel 1}
898 $fakerowmenu add command -label "Make patch" -command mkpatch
899 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
900 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
901 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
903 set headctxmenu .headctxmenu
904 menu $headctxmenu -tearoff 0
905 $headctxmenu add command -label "Check out this branch" \
907 $headctxmenu add command -label "Remove this branch" \
911 # mouse-2 makes all windows scan vertically, but only the one
912 # the cursor is in scans horizontally
913 proc canvscan {op w x y} {
914 global canv canv2 canv3
915 foreach c [list $canv $canv2 $canv3] {
924 proc scrollcanv {cscroll f0 f1} {
930 # when we make a key binding for the toplevel, make sure
931 # it doesn't get triggered when that key is pressed in the
932 # find string entry widget.
933 proc bindkey {ev script} {
936 set escript [bind Entry $ev]
937 if {$escript == {}} {
938 set escript [bind Entry <Key>]
941 bind $e $ev "$escript; break"
945 # set the focus back to the toplevel for any click outside
956 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
957 global stuffsaved findmergefiles maxgraphpct
958 global maxwidth showneartags showlocalchanges
959 global viewname viewfiles viewargs viewperm nextviewnum
960 global cmitmode wrapcomment
961 global colors bgcolor fgcolor diffcolors selectbgcolor
963 if {$stuffsaved} return
964 if {![winfo viewable .]} return
966 set f [open "~/.gitk-new" w]
967 puts $f [list set mainfont $mainfont]
968 puts $f [list set textfont $textfont]
969 puts $f [list set uifont $uifont]
970 puts $f [list set tabstop $tabstop]
971 puts $f [list set findmergefiles $findmergefiles]
972 puts $f [list set maxgraphpct $maxgraphpct]
973 puts $f [list set maxwidth $maxwidth]
974 puts $f [list set cmitmode $cmitmode]
975 puts $f [list set wrapcomment $wrapcomment]
976 puts $f [list set showneartags $showneartags]
977 puts $f [list set showlocalchanges $showlocalchanges]
978 puts $f [list set bgcolor $bgcolor]
979 puts $f [list set fgcolor $fgcolor]
980 puts $f [list set colors $colors]
981 puts $f [list set diffcolors $diffcolors]
982 puts $f [list set selectbgcolor $selectbgcolor]
984 puts $f "set geometry(main) [wm geometry .]"
985 puts $f "set geometry(topwidth) [winfo width .tf]"
986 puts $f "set geometry(topheight) [winfo height .tf]"
987 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
988 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
989 puts $f "set geometry(botwidth) [winfo width .bleft]"
990 puts $f "set geometry(botheight) [winfo height .bleft]"
992 puts -nonewline $f "set permviews {"
993 for {set v 0} {$v < $nextviewnum} {incr v} {
995 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1000 file rename -force "~/.gitk-new" "~/.gitk"
1005 proc resizeclistpanes {win w} {
1007 if {[info exists oldwidth($win)]} {
1008 set s0 [$win sash coord 0]
1009 set s1 [$win sash coord 1]
1011 set sash0 [expr {int($w/2 - 2)}]
1012 set sash1 [expr {int($w*5/6 - 2)}]
1014 set factor [expr {1.0 * $w / $oldwidth($win)}]
1015 set sash0 [expr {int($factor * [lindex $s0 0])}]
1016 set sash1 [expr {int($factor * [lindex $s1 0])}]
1020 if {$sash1 < $sash0 + 20} {
1021 set sash1 [expr {$sash0 + 20}]
1023 if {$sash1 > $w - 10} {
1024 set sash1 [expr {$w - 10}]
1025 if {$sash0 > $sash1 - 20} {
1026 set sash0 [expr {$sash1 - 20}]
1030 $win sash place 0 $sash0 [lindex $s0 1]
1031 $win sash place 1 $sash1 [lindex $s1 1]
1033 set oldwidth($win) $w
1036 proc resizecdetpanes {win w} {
1038 if {[info exists oldwidth($win)]} {
1039 set s0 [$win sash coord 0]
1041 set sash0 [expr {int($w*3/4 - 2)}]
1043 set factor [expr {1.0 * $w / $oldwidth($win)}]
1044 set sash0 [expr {int($factor * [lindex $s0 0])}]
1048 if {$sash0 > $w - 15} {
1049 set sash0 [expr {$w - 15}]
1052 $win sash place 0 $sash0 [lindex $s0 1]
1054 set oldwidth($win) $w
1057 proc allcanvs args {
1058 global canv canv2 canv3
1064 proc bindall {event action} {
1065 global canv canv2 canv3
1066 bind $canv $event $action
1067 bind $canv2 $event $action
1068 bind $canv3 $event $action
1074 if {[winfo exists $w]} {
1079 wm title $w "About gitk"
1080 message $w.m -text {
1081 Gitk - a commit viewer for git
1083 Copyright © 2005-2006 Paul Mackerras
1085 Use and redistribute under the terms of the GNU General Public License} \
1086 -justify center -aspect 400 -border 2 -bg white -relief groove
1087 pack $w.m -side top -fill x -padx 2 -pady 2
1088 $w.m configure -font $uifont
1089 button $w.ok -text Close -command "destroy $w" -default active
1090 pack $w.ok -side bottom
1091 $w.ok configure -font $uifont
1092 bind $w <Visibility> "focus $w.ok"
1093 bind $w <Key-Escape> "destroy $w"
1094 bind $w <Key-Return> "destroy $w"
1100 if {[winfo exists $w]} {
1105 wm title $w "Gitk key bindings"
1106 message $w.m -text {
1110 <Home> Move to first commit
1111 <End> Move to last commit
1112 <Up>, p, i Move up one commit
1113 <Down>, n, k Move down one commit
1114 <Left>, z, j Go back in history list
1115 <Right>, x, l Go forward in history list
1116 <PageUp> Move up one page in commit list
1117 <PageDown> Move down one page in commit list
1118 <Ctrl-Home> Scroll to top of commit list
1119 <Ctrl-End> Scroll to bottom of commit list
1120 <Ctrl-Up> Scroll commit list up one line
1121 <Ctrl-Down> Scroll commit list down one line
1122 <Ctrl-PageUp> Scroll commit list up one page
1123 <Ctrl-PageDown> Scroll commit list down one page
1124 <Shift-Up> Move to previous highlighted line
1125 <Shift-Down> Move to next highlighted line
1126 <Delete>, b Scroll diff view up one page
1127 <Backspace> Scroll diff view up one page
1128 <Space> Scroll diff view down one page
1129 u Scroll diff view up 18 lines
1130 d Scroll diff view down 18 lines
1132 <Ctrl-G> Move to next find hit
1133 <Return> Move to next find hit
1134 / Move to next find hit, or redo find
1135 ? Move to previous find hit
1136 f Scroll diff view to next file
1137 <Ctrl-S> Search for next hit in diff view
1138 <Ctrl-R> Search for previous hit in diff view
1139 <Ctrl-KP+> Increase font size
1140 <Ctrl-plus> Increase font size
1141 <Ctrl-KP-> Decrease font size
1142 <Ctrl-minus> Decrease font size
1145 -justify left -bg white -border 2 -relief groove
1146 pack $w.m -side top -fill both -padx 2 -pady 2
1147 $w.m configure -font $uifont
1148 button $w.ok -text Close -command "destroy $w" -default active
1149 pack $w.ok -side bottom
1150 $w.ok configure -font $uifont
1151 bind $w <Visibility> "focus $w.ok"
1152 bind $w <Key-Escape> "destroy $w"
1153 bind $w <Key-Return> "destroy $w"
1156 # Procedures for manipulating the file list window at the
1157 # bottom right of the overall window.
1159 proc treeview {w l openlevs} {
1160 global treecontents treediropen treeheight treeparent treeindex
1170 set treecontents() {}
1171 $w conf -state normal
1173 while {[string range $f 0 $prefixend] ne $prefix} {
1174 if {$lev <= $openlevs} {
1175 $w mark set e:$treeindex($prefix) "end -1c"
1176 $w mark gravity e:$treeindex($prefix) left
1178 set treeheight($prefix) $ht
1179 incr ht [lindex $htstack end]
1180 set htstack [lreplace $htstack end end]
1181 set prefixend [lindex $prefendstack end]
1182 set prefendstack [lreplace $prefendstack end end]
1183 set prefix [string range $prefix 0 $prefixend]
1186 set tail [string range $f [expr {$prefixend+1}] end]
1187 while {[set slash [string first "/" $tail]] >= 0} {
1190 lappend prefendstack $prefixend
1191 incr prefixend [expr {$slash + 1}]
1192 set d [string range $tail 0 $slash]
1193 lappend treecontents($prefix) $d
1194 set oldprefix $prefix
1196 set treecontents($prefix) {}
1197 set treeindex($prefix) [incr ix]
1198 set treeparent($prefix) $oldprefix
1199 set tail [string range $tail [expr {$slash+1}] end]
1200 if {$lev <= $openlevs} {
1202 set treediropen($prefix) [expr {$lev < $openlevs}]
1203 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1204 $w mark set d:$ix "end -1c"
1205 $w mark gravity d:$ix left
1207 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1209 $w image create end -align center -image $bm -padx 1 \
1211 $w insert end $d [highlight_tag $prefix]
1212 $w mark set s:$ix "end -1c"
1213 $w mark gravity s:$ix left
1218 if {$lev <= $openlevs} {
1221 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1223 $w insert end $tail [highlight_tag $f]
1225 lappend treecontents($prefix) $tail
1228 while {$htstack ne {}} {
1229 set treeheight($prefix) $ht
1230 incr ht [lindex $htstack end]
1231 set htstack [lreplace $htstack end end]
1232 set prefixend [lindex $prefendstack end]
1233 set prefendstack [lreplace $prefendstack end end]
1234 set prefix [string range $prefix 0 $prefixend]
1236 $w conf -state disabled
1239 proc linetoelt {l} {
1240 global treeheight treecontents
1245 foreach e $treecontents($prefix) {
1250 if {[string index $e end] eq "/"} {
1251 set n $treeheight($prefix$e)
1263 proc highlight_tree {y prefix} {
1264 global treeheight treecontents cflist
1266 foreach e $treecontents($prefix) {
1268 if {[highlight_tag $path] ne {}} {
1269 $cflist tag add bold $y.0 "$y.0 lineend"
1272 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1273 set y [highlight_tree $y $path]
1279 proc treeclosedir {w dir} {
1280 global treediropen treeheight treeparent treeindex
1282 set ix $treeindex($dir)
1283 $w conf -state normal
1284 $w delete s:$ix e:$ix
1285 set treediropen($dir) 0
1286 $w image configure a:$ix -image tri-rt
1287 $w conf -state disabled
1288 set n [expr {1 - $treeheight($dir)}]
1289 while {$dir ne {}} {
1290 incr treeheight($dir) $n
1291 set dir $treeparent($dir)
1295 proc treeopendir {w dir} {
1296 global treediropen treeheight treeparent treecontents treeindex
1298 set ix $treeindex($dir)
1299 $w conf -state normal
1300 $w image configure a:$ix -image tri-dn
1301 $w mark set e:$ix s:$ix
1302 $w mark gravity e:$ix right
1305 set n [llength $treecontents($dir)]
1306 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1309 incr treeheight($x) $n
1311 foreach e $treecontents($dir) {
1313 if {[string index $e end] eq "/"} {
1314 set iy $treeindex($de)
1315 $w mark set d:$iy e:$ix
1316 $w mark gravity d:$iy left
1317 $w insert e:$ix $str
1318 set treediropen($de) 0
1319 $w image create e:$ix -align center -image tri-rt -padx 1 \
1321 $w insert e:$ix $e [highlight_tag $de]
1322 $w mark set s:$iy e:$ix
1323 $w mark gravity s:$iy left
1324 set treeheight($de) 1
1326 $w insert e:$ix $str
1327 $w insert e:$ix $e [highlight_tag $de]
1330 $w mark gravity e:$ix left
1331 $w conf -state disabled
1332 set treediropen($dir) 1
1333 set top [lindex [split [$w index @0,0] .] 0]
1334 set ht [$w cget -height]
1335 set l [lindex [split [$w index s:$ix] .] 0]
1338 } elseif {$l + $n + 1 > $top + $ht} {
1339 set top [expr {$l + $n + 2 - $ht}]
1347 proc treeclick {w x y} {
1348 global treediropen cmitmode ctext cflist cflist_top
1350 if {$cmitmode ne "tree"} return
1351 if {![info exists cflist_top]} return
1352 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1353 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1354 $cflist tag add highlight $l.0 "$l.0 lineend"
1360 set e [linetoelt $l]
1361 if {[string index $e end] ne "/"} {
1363 } elseif {$treediropen($e)} {
1370 proc setfilelist {id} {
1371 global treefilelist cflist
1373 treeview $cflist $treefilelist($id) 0
1376 image create bitmap tri-rt -background black -foreground blue -data {
1377 #define tri-rt_width 13
1378 #define tri-rt_height 13
1379 static unsigned char tri-rt_bits[] = {
1380 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1381 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1384 #define tri-rt-mask_width 13
1385 #define tri-rt-mask_height 13
1386 static unsigned char tri-rt-mask_bits[] = {
1387 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1388 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1391 image create bitmap tri-dn -background black -foreground blue -data {
1392 #define tri-dn_width 13
1393 #define tri-dn_height 13
1394 static unsigned char tri-dn_bits[] = {
1395 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1396 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1399 #define tri-dn-mask_width 13
1400 #define tri-dn-mask_height 13
1401 static unsigned char tri-dn-mask_bits[] = {
1402 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1403 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1407 proc init_flist {first} {
1408 global cflist cflist_top selectedline difffilestart
1410 $cflist conf -state normal
1411 $cflist delete 0.0 end
1413 $cflist insert end $first
1415 $cflist tag add highlight 1.0 "1.0 lineend"
1417 catch {unset cflist_top}
1419 $cflist conf -state disabled
1420 set difffilestart {}
1423 proc highlight_tag {f} {
1424 global highlight_paths
1426 foreach p $highlight_paths {
1427 if {[string match $p $f]} {
1434 proc highlight_filelist {} {
1435 global cmitmode cflist
1437 $cflist conf -state normal
1438 if {$cmitmode ne "tree"} {
1439 set end [lindex [split [$cflist index end] .] 0]
1440 for {set l 2} {$l < $end} {incr l} {
1441 set line [$cflist get $l.0 "$l.0 lineend"]
1442 if {[highlight_tag $line] ne {}} {
1443 $cflist tag add bold $l.0 "$l.0 lineend"
1449 $cflist conf -state disabled
1452 proc unhighlight_filelist {} {
1455 $cflist conf -state normal
1456 $cflist tag remove bold 1.0 end
1457 $cflist conf -state disabled
1460 proc add_flist {fl} {
1463 $cflist conf -state normal
1465 $cflist insert end "\n"
1466 $cflist insert end $f [highlight_tag $f]
1468 $cflist conf -state disabled
1471 proc sel_flist {w x y} {
1472 global ctext difffilestart cflist cflist_top cmitmode
1474 if {$cmitmode eq "tree"} return
1475 if {![info exists cflist_top]} return
1476 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1477 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1478 $cflist tag add highlight $l.0 "$l.0 lineend"
1483 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1487 # Functions for adding and removing shell-type quoting
1489 proc shellquote {str} {
1490 if {![string match "*\['\"\\ \t]*" $str]} {
1493 if {![string match "*\['\"\\]*" $str]} {
1496 if {![string match "*'*" $str]} {
1499 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1502 proc shellarglist {l} {
1508 append str [shellquote $a]
1513 proc shelldequote {str} {
1518 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1519 append ret [string range $str $used end]
1520 set used [string length $str]
1523 set first [lindex $first 0]
1524 set ch [string index $str $first]
1525 if {$first > $used} {
1526 append ret [string range $str $used [expr {$first - 1}]]
1529 if {$ch eq " " || $ch eq "\t"} break
1532 set first [string first "'" $str $used]
1534 error "unmatched single-quote"
1536 append ret [string range $str $used [expr {$first - 1}]]
1541 if {$used >= [string length $str]} {
1542 error "trailing backslash"
1544 append ret [string index $str $used]
1549 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1550 error "unmatched double-quote"
1552 set first [lindex $first 0]
1553 set ch [string index $str $first]
1554 if {$first > $used} {
1555 append ret [string range $str $used [expr {$first - 1}]]
1558 if {$ch eq "\""} break
1560 append ret [string index $str $used]
1564 return [list $used $ret]
1567 proc shellsplit {str} {
1570 set str [string trimleft $str]
1571 if {$str eq {}} break
1572 set dq [shelldequote $str]
1573 set n [lindex $dq 0]
1574 set word [lindex $dq 1]
1575 set str [string range $str $n end]
1581 # Code to implement multiple views
1583 proc newview {ishighlight} {
1584 global nextviewnum newviewname newviewperm uifont newishighlight
1585 global newviewargs revtreeargs
1587 set newishighlight $ishighlight
1589 if {[winfo exists $top]} {
1593 set newviewname($nextviewnum) "View $nextviewnum"
1594 set newviewperm($nextviewnum) 0
1595 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1596 vieweditor $top $nextviewnum "Gitk view definition"
1601 global viewname viewperm newviewname newviewperm
1602 global viewargs newviewargs
1604 set top .gitkvedit-$curview
1605 if {[winfo exists $top]} {
1609 set newviewname($curview) $viewname($curview)
1610 set newviewperm($curview) $viewperm($curview)
1611 set newviewargs($curview) [shellarglist $viewargs($curview)]
1612 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1615 proc vieweditor {top n title} {
1616 global newviewname newviewperm viewfiles
1620 wm title $top $title
1621 label $top.nl -text "Name" -font $uifont
1622 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1623 grid $top.nl $top.name -sticky w -pady 5
1624 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1626 grid $top.perm - -pady 5 -sticky w
1627 message $top.al -aspect 1000 -font $uifont \
1628 -text "Commits to include (arguments to git rev-list):"
1629 grid $top.al - -sticky w -pady 5
1630 entry $top.args -width 50 -textvariable newviewargs($n) \
1631 -background white -font $uifont
1632 grid $top.args - -sticky ew -padx 5
1633 message $top.l -aspect 1000 -font $uifont \
1634 -text "Enter files and directories to include, one per line:"
1635 grid $top.l - -sticky w
1636 text $top.t -width 40 -height 10 -background white -font $uifont
1637 if {[info exists viewfiles($n)]} {
1638 foreach f $viewfiles($n) {
1639 $top.t insert end $f
1640 $top.t insert end "\n"
1642 $top.t delete {end - 1c} end
1643 $top.t mark set insert 0.0
1645 grid $top.t - -sticky ew -padx 5
1647 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1649 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1651 grid $top.buts.ok $top.buts.can
1652 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1653 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1654 grid $top.buts - -pady 10 -sticky ew
1658 proc doviewmenu {m first cmd op argv} {
1659 set nmenu [$m index end]
1660 for {set i $first} {$i <= $nmenu} {incr i} {
1661 if {[$m entrycget $i -command] eq $cmd} {
1662 eval $m $op $i $argv
1668 proc allviewmenus {n op args} {
1671 doviewmenu .bar.view 5 [list showview $n] $op $args
1672 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1675 proc newviewok {top n} {
1676 global nextviewnum newviewperm newviewname newishighlight
1677 global viewname viewfiles viewperm selectedview curview
1678 global viewargs newviewargs viewhlmenu
1681 set newargs [shellsplit $newviewargs($n)]
1683 error_popup "Error in commit selection arguments: $err"
1689 foreach f [split [$top.t get 0.0 end] "\n"] {
1690 set ft [string trim $f]
1695 if {![info exists viewfiles($n)]} {
1696 # creating a new view
1698 set viewname($n) $newviewname($n)
1699 set viewperm($n) $newviewperm($n)
1700 set viewfiles($n) $files
1701 set viewargs($n) $newargs
1703 if {!$newishighlight} {
1706 run addvhighlight $n
1709 # editing an existing view
1710 set viewperm($n) $newviewperm($n)
1711 if {$newviewname($n) ne $viewname($n)} {
1712 set viewname($n) $newviewname($n)
1713 doviewmenu .bar.view 5 [list showview $n] \
1714 entryconf [list -label $viewname($n)]
1715 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1716 entryconf [list -label $viewname($n) -value $viewname($n)]
1718 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1719 set viewfiles($n) $files
1720 set viewargs($n) $newargs
1721 if {$curview == $n} {
1726 catch {destroy $top}
1730 global curview viewdata viewperm hlview selectedhlview
1732 if {$curview == 0} return
1733 if {[info exists hlview] && $hlview == $curview} {
1734 set selectedhlview None
1737 allviewmenus $curview delete
1738 set viewdata($curview) {}
1739 set viewperm($curview) 0
1743 proc addviewmenu {n} {
1744 global viewname viewhlmenu
1746 .bar.view add radiobutton -label $viewname($n) \
1747 -command [list showview $n] -variable selectedview -value $n
1748 $viewhlmenu add radiobutton -label $viewname($n) \
1749 -command [list addvhighlight $n] -variable selectedhlview
1752 proc flatten {var} {
1756 foreach i [array names $var] {
1757 lappend ret $i [set $var\($i\)]
1762 proc unflatten {var l} {
1772 global curview viewdata viewfiles
1773 global displayorder parentlist rowidlist rowoffsets
1774 global colormap rowtextx commitrow nextcolor canvxmax
1775 global numcommits rowrangelist commitlisted idrowranges rowchk
1776 global selectedline currentid canv canvy0
1778 global pending_select phase
1779 global commitidx rowlaidout rowoptim
1781 global selectedview selectfirst
1782 global vparentlist vdisporder vcmitlisted
1783 global hlview selectedhlview
1785 if {$n == $curview} return
1787 if {[info exists selectedline]} {
1788 set selid $currentid
1789 set y [yc $selectedline]
1790 set ymax [lindex [$canv cget -scrollregion] 3]
1791 set span [$canv yview]
1792 set ytop [expr {[lindex $span 0] * $ymax}]
1793 set ybot [expr {[lindex $span 1] * $ymax}]
1794 if {$ytop < $y && $y < $ybot} {
1795 set yscreen [expr {$y - $ytop}]
1797 set yscreen [expr {($ybot - $ytop) / 2}]
1799 } elseif {[info exists pending_select]} {
1800 set selid $pending_select
1801 unset pending_select
1805 if {$curview >= 0} {
1806 set vparentlist($curview) $parentlist
1807 set vdisporder($curview) $displayorder
1808 set vcmitlisted($curview) $commitlisted
1810 set viewdata($curview) \
1811 [list $phase $rowidlist $rowoffsets $rowrangelist \
1812 [flatten idrowranges] [flatten idinlist] \
1813 $rowlaidout $rowoptim $numcommits]
1814 } elseif {![info exists viewdata($curview)]
1815 || [lindex $viewdata($curview) 0] ne {}} {
1816 set viewdata($curview) \
1817 [list {} $rowidlist $rowoffsets $rowrangelist]
1820 catch {unset treediffs}
1822 if {[info exists hlview] && $hlview == $n} {
1824 set selectedhlview None
1829 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1830 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1832 if {![info exists viewdata($n)]} {
1834 set pending_select $selid
1841 set phase [lindex $v 0]
1842 set displayorder $vdisporder($n)
1843 set parentlist $vparentlist($n)
1844 set commitlisted $vcmitlisted($n)
1845 set rowidlist [lindex $v 1]
1846 set rowoffsets [lindex $v 2]
1847 set rowrangelist [lindex $v 3]
1849 set numcommits [llength $displayorder]
1850 catch {unset idrowranges}
1852 unflatten idrowranges [lindex $v 4]
1853 unflatten idinlist [lindex $v 5]
1854 set rowlaidout [lindex $v 6]
1855 set rowoptim [lindex $v 7]
1856 set numcommits [lindex $v 8]
1857 catch {unset rowchk}
1860 catch {unset colormap}
1861 catch {unset rowtextx}
1863 set canvxmax [$canv cget -width]
1870 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1871 set row $commitrow($n,$selid)
1872 # try to get the selected row in the same position on the screen
1873 set ymax [lindex [$canv cget -scrollregion] 3]
1874 set ytop [expr {[yc $row] - $yscreen}]
1878 set yf [expr {$ytop * 1.0 / $ymax}]
1880 allcanvs yview moveto $yf
1884 } elseif {$selid ne {}} {
1885 set pending_select $selid
1887 set row [first_real_row]
1888 if {$row < $numcommits} {
1895 if {$phase eq "getcommits"} {
1896 show_status "Reading commits..."
1899 } elseif {$numcommits == 0} {
1900 show_status "No commits selected"
1904 # Stuff relating to the highlighting facility
1906 proc ishighlighted {row} {
1907 global vhighlights fhighlights nhighlights rhighlights
1909 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1910 return $nhighlights($row)
1912 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1913 return $vhighlights($row)
1915 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1916 return $fhighlights($row)
1918 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1919 return $rhighlights($row)
1924 proc bolden {row font} {
1925 global canv linehtag selectedline boldrows
1927 lappend boldrows $row
1928 $canv itemconf $linehtag($row) -font $font
1929 if {[info exists selectedline] && $row == $selectedline} {
1931 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1932 -outline {{}} -tags secsel \
1933 -fill [$canv cget -selectbackground]]
1938 proc bolden_name {row font} {
1939 global canv2 linentag selectedline boldnamerows
1941 lappend boldnamerows $row
1942 $canv2 itemconf $linentag($row) -font $font
1943 if {[info exists selectedline] && $row == $selectedline} {
1944 $canv2 delete secsel
1945 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1946 -outline {{}} -tags secsel \
1947 -fill [$canv2 cget -selectbackground]]
1953 global mainfont boldrows
1956 foreach row $boldrows {
1957 if {![ishighlighted $row]} {
1958 bolden $row $mainfont
1960 lappend stillbold $row
1963 set boldrows $stillbold
1966 proc addvhighlight {n} {
1967 global hlview curview viewdata vhl_done vhighlights commitidx
1969 if {[info exists hlview]} {
1973 if {$n != $curview && ![info exists viewdata($n)]} {
1974 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1975 set vparentlist($n) {}
1976 set vdisporder($n) {}
1977 set vcmitlisted($n) {}
1980 set vhl_done $commitidx($hlview)
1981 if {$vhl_done > 0} {
1986 proc delvhighlight {} {
1987 global hlview vhighlights
1989 if {![info exists hlview]} return
1991 catch {unset vhighlights}
1995 proc vhighlightmore {} {
1996 global hlview vhl_done commitidx vhighlights
1997 global displayorder vdisporder curview mainfont
1999 set font [concat $mainfont bold]
2000 set max $commitidx($hlview)
2001 if {$hlview == $curview} {
2002 set disp $displayorder
2004 set disp $vdisporder($hlview)
2006 set vr [visiblerows]
2007 set r0 [lindex $vr 0]
2008 set r1 [lindex $vr 1]
2009 for {set i $vhl_done} {$i < $max} {incr i} {
2010 set id [lindex $disp $i]
2011 if {[info exists commitrow($curview,$id)]} {
2012 set row $commitrow($curview,$id)
2013 if {$r0 <= $row && $row <= $r1} {
2014 if {![highlighted $row]} {
2017 set vhighlights($row) 1
2024 proc askvhighlight {row id} {
2025 global hlview vhighlights commitrow iddrawn mainfont
2027 if {[info exists commitrow($hlview,$id)]} {
2028 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2029 bolden $row [concat $mainfont bold]
2031 set vhighlights($row) 1
2033 set vhighlights($row) 0
2037 proc hfiles_change {name ix op} {
2038 global highlight_files filehighlight fhighlights fh_serial
2039 global mainfont highlight_paths
2041 if {[info exists filehighlight]} {
2042 # delete previous highlights
2043 catch {close $filehighlight}
2045 catch {unset fhighlights}
2047 unhighlight_filelist
2049 set highlight_paths {}
2050 after cancel do_file_hl $fh_serial
2052 if {$highlight_files ne {}} {
2053 after 300 do_file_hl $fh_serial
2057 proc makepatterns {l} {
2060 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2061 if {[string index $ee end] eq "/"} {
2071 proc do_file_hl {serial} {
2072 global highlight_files filehighlight highlight_paths gdttype fhl_list
2074 if {$gdttype eq "touching paths:"} {
2075 if {[catch {set paths [shellsplit $highlight_files]}]} return
2076 set highlight_paths [makepatterns $paths]
2078 set gdtargs [concat -- $paths]
2080 set gdtargs [list "-S$highlight_files"]
2082 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2083 set filehighlight [open $cmd r+]
2084 fconfigure $filehighlight -blocking 0
2085 filerun $filehighlight readfhighlight
2091 proc flushhighlights {} {
2092 global filehighlight fhl_list
2094 if {[info exists filehighlight]} {
2096 puts $filehighlight ""
2097 flush $filehighlight
2101 proc askfilehighlight {row id} {
2102 global filehighlight fhighlights fhl_list
2104 lappend fhl_list $id
2105 set fhighlights($row) -1
2106 puts $filehighlight $id
2109 proc readfhighlight {} {
2110 global filehighlight fhighlights commitrow curview mainfont iddrawn
2113 if {![info exists filehighlight]} {
2117 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2118 set line [string trim $line]
2119 set i [lsearch -exact $fhl_list $line]
2120 if {$i < 0} continue
2121 for {set j 0} {$j < $i} {incr j} {
2122 set id [lindex $fhl_list $j]
2123 if {[info exists commitrow($curview,$id)]} {
2124 set fhighlights($commitrow($curview,$id)) 0
2127 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2128 if {$line eq {}} continue
2129 if {![info exists commitrow($curview,$line)]} continue
2130 set row $commitrow($curview,$line)
2131 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2132 bolden $row [concat $mainfont bold]
2134 set fhighlights($row) 1
2136 if {[eof $filehighlight]} {
2138 puts "oops, git diff-tree died"
2139 catch {close $filehighlight}
2147 proc find_change {name ix op} {
2148 global nhighlights mainfont boldnamerows
2149 global findstring findpattern findtype markingmatches
2151 # delete previous highlights, if any
2152 foreach row $boldnamerows {
2153 bolden_name $row $mainfont
2156 catch {unset nhighlights}
2159 if {$findtype ne "Regexp"} {
2160 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2162 set findpattern "*$e*"
2164 set markingmatches [expr {$findstring ne {}}]
2168 proc doesmatch {f} {
2169 global findtype findstring findpattern
2171 if {$findtype eq "Regexp"} {
2172 return [regexp $findstring $f]
2173 } elseif {$findtype eq "IgnCase"} {
2174 return [string match -nocase $findpattern $f]
2176 return [string match $findpattern $f]
2180 proc askfindhighlight {row id} {
2181 global nhighlights commitinfo iddrawn mainfont
2183 global markingmatches
2185 if {![info exists commitinfo($id)]} {
2188 set info $commitinfo($id)
2190 set fldtypes {Headline Author Date Committer CDate Comments}
2191 foreach f $info ty $fldtypes {
2192 if {($findloc eq "All fields" || $findloc eq $ty) &&
2194 if {$ty eq "Author"} {
2201 if {$isbold && [info exists iddrawn($id)]} {
2202 set f [concat $mainfont bold]
2203 if {![ishighlighted $row]} {
2209 if {$markingmatches} {
2210 markrowmatches $row [lindex $info 0] [lindex $info 1]
2213 set nhighlights($row) $isbold
2216 proc markrowmatches {row headline author} {
2217 global canv canv2 linehtag linentag
2219 $canv delete match$row
2220 $canv2 delete match$row
2221 set m [findmatches $headline]
2223 markmatches $canv $row $headline $linehtag($row) $m \
2224 [$canv itemcget $linehtag($row) -font]
2226 set m [findmatches $author]
2228 markmatches $canv2 $row $author $linentag($row) $m \
2229 [$canv2 itemcget $linentag($row) -font]
2233 proc vrel_change {name ix op} {
2234 global highlight_related
2237 if {$highlight_related ne "None"} {
2242 # prepare for testing whether commits are descendents or ancestors of a
2243 proc rhighlight_sel {a} {
2244 global descendent desc_todo ancestor anc_todo
2245 global highlight_related rhighlights
2247 catch {unset descendent}
2248 set desc_todo [list $a]
2249 catch {unset ancestor}
2250 set anc_todo [list $a]
2251 if {$highlight_related ne "None"} {
2257 proc rhighlight_none {} {
2260 catch {unset rhighlights}
2264 proc is_descendent {a} {
2265 global curview children commitrow descendent desc_todo
2268 set la $commitrow($v,$a)
2272 for {set i 0} {$i < [llength $todo]} {incr i} {
2273 set do [lindex $todo $i]
2274 if {$commitrow($v,$do) < $la} {
2275 lappend leftover $do
2278 foreach nk $children($v,$do) {
2279 if {![info exists descendent($nk)]} {
2280 set descendent($nk) 1
2288 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2292 set descendent($a) 0
2293 set desc_todo $leftover
2296 proc is_ancestor {a} {
2297 global curview parentlist commitrow ancestor anc_todo
2300 set la $commitrow($v,$a)
2304 for {set i 0} {$i < [llength $todo]} {incr i} {
2305 set do [lindex $todo $i]
2306 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2307 lappend leftover $do
2310 foreach np [lindex $parentlist $commitrow($v,$do)] {
2311 if {![info exists ancestor($np)]} {
2320 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2325 set anc_todo $leftover
2328 proc askrelhighlight {row id} {
2329 global descendent highlight_related iddrawn mainfont rhighlights
2330 global selectedline ancestor
2332 if {![info exists selectedline]} return
2334 if {$highlight_related eq "Descendent" ||
2335 $highlight_related eq "Not descendent"} {
2336 if {![info exists descendent($id)]} {
2339 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2342 } elseif {$highlight_related eq "Ancestor" ||
2343 $highlight_related eq "Not ancestor"} {
2344 if {![info exists ancestor($id)]} {
2347 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2351 if {[info exists iddrawn($id)]} {
2352 if {$isbold && ![ishighlighted $row]} {
2353 bolden $row [concat $mainfont bold]
2356 set rhighlights($row) $isbold
2359 proc next_hlcont {} {
2360 global fhl_row fhl_dirn displayorder numcommits
2361 global vhighlights fhighlights nhighlights rhighlights
2362 global hlview filehighlight findstring highlight_related
2364 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2367 if {$row < 0 || $row >= $numcommits} {
2372 set id [lindex $displayorder $row]
2373 if {[info exists hlview]} {
2374 if {![info exists vhighlights($row)]} {
2375 askvhighlight $row $id
2377 if {$vhighlights($row) > 0} break
2379 if {$findstring ne {}} {
2380 if {![info exists nhighlights($row)]} {
2381 askfindhighlight $row $id
2383 if {$nhighlights($row) > 0} break
2385 if {$highlight_related ne "None"} {
2386 if {![info exists rhighlights($row)]} {
2387 askrelhighlight $row $id
2389 if {$rhighlights($row) > 0} break
2391 if {[info exists filehighlight]} {
2392 if {![info exists fhighlights($row)]} {
2393 # ask for a few more while we're at it...
2395 for {set n 0} {$n < 100} {incr n} {
2396 if {![info exists fhighlights($r)]} {
2397 askfilehighlight $r [lindex $displayorder $r]
2400 if {$r < 0 || $r >= $numcommits} break
2404 if {$fhighlights($row) < 0} {
2408 if {$fhighlights($row) > 0} break
2416 proc next_highlight {dirn} {
2417 global selectedline fhl_row fhl_dirn
2418 global hlview filehighlight findstring highlight_related
2420 if {![info exists selectedline]} return
2421 if {!([info exists hlview] || $findstring ne {} ||
2422 $highlight_related ne "None" || [info exists filehighlight])} return
2423 set fhl_row [expr {$selectedline + $dirn}]
2428 proc cancel_next_highlight {} {
2434 # Graph layout functions
2436 proc shortids {ids} {
2439 if {[llength $id] > 1} {
2440 lappend res [shortids $id]
2441 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2442 lappend res [string range $id 0 7]
2450 proc incrange {l x o} {
2453 set e [lindex $l $x]
2455 lset l $x [expr {$e + $o}]
2464 for {} {$n > 0} {incr n -1} {
2470 proc usedinrange {id l1 l2} {
2471 global children commitrow curview
2473 if {[info exists commitrow($curview,$id)]} {
2474 set r $commitrow($curview,$id)
2475 if {$l1 <= $r && $r <= $l2} {
2476 return [expr {$r - $l1 + 1}]
2479 set kids $children($curview,$id)
2481 set r $commitrow($curview,$c)
2482 if {$l1 <= $r && $r <= $l2} {
2483 return [expr {$r - $l1 + 1}]
2489 proc sanity {row {full 0}} {
2490 global rowidlist rowoffsets
2493 set ids [lindex $rowidlist $row]
2496 if {$id eq {}} continue
2497 if {$col < [llength $ids] - 1 &&
2498 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2499 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2501 set o [lindex $rowoffsets $row $col]
2507 if {[lindex $rowidlist $y $x] != $id} {
2508 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2509 puts " id=[shortids $id] check started at row $row"
2510 for {set i $row} {$i >= $y} {incr i -1} {
2511 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2516 set o [lindex $rowoffsets $y $x]
2521 proc makeuparrow {oid x y z} {
2522 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2524 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2527 set off0 [lindex $rowoffsets $y]
2528 for {set x0 $x} {1} {incr x0} {
2529 if {$x0 >= [llength $off0]} {
2530 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2533 set z [lindex $off0 $x0]
2539 set z [expr {$x0 - $x}]
2540 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2541 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2543 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2544 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2545 lappend idrowranges($oid) [lindex $displayorder $y]
2548 proc initlayout {} {
2549 global rowidlist rowoffsets displayorder commitlisted
2550 global rowlaidout rowoptim
2551 global idinlist rowchk rowrangelist idrowranges
2552 global numcommits canvxmax canv
2555 global colormap rowtextx
2566 catch {unset idinlist}
2567 catch {unset rowchk}
2570 set canvxmax [$canv cget -width]
2571 catch {unset colormap}
2572 catch {unset rowtextx}
2573 catch {unset idrowranges}
2577 proc setcanvscroll {} {
2578 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2580 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2581 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2582 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2583 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2586 proc visiblerows {} {
2587 global canv numcommits linespc
2589 set ymax [lindex [$canv cget -scrollregion] 3]
2590 if {$ymax eq {} || $ymax == 0} return
2592 set y0 [expr {int([lindex $f 0] * $ymax)}]
2593 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2597 set y1 [expr {int([lindex $f 1] * $ymax)}]
2598 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2599 if {$r1 >= $numcommits} {
2600 set r1 [expr {$numcommits - 1}]
2602 return [list $r0 $r1]
2605 proc layoutmore {tmax allread} {
2606 global rowlaidout rowoptim commitidx numcommits optim_delay
2607 global uparrowlen curview rowidlist idinlist
2610 set showdelay $optim_delay
2611 set optdelay [expr {$uparrowlen + 1}]
2613 if {$rowoptim - $showdelay > $numcommits} {
2614 showstuff [expr {$rowoptim - $showdelay}] $showlast
2615 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2616 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2620 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2622 } elseif {$commitidx($curview) > $rowlaidout} {
2623 set nr [expr {$commitidx($curview) - $rowlaidout}]
2624 # may need to increase this threshold if uparrowlen or
2625 # mingaplen are increased...
2630 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2631 if {$rowlaidout == $row} {
2634 } elseif {$allread} {
2636 set nrows $commitidx($curview)
2637 if {[lindex $rowidlist $nrows] ne {} ||
2638 [array names idinlist] ne {}} {
2640 set rowlaidout $commitidx($curview)
2641 } elseif {$rowoptim == $nrows} {
2644 if {$numcommits == $nrows} {
2651 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2657 proc showstuff {canshow last} {
2658 global numcommits commitrow pending_select selectedline curview
2659 global lookingforhead mainheadid displayorder selectfirst
2660 global lastscrollset
2662 if {$numcommits == 0} {
2664 set phase "incrdraw"
2668 set prev $numcommits
2669 set numcommits $canshow
2670 set t [clock clicks -milliseconds]
2671 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2672 set lastscrollset $t
2675 set rows [visiblerows]
2676 set r1 [lindex $rows 1]
2677 if {$r1 >= $canshow} {
2678 set r1 [expr {$canshow - 1}]
2683 if {[info exists pending_select] &&
2684 [info exists commitrow($curview,$pending_select)] &&
2685 $commitrow($curview,$pending_select) < $numcommits} {
2686 selectline $commitrow($curview,$pending_select) 1
2689 if {[info exists selectedline] || [info exists pending_select]} {
2692 set l [first_real_row]
2697 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2698 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2699 set lookingforhead 0
2704 proc doshowlocalchanges {} {
2705 global lookingforhead curview mainheadid phase commitrow
2707 if {[info exists commitrow($curview,$mainheadid)] &&
2708 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2710 } elseif {$phase ne {}} {
2711 set lookingforhead 1
2715 proc dohidelocalchanges {} {
2716 global lookingforhead localfrow localirow lserial
2718 set lookingforhead 0
2719 if {$localfrow >= 0} {
2720 removerow $localfrow
2722 if {$localirow > 0} {
2726 if {$localirow >= 0} {
2727 removerow $localirow
2733 # spawn off a process to do git diff-index --cached HEAD
2734 proc dodiffindex {} {
2735 global localirow localfrow lserial
2740 set fd [open "|git diff-index --cached HEAD" r]
2741 fconfigure $fd -blocking 0
2742 filerun $fd [list readdiffindex $fd $lserial]
2745 proc readdiffindex {fd serial} {
2746 global localirow commitrow mainheadid nullid2 curview
2747 global commitinfo commitdata lserial
2750 if {[gets $fd line] < 0} {
2756 # we only need to see one line and we don't really care what it says...
2759 # now see if there are any local changes not checked in to the index
2760 if {$serial == $lserial} {
2761 set fd [open "|git diff-files" r]
2762 fconfigure $fd -blocking 0
2763 filerun $fd [list readdifffiles $fd $serial]
2766 if {$isdiff && $serial == $lserial && $localirow == -1} {
2767 # add the line for the changes in the index to the graph
2768 set localirow $commitrow($curview,$mainheadid)
2769 set hl "Local changes checked in to index but not committed"
2770 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2771 set commitdata($nullid2) "\n $hl\n"
2772 insertrow $localirow $nullid2
2777 proc readdifffiles {fd serial} {
2778 global localirow localfrow commitrow mainheadid nullid curview
2779 global commitinfo commitdata lserial
2782 if {[gets $fd line] < 0} {
2788 # we only need to see one line and we don't really care what it says...
2791 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2792 # add the line for the local diff to the graph
2793 if {$localirow >= 0} {
2794 set localfrow $localirow
2797 set localfrow $commitrow($curview,$mainheadid)
2799 set hl "Local uncommitted changes, not checked in to index"
2800 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2801 set commitdata($nullid) "\n $hl\n"
2802 insertrow $localfrow $nullid
2807 proc layoutrows {row endrow last} {
2808 global rowidlist rowoffsets displayorder
2809 global uparrowlen downarrowlen maxwidth mingaplen
2810 global children parentlist
2812 global commitidx curview
2813 global idinlist rowchk rowrangelist
2815 set idlist [lindex $rowidlist $row]
2816 set offs [lindex $rowoffsets $row]
2817 while {$row < $endrow} {
2818 set id [lindex $displayorder $row]
2821 foreach p [lindex $parentlist $row] {
2822 if {![info exists idinlist($p)]} {
2824 } elseif {!$idinlist($p)} {
2828 set nev [expr {[llength $idlist] + [llength $newolds]
2829 + [llength $oldolds] - $maxwidth + 1}]
2832 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2833 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2834 set i [lindex $idlist $x]
2835 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2836 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2837 [expr {$row + $uparrowlen + $mingaplen}]]
2839 set idlist [lreplace $idlist $x $x]
2840 set offs [lreplace $offs $x $x]
2841 set offs [incrange $offs $x 1]
2843 set rm1 [expr {$row - 1}]
2844 lappend idrowranges($i) [lindex $displayorder $rm1]
2845 if {[incr nev -1] <= 0} break
2848 set rowchk($id) [expr {$row + $r}]
2851 lset rowidlist $row $idlist
2852 lset rowoffsets $row $offs
2854 set col [lsearch -exact $idlist $id]
2856 set col [llength $idlist]
2858 lset rowidlist $row $idlist
2860 if {$children($curview,$id) ne {}} {
2861 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2865 lset rowoffsets $row $offs
2867 makeuparrow $id $col $row $z
2873 if {[info exists idrowranges($id)]} {
2874 set ranges $idrowranges($id)
2876 unset idrowranges($id)
2878 lappend rowrangelist $ranges
2880 set offs [ntimes [llength $idlist] 0]
2881 set l [llength $newolds]
2882 set idlist [eval lreplace \$idlist $col $col $newolds]
2885 set offs [lrange $offs 0 [expr {$col - 1}]]
2886 foreach x $newolds {
2891 set tmp [expr {[llength $idlist] - [llength $offs]}]
2893 set offs [concat $offs [ntimes $tmp $o]]
2898 foreach i $newolds {
2900 set idrowranges($i) $id
2903 foreach oid $oldolds {
2904 set idinlist($oid) 1
2905 set idlist [linsert $idlist $col $oid]
2906 set offs [linsert $offs $col $o]
2907 makeuparrow $oid $col $row $o
2910 lappend rowidlist $idlist
2911 lappend rowoffsets $offs
2916 proc addextraid {id row} {
2917 global displayorder commitrow commitinfo
2918 global commitidx commitlisted
2919 global parentlist children curview
2921 incr commitidx($curview)
2922 lappend displayorder $id
2923 lappend commitlisted 0
2924 lappend parentlist {}
2925 set commitrow($curview,$id) $row
2927 if {![info exists commitinfo($id)]} {
2928 set commitinfo($id) {"No commit information available"}
2930 if {![info exists children($curview,$id)]} {
2931 set children($curview,$id) {}
2935 proc layouttail {} {
2936 global rowidlist rowoffsets idinlist commitidx curview
2937 global idrowranges rowrangelist
2939 set row $commitidx($curview)
2940 set idlist [lindex $rowidlist $row]
2941 while {$idlist ne {}} {
2942 set col [expr {[llength $idlist] - 1}]
2943 set id [lindex $idlist $col]
2946 lappend idrowranges($id) $id
2947 lappend rowrangelist $idrowranges($id)
2948 unset idrowranges($id)
2950 set offs [ntimes $col 0]
2951 set idlist [lreplace $idlist $col $col]
2952 lappend rowidlist $idlist
2953 lappend rowoffsets $offs
2956 foreach id [array names idinlist] {
2959 lset rowidlist $row [list $id]
2960 lset rowoffsets $row 0
2961 makeuparrow $id 0 $row 0
2962 lappend idrowranges($id) $id
2963 lappend rowrangelist $idrowranges($id)
2964 unset idrowranges($id)
2966 lappend rowidlist {}
2967 lappend rowoffsets {}
2971 proc insert_pad {row col npad} {
2972 global rowidlist rowoffsets
2974 set pad [ntimes $npad {}]
2975 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2976 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2977 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2980 proc optimize_rows {row col endrow} {
2981 global rowidlist rowoffsets displayorder
2983 for {} {$row < $endrow} {incr row} {
2984 set idlist [lindex $rowidlist $row]
2985 set offs [lindex $rowoffsets $row]
2987 for {} {$col < [llength $offs]} {incr col} {
2988 if {[lindex $idlist $col] eq {}} {
2992 set z [lindex $offs $col]
2993 if {$z eq {}} continue
2995 set x0 [expr {$col + $z}]
2996 set y0 [expr {$row - 1}]
2997 set z0 [lindex $rowoffsets $y0 $x0]
2999 set id [lindex $idlist $col]
3000 set ranges [rowranges $id]
3001 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3005 # Looking at lines from this row to the previous row,
3006 # make them go straight up if they end in an arrow on
3007 # the previous row; otherwise make them go straight up
3009 if {$z < -1 || ($z < 0 && $isarrow)} {
3010 # Line currently goes left too much;
3011 # insert pads in the previous row, then optimize it
3012 set npad [expr {-1 - $z + $isarrow}]
3013 set offs [incrange $offs $col $npad]
3014 insert_pad $y0 $x0 $npad
3016 optimize_rows $y0 $x0 $row
3018 set z [lindex $offs $col]
3019 set x0 [expr {$col + $z}]
3020 set z0 [lindex $rowoffsets $y0 $x0]
3021 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3022 # Line currently goes right too much;
3023 # insert pads in this line and adjust the next's rowoffsets
3024 set npad [expr {$z - 1 + $isarrow}]
3025 set y1 [expr {$row + 1}]
3026 set offs2 [lindex $rowoffsets $y1]
3030 if {$z eq {} || $x1 + $z < $col} continue
3031 if {$x1 + $z > $col} {
3034 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3037 set pad [ntimes $npad {}]
3038 set idlist [eval linsert \$idlist $col $pad]
3039 set tmp [eval linsert \$offs $col $pad]
3041 set offs [incrange $tmp $col [expr {-$npad}]]
3042 set z [lindex $offs $col]
3045 if {$z0 eq {} && !$isarrow} {
3046 # this line links to its first child on row $row-2
3047 set rm2 [expr {$row - 2}]
3048 set id [lindex $displayorder $rm2]
3049 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3051 set z0 [expr {$xc - $x0}]
3054 # avoid lines jigging left then immediately right
3055 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3056 insert_pad $y0 $x0 1
3057 set offs [incrange $offs $col 1]
3058 optimize_rows $y0 [expr {$x0 + 1}] $row
3063 # Find the first column that doesn't have a line going right
3064 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3065 set o [lindex $offs $col]
3067 # check if this is the link to the first child
3068 set id [lindex $idlist $col]
3069 set ranges [rowranges $id]
3070 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3071 # it is, work out offset to child
3072 set y0 [expr {$row - 1}]
3073 set id [lindex $displayorder $y0]
3074 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3076 set o [expr {$x0 - $col}]
3080 if {$o eq {} || $o <= 0} break
3082 # Insert a pad at that column as long as it has a line and
3083 # isn't the last column, and adjust the next row' offsets
3084 if {$o ne {} && [incr col] < [llength $idlist]} {
3085 set y1 [expr {$row + 1}]
3086 set offs2 [lindex $rowoffsets $y1]
3090 if {$z eq {} || $x1 + $z < $col} continue
3091 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3094 set idlist [linsert $idlist $col {}]
3095 set tmp [linsert $offs $col {}]
3097 set offs [incrange $tmp $col -1]
3100 lset rowidlist $row $idlist
3101 lset rowoffsets $row $offs
3107 global canvx0 linespc
3108 return [expr {$canvx0 + $col * $linespc}]
3112 global canvy0 linespc
3113 return [expr {$canvy0 + $row * $linespc}]
3116 proc linewidth {id} {
3117 global thickerline lthickness
3120 if {[info exists thickerline] && $id eq $thickerline} {
3121 set wid [expr {2 * $lthickness}]
3126 proc rowranges {id} {
3127 global phase idrowranges commitrow rowlaidout rowrangelist curview
3131 ([info exists commitrow($curview,$id)]
3132 && $commitrow($curview,$id) < $rowlaidout)} {
3133 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3134 } elseif {[info exists idrowranges($id)]} {
3135 set ranges $idrowranges($id)
3138 foreach rid $ranges {
3139 lappend linenos $commitrow($curview,$rid)
3141 if {$linenos ne {}} {
3142 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3147 # work around tk8.4 refusal to draw arrows on diagonal segments
3148 proc adjarrowhigh {coords} {
3151 set x0 [lindex $coords 0]
3152 set x1 [lindex $coords 2]
3154 set y0 [lindex $coords 1]
3155 set y1 [lindex $coords 3]
3156 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3157 # we have a nearby vertical segment, just trim off the diag bit
3158 set coords [lrange $coords 2 end]
3160 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3161 set xi [expr {$x0 - $slope * $linespc / 2}]
3162 set yi [expr {$y0 - $linespc / 2}]
3163 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3169 proc drawlineseg {id row endrow arrowlow} {
3170 global rowidlist displayorder iddrawn linesegs
3171 global canv colormap linespc curview maxlinelen
3173 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3174 set le [expr {$row + 1}]
3177 set c [lsearch -exact [lindex $rowidlist $le] $id]
3183 set x [lindex $displayorder $le]
3188 if {[info exists iddrawn($x)] || $le == $endrow} {
3189 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3205 if {[info exists linesegs($id)]} {
3206 set lines $linesegs($id)
3208 set r0 [lindex $li 0]
3210 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3220 set li [lindex $lines [expr {$i-1}]]
3221 set r1 [lindex $li 1]
3222 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3227 set x [lindex $cols [expr {$le - $row}]]
3228 set xp [lindex $cols [expr {$le - 1 - $row}]]
3229 set dir [expr {$xp - $x}]
3231 set ith [lindex $lines $i 2]
3232 set coords [$canv coords $ith]
3233 set ah [$canv itemcget $ith -arrow]
3234 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3235 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3236 if {$x2 ne {} && $x - $x2 == $dir} {
3237 set coords [lrange $coords 0 end-2]
3240 set coords [list [xc $le $x] [yc $le]]
3243 set itl [lindex $lines [expr {$i-1}] 2]
3244 set al [$canv itemcget $itl -arrow]
3245 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3246 } elseif {$arrowlow &&
3247 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3250 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3251 for {set y $le} {[incr y -1] > $row} {} {
3253 set xp [lindex $cols [expr {$y - 1 - $row}]]
3254 set ndir [expr {$xp - $x}]
3255 if {$dir != $ndir || $xp < 0} {
3256 lappend coords [xc $y $x] [yc $y]
3262 # join parent line to first child
3263 set ch [lindex $displayorder $row]
3264 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3266 puts "oops: drawlineseg: child $ch not on row $row"
3269 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3270 } elseif {$xc > $x + 1} {
3271 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3275 lappend coords [xc $row $x] [yc $row]
3277 set xn [xc $row $xp]
3279 # work around tk8.4 refusal to draw arrows on diagonal segments
3280 if {$arrowlow && $xn != [lindex $coords end-1]} {
3281 if {[llength $coords] < 4 ||
3282 [lindex $coords end-3] != [lindex $coords end-1] ||
3283 [lindex $coords end] - $yn > 2 * $linespc} {
3284 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3285 set yo [yc [expr {$row + 0.5}]]
3286 lappend coords $xn $yo $xn $yn
3289 lappend coords $xn $yn
3294 set coords [adjarrowhigh $coords]
3297 set t [$canv create line $coords -width [linewidth $id] \
3298 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3301 set lines [linsert $lines $i [list $row $le $t]]
3303 $canv coords $ith $coords
3304 if {$arrow ne $ah} {
3305 $canv itemconf $ith -arrow $arrow
3307 lset lines $i 0 $row
3310 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3311 set ndir [expr {$xo - $xp}]
3312 set clow [$canv coords $itl]
3313 if {$dir == $ndir} {
3314 set clow [lrange $clow 2 end]
3316 set coords [concat $coords $clow]
3318 lset lines [expr {$i-1}] 1 $le
3320 set coords [adjarrowhigh $coords]
3323 # coalesce two pieces
3325 set b [lindex $lines [expr {$i-1}] 0]
3326 set e [lindex $lines $i 1]
3327 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3329 $canv coords $itl $coords
3330 if {$arrow ne $al} {
3331 $canv itemconf $itl -arrow $arrow
3335 set linesegs($id) $lines
3339 proc drawparentlinks {id row} {
3340 global rowidlist canv colormap curview parentlist
3343 set rowids [lindex $rowidlist $row]
3344 set col [lsearch -exact $rowids $id]
3345 if {$col < 0} return
3346 set olds [lindex $parentlist $row]
3347 set row2 [expr {$row + 1}]
3348 set x [xc $row $col]
3351 set ids [lindex $rowidlist $row2]
3352 # rmx = right-most X coord used
3355 set i [lsearch -exact $ids $p]
3357 puts "oops, parent $p of $id not in list"
3360 set x2 [xc $row2 $i]
3364 if {[lsearch -exact $rowids $p] < 0} {
3365 # drawlineseg will do this one for us
3369 # should handle duplicated parents here...
3370 set coords [list $x $y]
3371 if {$i < $col - 1} {
3372 lappend coords [xc $row [expr {$i + 1}]] $y
3373 } elseif {$i > $col + 1} {
3374 lappend coords [xc $row [expr {$i - 1}]] $y
3376 lappend coords $x2 $y2
3377 set t [$canv create line $coords -width [linewidth $p] \
3378 -fill $colormap($p) -tags lines.$p]
3382 if {$rmx > [lindex $idpos($id) 1]} {
3383 lset idpos($id) 1 $rmx
3388 proc drawlines {id} {
3391 $canv itemconf lines.$id -width [linewidth $id]
3394 proc drawcmittext {id row col} {
3395 global linespc canv canv2 canv3 canvy0 fgcolor curview
3396 global commitlisted commitinfo rowidlist parentlist
3397 global rowtextx idpos idtags idheads idotherrefs
3398 global linehtag linentag linedtag markingmatches
3399 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3401 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3402 set listed [lindex $commitlisted $row]
3403 if {$id eq $nullid} {
3405 } elseif {$id eq $nullid2} {
3408 set ofill [expr {$listed != 0? "blue": "white"}]
3410 set x [xc $row $col]
3412 set orad [expr {$linespc / 3}]
3414 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3415 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3416 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3417 } elseif {$listed == 2} {
3418 # triangle pointing left for left-side commits
3419 set t [$canv create polygon \
3420 [expr {$x - $orad}] $y \
3421 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3422 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3423 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3425 # triangle pointing right for right-side commits
3426 set t [$canv create polygon \
3427 [expr {$x + $orad - 1}] $y \
3428 [expr {$x - $orad}] [expr {$y - $orad}] \
3429 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3430 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3433 $canv bind $t <1> {selcanvline {} %x %y}
3434 set rmx [llength [lindex $rowidlist $row]]
3435 set olds [lindex $parentlist $row]
3437 set nextids [lindex $rowidlist [expr {$row + 1}]]
3439 set i [lsearch -exact $nextids $p]
3445 set xt [xc $row $rmx]
3446 set rowtextx($row) $xt
3447 set idpos($id) [list $x $xt $y]
3448 if {[info exists idtags($id)] || [info exists idheads($id)]
3449 || [info exists idotherrefs($id)]} {
3450 set xt [drawtags $id $x $xt $y]
3452 set headline [lindex $commitinfo($id) 0]
3453 set name [lindex $commitinfo($id) 1]
3454 set date [lindex $commitinfo($id) 2]
3455 set date [formatdate $date]
3458 set isbold [ishighlighted $row]
3460 lappend boldrows $row
3463 lappend boldnamerows $row
3467 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3468 -text $headline -font $font -tags text]
3469 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3470 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3471 -text $name -font $nfont -tags text]
3472 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3473 -text $date -font $mainfont -tags text]
3474 set xr [expr {$xt + [font measure $mainfont $headline]}]
3475 if {$markingmatches} {
3476 markrowmatches $row $headline $name
3478 if {$xr > $canvxmax} {
3484 proc drawcmitrow {row} {
3485 global displayorder rowidlist
3487 global commitinfo parentlist numcommits
3488 global filehighlight fhighlights findstring nhighlights
3489 global hlview vhighlights
3490 global highlight_related rhighlights
3492 if {$row >= $numcommits} return
3494 set id [lindex $displayorder $row]
3495 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3496 askvhighlight $row $id
3498 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3499 askfilehighlight $row $id
3501 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3502 askfindhighlight $row $id
3504 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3505 askrelhighlight $row $id
3507 if {[info exists iddrawn($id)]} return
3508 set col [lsearch -exact [lindex $rowidlist $row] $id]
3510 puts "oops, row $row id $id not in list"
3513 if {![info exists commitinfo($id)]} {
3517 drawcmittext $id $row $col
3521 proc drawcommits {row {endrow {}}} {
3522 global numcommits iddrawn displayorder curview
3523 global parentlist rowidlist
3528 if {$endrow eq {}} {
3531 if {$endrow >= $numcommits} {
3532 set endrow [expr {$numcommits - 1}]
3535 # make the lines join to already-drawn rows either side
3536 set r [expr {$row - 1}]
3537 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3540 set er [expr {$endrow + 1}]
3541 if {$er >= $numcommits ||
3542 ![info exists iddrawn([lindex $displayorder $er])]} {
3545 for {} {$r <= $er} {incr r} {
3546 set id [lindex $displayorder $r]
3547 set wasdrawn [info exists iddrawn($id)]
3549 if {$r == $er} break
3550 set nextid [lindex $displayorder [expr {$r + 1}]]
3551 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3552 catch {unset prevlines}
3555 drawparentlinks $id $r
3557 if {[info exists lineends($r)]} {
3558 foreach lid $lineends($r) {
3559 unset prevlines($lid)
3562 set rowids [lindex $rowidlist $r]
3563 foreach lid $rowids {
3564 if {$lid eq {}} continue
3566 # see if this is the first child of any of its parents
3567 foreach p [lindex $parentlist $r] {
3568 if {[lsearch -exact $rowids $p] < 0} {
3569 # make this line extend up to the child
3570 set le [drawlineseg $p $r $er 0]
3571 lappend lineends($le) $p
3575 } elseif {![info exists prevlines($lid)]} {
3576 set le [drawlineseg $lid $r $er 1]
3577 lappend lineends($le) $lid
3578 set prevlines($lid) 1
3584 proc drawfrac {f0 f1} {
3587 set ymax [lindex [$canv cget -scrollregion] 3]
3588 if {$ymax eq {} || $ymax == 0} return
3589 set y0 [expr {int($f0 * $ymax)}]
3590 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3591 set y1 [expr {int($f1 * $ymax)}]
3592 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3593 drawcommits $row $endrow
3596 proc drawvisible {} {
3598 eval drawfrac [$canv yview]
3601 proc clear_display {} {
3602 global iddrawn linesegs
3603 global vhighlights fhighlights nhighlights rhighlights
3606 catch {unset iddrawn}
3607 catch {unset linesegs}
3608 catch {unset vhighlights}
3609 catch {unset fhighlights}
3610 catch {unset nhighlights}
3611 catch {unset rhighlights}
3614 proc findcrossings {id} {
3615 global rowidlist parentlist numcommits rowoffsets displayorder
3619 foreach {s e} [rowranges $id] {
3620 if {$e >= $numcommits} {
3621 set e [expr {$numcommits - 1}]
3623 if {$e <= $s} continue
3624 set x [lsearch -exact [lindex $rowidlist $e] $id]
3626 puts "findcrossings: oops, no [shortids $id] in row $e"
3629 for {set row $e} {[incr row -1] >= $s} {} {
3630 set olds [lindex $parentlist $row]
3631 set kid [lindex $displayorder $row]
3632 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3633 if {$kidx < 0} continue
3634 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3636 set px [lsearch -exact $nextrow $p]
3637 if {$px < 0} continue
3638 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3639 if {[lsearch -exact $ccross $p] >= 0} continue
3640 if {$x == $px + ($kidx < $px? -1: 1)} {
3642 } elseif {[lsearch -exact $cross $p] < 0} {
3647 set inc [lindex $rowoffsets $row $x]
3648 if {$inc eq {}} break
3652 return [concat $ccross {{}} $cross]
3655 proc assigncolor {id} {
3656 global colormap colors nextcolor
3657 global commitrow parentlist children children curview
3659 if {[info exists colormap($id)]} return
3660 set ncolors [llength $colors]
3661 if {[info exists children($curview,$id)]} {
3662 set kids $children($curview,$id)
3666 if {[llength $kids] == 1} {
3667 set child [lindex $kids 0]
3668 if {[info exists colormap($child)]
3669 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3670 set colormap($id) $colormap($child)
3676 foreach x [findcrossings $id] {
3678 # delimiter between corner crossings and other crossings
3679 if {[llength $badcolors] >= $ncolors - 1} break
3680 set origbad $badcolors
3682 if {[info exists colormap($x)]
3683 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3684 lappend badcolors $colormap($x)
3687 if {[llength $badcolors] >= $ncolors} {
3688 set badcolors $origbad
3690 set origbad $badcolors
3691 if {[llength $badcolors] < $ncolors - 1} {
3692 foreach child $kids {
3693 if {[info exists colormap($child)]
3694 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3695 lappend badcolors $colormap($child)
3697 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3698 if {[info exists colormap($p)]
3699 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3700 lappend badcolors $colormap($p)
3704 if {[llength $badcolors] >= $ncolors} {
3705 set badcolors $origbad
3708 for {set i 0} {$i <= $ncolors} {incr i} {
3709 set c [lindex $colors $nextcolor]
3710 if {[incr nextcolor] >= $ncolors} {
3713 if {[lsearch -exact $badcolors $c]} break
3715 set colormap($id) $c
3718 proc bindline {t id} {
3721 $canv bind $t <Enter> "lineenter %x %y $id"
3722 $canv bind $t <Motion> "linemotion %x %y $id"
3723 $canv bind $t <Leave> "lineleave $id"
3724 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3727 proc drawtags {id x xt y1} {
3728 global idtags idheads idotherrefs mainhead
3729 global linespc lthickness
3730 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3735 if {[info exists idtags($id)]} {
3736 set marks $idtags($id)
3737 set ntags [llength $marks]
3739 if {[info exists idheads($id)]} {
3740 set marks [concat $marks $idheads($id)]
3741 set nheads [llength $idheads($id)]
3743 if {[info exists idotherrefs($id)]} {
3744 set marks [concat $marks $idotherrefs($id)]
3750 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3751 set yt [expr {$y1 - 0.5 * $linespc}]
3752 set yb [expr {$yt + $linespc - 1}]
3756 foreach tag $marks {
3758 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3759 set wid [font measure [concat $mainfont bold] $tag]
3761 set wid [font measure $mainfont $tag]
3765 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3767 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3768 -width $lthickness -fill black -tags tag.$id]
3770 foreach tag $marks x $xvals wid $wvals {
3771 set xl [expr {$x + $delta}]
3772 set xr [expr {$x + $delta + $wid + $lthickness}]
3774 if {[incr ntags -1] >= 0} {
3776 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3777 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3778 -width 1 -outline black -fill yellow -tags tag.$id]
3779 $canv bind $t <1> [list showtag $tag 1]
3780 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3782 # draw a head or other ref
3783 if {[incr nheads -1] >= 0} {
3785 if {$tag eq $mainhead} {
3791 set xl [expr {$xl - $delta/2}]
3792 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3793 -width 1 -outline black -fill $col -tags tag.$id
3794 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3795 set rwid [font measure $mainfont $remoteprefix]
3796 set xi [expr {$x + 1}]
3797 set yti [expr {$yt + 1}]
3798 set xri [expr {$x + $rwid}]
3799 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3800 -width 0 -fill "#ffddaa" -tags tag.$id
3803 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3804 -font $font -tags [list tag.$id text]]
3806 $canv bind $t <1> [list showtag $tag 1]
3807 } elseif {$nheads >= 0} {
3808 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3814 proc xcoord {i level ln} {
3815 global canvx0 xspc1 xspc2
3817 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3818 if {$i > 0 && $i == $level} {
3819 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3820 } elseif {$i > $level} {
3821 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3826 proc show_status {msg} {
3827 global canv mainfont fgcolor
3830 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3831 -tags text -fill $fgcolor
3834 # Insert a new commit as the child of the commit on row $row.
3835 # The new commit will be displayed on row $row and the commits
3836 # on that row and below will move down one row.
3837 proc insertrow {row newcmit} {
3838 global displayorder parentlist commitlisted children
3839 global commitrow curview rowidlist rowoffsets numcommits
3840 global rowrangelist rowlaidout rowoptim numcommits
3841 global selectedline rowchk commitidx
3843 if {$row >= $numcommits} {
3844 puts "oops, inserting new row $row but only have $numcommits rows"
3847 set p [lindex $displayorder $row]
3848 set displayorder [linsert $displayorder $row $newcmit]
3849 set parentlist [linsert $parentlist $row $p]
3850 set kids $children($curview,$p)
3851 lappend kids $newcmit
3852 set children($curview,$p) $kids
3853 set children($curview,$newcmit) {}
3854 set commitlisted [linsert $commitlisted $row 1]
3855 set l [llength $displayorder]
3856 for {set r $row} {$r < $l} {incr r} {
3857 set id [lindex $displayorder $r]
3858 set commitrow($curview,$id) $r
3860 incr commitidx($curview)
3862 set idlist [lindex $rowidlist $row]
3863 set offs [lindex $rowoffsets $row]
3866 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3872 if {[llength $kids] == 1} {
3873 set col [lsearch -exact $idlist $p]
3874 lset idlist $col $newcmit
3876 set col [llength $idlist]
3877 lappend idlist $newcmit
3879 lset rowoffsets $row $offs
3881 set rowidlist [linsert $rowidlist $row $idlist]
3882 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3884 set rowrangelist [linsert $rowrangelist $row {}]
3885 if {[llength $kids] > 1} {
3886 set rp1 [expr {$row + 1}]
3887 set ranges [lindex $rowrangelist $rp1]
3888 if {$ranges eq {}} {
3889 set ranges [list $newcmit $p]
3890 } elseif {[lindex $ranges end-1] eq $p} {
3891 lset ranges end-1 $newcmit
3893 lset rowrangelist $rp1 $ranges
3896 catch {unset rowchk}
3902 if {[info exists selectedline] && $selectedline >= $row} {
3908 # Remove a commit that was inserted with insertrow on row $row.
3909 proc removerow {row} {
3910 global displayorder parentlist commitlisted children
3911 global commitrow curview rowidlist rowoffsets numcommits
3912 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3913 global linesegends selectedline rowchk commitidx
3915 if {$row >= $numcommits} {
3916 puts "oops, removing row $row but only have $numcommits rows"
3919 set rp1 [expr {$row + 1}]
3920 set id [lindex $displayorder $row]
3921 set p [lindex $parentlist $row]
3922 set displayorder [lreplace $displayorder $row $row]
3923 set parentlist [lreplace $parentlist $row $row]
3924 set commitlisted [lreplace $commitlisted $row $row]
3925 set kids $children($curview,$p)
3926 set i [lsearch -exact $kids $id]
3928 set kids [lreplace $kids $i $i]
3929 set children($curview,$p) $kids
3931 set l [llength $displayorder]
3932 for {set r $row} {$r < $l} {incr r} {
3933 set id [lindex $displayorder $r]
3934 set commitrow($curview,$id) $r
3936 incr commitidx($curview) -1
3938 set rowidlist [lreplace $rowidlist $row $row]
3939 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3941 set offs [lindex $rowoffsets $row]
3942 set offs [lreplace $offs end end]
3943 lset rowoffsets $row $offs
3946 set rowrangelist [lreplace $rowrangelist $row $row]
3947 if {[llength $kids] > 0} {
3948 set ranges [lindex $rowrangelist $row]
3949 if {[lindex $ranges end-1] eq $id} {
3950 set ranges [lreplace $ranges end-1 end]
3951 lset rowrangelist $row $ranges
3955 catch {unset rowchk}
3961 if {[info exists selectedline] && $selectedline > $row} {
3962 incr selectedline -1
3967 # Don't change the text pane cursor if it is currently the hand cursor,
3968 # showing that we are over a sha1 ID link.
3969 proc settextcursor {c} {
3970 global ctext curtextcursor
3972 if {[$ctext cget -cursor] == $curtextcursor} {
3973 $ctext config -cursor $c
3975 set curtextcursor $c
3978 proc nowbusy {what} {
3981 if {[array names isbusy] eq {}} {
3982 . config -cursor watch
3988 proc notbusy {what} {
3989 global isbusy maincursor textcursor
3991 catch {unset isbusy($what)}
3992 if {[array names isbusy] eq {}} {
3993 . config -cursor $maincursor
3994 settextcursor $textcursor
3998 proc findmatches {f} {
3999 global findtype findstring
4000 if {$findtype == "Regexp"} {
4001 set matches [regexp -indices -all -inline $findstring $f]
4004 if {$findtype == "IgnCase"} {
4005 set f [string tolower $f]
4006 set fs [string tolower $fs]
4010 set l [string length $fs]
4011 while {[set j [string first $fs $f $i]] >= 0} {
4012 lappend matches [list $j [expr {$j+$l-1}]]
4013 set i [expr {$j + $l}]
4019 proc dofind {{rev 0}} {
4020 global findstring findstartline findcurline selectedline numcommits
4023 cancel_next_highlight
4025 if {$findstring eq {} || $numcommits == 0} return
4026 if {![info exists selectedline]} {
4027 set findstartline [lindex [visiblerows] $rev]
4029 set findstartline $selectedline
4031 set findcurline $findstartline
4036 set findcurline $findstartline
4037 if {$findcurline == 0} {
4038 set findcurline $numcommits
4045 proc findnext {restart} {
4047 if {![info exists findcurline]} {
4061 if {![info exists findcurline]} {
4070 global commitdata commitinfo numcommits findstring findpattern findloc
4071 global findstartline findcurline markingmatches displayorder
4073 set fldtypes {Headline Author Date Committer CDate Comments}
4074 set l [expr {$findcurline + 1}]
4075 if {$l >= $numcommits} {
4078 if {$l <= $findstartline} {
4079 set lim [expr {$findstartline + 1}]
4083 if {$lim - $l > 500} {
4084 set lim [expr {$l + 500}]
4087 for {} {$l < $lim} {incr l} {
4088 set id [lindex $displayorder $l]
4089 if {![doesmatch $commitdata($id)]} continue
4090 if {![info exists commitinfo($id)]} {
4093 set info $commitinfo($id)
4094 foreach f $info ty $fldtypes {
4095 if {($findloc eq "All fields" || $findloc eq $ty) &&
4097 set markingmatches 1
4104 if {$l == $findstartline + 1} {
4110 set findcurline [expr {$l - 1}]
4114 proc findmorerev {} {
4115 global commitdata commitinfo numcommits findstring findpattern findloc
4116 global findstartline findcurline markingmatches displayorder
4118 set fldtypes {Headline Author Date Committer CDate Comments}
4124 if {$l >= $findstartline} {
4125 set lim [expr {$findstartline - 1}]
4129 if {$l - $lim > 500} {
4130 set lim [expr {$l - 500}]
4133 for {} {$l > $lim} {incr l -1} {
4134 set id [lindex $displayorder $l]
4135 if {![doesmatch $commitdata($id)]} continue
4136 if {![info exists commitinfo($id)]} {
4139 set info $commitinfo($id)
4140 foreach f $info ty $fldtypes {
4141 if {($findloc eq "All fields" || $findloc eq $ty) &&
4143 set markingmatches 1
4156 set findcurline [expr {$l + 1}]
4160 proc findselectline {l} {
4161 global findloc commentend ctext
4163 if {$findloc == "All fields" || $findloc == "Comments"} {
4164 # highlight the matches in the comments
4165 set f [$ctext get 1.0 $commentend]
4166 set matches [findmatches $f]
4167 foreach match $matches {
4168 set start [lindex $match 0]
4169 set end [expr {[lindex $match 1] + 1}]
4170 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4175 # mark the bits of a headline or author that match a find string
4176 proc markmatches {canv l str tag matches font} {
4177 set bbox [$canv bbox $tag]
4178 set x0 [lindex $bbox 0]
4179 set y0 [lindex $bbox 1]
4180 set y1 [lindex $bbox 3]
4181 foreach match $matches {
4182 set start [lindex $match 0]
4183 set end [lindex $match 1]
4184 if {$start > $end} continue
4185 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4186 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4187 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4188 [expr {$x0+$xlen+2}] $y1 \
4189 -outline {} -tags [list match$l matches] -fill yellow]
4194 proc unmarkmatches {} {
4195 global findids markingmatches findcurline
4197 allcanvs delete matches
4198 catch {unset findids}
4199 set markingmatches 0
4200 catch {unset findcurline}
4203 proc selcanvline {w x y} {
4204 global canv canvy0 ctext linespc
4206 set ymax [lindex [$canv cget -scrollregion] 3]
4207 if {$ymax == {}} return
4208 set yfrac [lindex [$canv yview] 0]
4209 set y [expr {$y + $yfrac * $ymax}]
4210 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4215 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4221 proc commit_descriptor {p} {
4223 if {![info exists commitinfo($p)]} {
4227 if {[llength $commitinfo($p)] > 1} {
4228 set l [lindex $commitinfo($p) 0]
4233 # append some text to the ctext widget, and make any SHA1 ID
4234 # that we know about be a clickable link.
4235 proc appendwithlinks {text tags} {
4236 global ctext commitrow linknum curview
4238 set start [$ctext index "end - 1c"]
4239 $ctext insert end $text $tags
4240 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4244 set linkid [string range $text $s $e]
4245 if {![info exists commitrow($curview,$linkid)]} continue
4247 $ctext tag add link "$start + $s c" "$start + $e c"
4248 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4249 $ctext tag bind link$linknum <1> \
4250 [list selectline $commitrow($curview,$linkid) 1]
4253 $ctext tag conf link -foreground blue -underline 1
4254 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4255 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4258 proc viewnextline {dir} {
4262 set ymax [lindex [$canv cget -scrollregion] 3]
4263 set wnow [$canv yview]
4264 set wtop [expr {[lindex $wnow 0] * $ymax}]
4265 set newtop [expr {$wtop + $dir * $linespc}]
4268 } elseif {$newtop > $ymax} {
4271 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4274 # add a list of tag or branch names at position pos
4275 # returns the number of names inserted
4276 proc appendrefs {pos ids var} {
4277 global ctext commitrow linknum curview $var maxrefs
4279 if {[catch {$ctext index $pos}]} {
4282 $ctext conf -state normal
4283 $ctext delete $pos "$pos lineend"
4286 foreach tag [set $var\($id\)] {
4287 lappend tags [list $tag $id]
4290 if {[llength $tags] > $maxrefs} {
4291 $ctext insert $pos "many ([llength $tags])"
4293 set tags [lsort -index 0 -decreasing $tags]
4296 set id [lindex $ti 1]
4299 $ctext tag delete $lk
4300 $ctext insert $pos $sep
4301 $ctext insert $pos [lindex $ti 0] $lk
4302 if {[info exists commitrow($curview,$id)]} {
4303 $ctext tag conf $lk -foreground blue
4304 $ctext tag bind $lk <1> \
4305 [list selectline $commitrow($curview,$id) 1]
4306 $ctext tag conf $lk -underline 1
4307 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4308 $ctext tag bind $lk <Leave> \
4309 { %W configure -cursor $curtextcursor }
4314 $ctext conf -state disabled
4315 return [llength $tags]
4318 # called when we have finished computing the nearby tags
4319 proc dispneartags {delay} {
4320 global selectedline currentid showneartags tagphase
4322 if {![info exists selectedline] || !$showneartags} return
4323 after cancel dispnexttag
4325 after 200 dispnexttag
4328 after idle dispnexttag
4333 proc dispnexttag {} {
4334 global selectedline currentid showneartags tagphase ctext
4336 if {![info exists selectedline] || !$showneartags} return
4337 switch -- $tagphase {
4339 set dtags [desctags $currentid]
4341 appendrefs precedes $dtags idtags
4345 set atags [anctags $currentid]
4347 appendrefs follows $atags idtags
4351 set dheads [descheads $currentid]
4352 if {$dheads ne {}} {
4353 if {[appendrefs branch $dheads idheads] > 1
4354 && [$ctext get "branch -3c"] eq "h"} {
4355 # turn "Branch" into "Branches"
4356 $ctext conf -state normal
4357 $ctext insert "branch -2c" "es"
4358 $ctext conf -state disabled
4363 if {[incr tagphase] <= 2} {
4364 after idle dispnexttag
4368 proc selectline {l isnew} {
4369 global canv canv2 canv3 ctext commitinfo selectedline
4370 global displayorder linehtag linentag linedtag
4371 global canvy0 linespc parentlist children curview
4372 global currentid sha1entry
4373 global commentend idtags linknum
4374 global mergemax numcommits pending_select
4375 global cmitmode showneartags allcommits
4377 catch {unset pending_select}
4380 cancel_next_highlight
4381 if {$l < 0 || $l >= $numcommits} return
4382 set y [expr {$canvy0 + $l * $linespc}]
4383 set ymax [lindex [$canv cget -scrollregion] 3]
4384 set ytop [expr {$y - $linespc - 1}]
4385 set ybot [expr {$y + $linespc + 1}]
4386 set wnow [$canv yview]
4387 set wtop [expr {[lindex $wnow 0] * $ymax}]
4388 set wbot [expr {[lindex $wnow 1] * $ymax}]
4389 set wh [expr {$wbot - $wtop}]
4391 if {$ytop < $wtop} {
4392 if {$ybot < $wtop} {
4393 set newtop [expr {$y - $wh / 2.0}]
4396 if {$newtop > $wtop - $linespc} {
4397 set newtop [expr {$wtop - $linespc}]
4400 } elseif {$ybot > $wbot} {
4401 if {$ytop > $wbot} {
4402 set newtop [expr {$y - $wh / 2.0}]
4404 set newtop [expr {$ybot - $wh}]
4405 if {$newtop < $wtop + $linespc} {
4406 set newtop [expr {$wtop + $linespc}]
4410 if {$newtop != $wtop} {
4414 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4418 if {![info exists linehtag($l)]} return
4420 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4421 -tags secsel -fill [$canv cget -selectbackground]]
4423 $canv2 delete secsel
4424 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4425 -tags secsel -fill [$canv2 cget -selectbackground]]
4427 $canv3 delete secsel
4428 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4429 -tags secsel -fill [$canv3 cget -selectbackground]]
4433 addtohistory [list selectline $l 0]
4438 set id [lindex $displayorder $l]
4440 $sha1entry delete 0 end
4441 $sha1entry insert 0 $id
4442 $sha1entry selection from 0
4443 $sha1entry selection to end
4446 $ctext conf -state normal
4449 set info $commitinfo($id)
4450 set date [formatdate [lindex $info 2]]
4451 $ctext insert end "Author: [lindex $info 1] $date\n"
4452 set date [formatdate [lindex $info 4]]
4453 $ctext insert end "Committer: [lindex $info 3] $date\n"
4454 if {[info exists idtags($id)]} {
4455 $ctext insert end "Tags:"
4456 foreach tag $idtags($id) {
4457 $ctext insert end " $tag"
4459 $ctext insert end "\n"
4463 set olds [lindex $parentlist $l]
4464 if {[llength $olds] > 1} {
4467 if {$np >= $mergemax} {
4472 $ctext insert end "Parent: " $tag
4473 appendwithlinks [commit_descriptor $p] {}
4478 append headers "Parent: [commit_descriptor $p]"
4482 foreach c $children($curview,$id) {
4483 append headers "Child: [commit_descriptor $c]"
4486 # make anything that looks like a SHA1 ID be a clickable link
4487 appendwithlinks $headers {}
4488 if {$showneartags} {
4489 if {![info exists allcommits]} {
4492 $ctext insert end "Branch: "
4493 $ctext mark set branch "end -1c"
4494 $ctext mark gravity branch left
4495 $ctext insert end "\nFollows: "
4496 $ctext mark set follows "end -1c"
4497 $ctext mark gravity follows left
4498 $ctext insert end "\nPrecedes: "
4499 $ctext mark set precedes "end -1c"
4500 $ctext mark gravity precedes left
4501 $ctext insert end "\n"
4504 $ctext insert end "\n"
4505 set comment [lindex $info 5]
4506 if {[string first "\r" $comment] >= 0} {
4507 set comment [string map {"\r" "\n "} $comment]
4509 appendwithlinks $comment {comment}
4511 $ctext tag remove found 1.0 end
4512 $ctext conf -state disabled
4513 set commentend [$ctext index "end - 1c"]
4515 init_flist "Comments"
4516 if {$cmitmode eq "tree"} {
4518 } elseif {[llength $olds] <= 1} {
4525 proc selfirstline {} {
4530 proc sellastline {} {
4533 set l [expr {$numcommits - 1}]
4537 proc selnextline {dir} {
4539 if {![info exists selectedline]} return
4540 set l [expr {$selectedline + $dir}]
4545 proc selnextpage {dir} {
4546 global canv linespc selectedline numcommits
4548 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4552 allcanvs yview scroll [expr {$dir * $lpp}] units
4554 if {![info exists selectedline]} return
4555 set l [expr {$selectedline + $dir * $lpp}]
4558 } elseif {$l >= $numcommits} {
4559 set l [expr $numcommits - 1]
4565 proc unselectline {} {
4566 global selectedline currentid
4568 catch {unset selectedline}
4569 catch {unset currentid}
4570 allcanvs delete secsel
4572 cancel_next_highlight
4575 proc reselectline {} {
4578 if {[info exists selectedline]} {
4579 selectline $selectedline 0
4583 proc addtohistory {cmd} {
4584 global history historyindex curview
4586 set elt [list $curview $cmd]
4587 if {$historyindex > 0
4588 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4592 if {$historyindex < [llength $history]} {
4593 set history [lreplace $history $historyindex end $elt]
4595 lappend history $elt
4598 if {$historyindex > 1} {
4599 .tf.bar.leftbut conf -state normal
4601 .tf.bar.leftbut conf -state disabled
4603 .tf.bar.rightbut conf -state disabled
4609 set view [lindex $elt 0]
4610 set cmd [lindex $elt 1]
4611 if {$curview != $view} {
4618 global history historyindex
4620 if {$historyindex > 1} {
4621 incr historyindex -1
4622 godo [lindex $history [expr {$historyindex - 1}]]
4623 .tf.bar.rightbut conf -state normal
4625 if {$historyindex <= 1} {
4626 .tf.bar.leftbut conf -state disabled
4631 global history historyindex
4633 if {$historyindex < [llength $history]} {
4634 set cmd [lindex $history $historyindex]
4637 .tf.bar.leftbut conf -state normal
4639 if {$historyindex >= [llength $history]} {
4640 .tf.bar.rightbut conf -state disabled
4645 global treefilelist treeidlist diffids diffmergeid treepending
4646 global nullid nullid2
4649 catch {unset diffmergeid}
4650 if {![info exists treefilelist($id)]} {
4651 if {![info exists treepending]} {
4652 if {$id eq $nullid} {
4653 set cmd [list | git ls-files]
4654 } elseif {$id eq $nullid2} {
4655 set cmd [list | git ls-files --stage -t]
4657 set cmd [list | git ls-tree -r $id]
4659 if {[catch {set gtf [open $cmd r]}]} {
4663 set treefilelist($id) {}
4664 set treeidlist($id) {}
4665 fconfigure $gtf -blocking 0
4666 filerun $gtf [list gettreeline $gtf $id]
4673 proc gettreeline {gtf id} {
4674 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4677 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4678 if {$diffids eq $nullid} {
4681 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4682 set i [string first "\t" $line]
4683 if {$i < 0} continue
4684 set sha1 [lindex $line 2]
4685 set fname [string range $line [expr {$i+1}] end]
4686 if {[string index $fname 0] eq "\""} {
4687 set fname [lindex $fname 0]
4689 lappend treeidlist($id) $sha1
4691 lappend treefilelist($id) $fname
4694 return [expr {$nl >= 1000? 2: 1}]
4698 if {$cmitmode ne "tree"} {
4699 if {![info exists diffmergeid]} {
4700 gettreediffs $diffids
4702 } elseif {$id ne $diffids} {
4711 global treefilelist treeidlist diffids nullid nullid2
4712 global ctext commentend
4714 set i [lsearch -exact $treefilelist($diffids) $f]
4716 puts "oops, $f not in list for id $diffids"
4719 if {$diffids eq $nullid} {
4720 if {[catch {set bf [open $f r]} err]} {
4721 puts "oops, can't read $f: $err"
4725 set blob [lindex $treeidlist($diffids) $i]
4726 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4727 puts "oops, error reading blob $blob: $err"
4731 fconfigure $bf -blocking 0
4732 filerun $bf [list getblobline $bf $diffids]
4733 $ctext config -state normal
4734 clear_ctext $commentend
4735 $ctext insert end "\n"
4736 $ctext insert end "$f\n" filesep
4737 $ctext config -state disabled
4738 $ctext yview $commentend
4741 proc getblobline {bf id} {
4742 global diffids cmitmode ctext
4744 if {$id ne $diffids || $cmitmode ne "tree"} {
4748 $ctext config -state normal
4750 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4751 $ctext insert end "$line\n"
4754 # delete last newline
4755 $ctext delete "end - 2c" "end - 1c"
4759 $ctext config -state disabled
4760 return [expr {$nl >= 1000? 2: 1}]
4763 proc mergediff {id l} {
4764 global diffmergeid diffopts mdifffd
4770 # this doesn't seem to actually affect anything...
4771 set env(GIT_DIFF_OPTS) $diffopts
4772 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4773 if {[catch {set mdf [open $cmd r]} err]} {
4774 error_popup "Error getting merge diffs: $err"
4777 fconfigure $mdf -blocking 0
4778 set mdifffd($id) $mdf
4779 set np [llength [lindex $parentlist $l]]
4780 filerun $mdf [list getmergediffline $mdf $id $np]
4783 proc getmergediffline {mdf id np} {
4784 global diffmergeid ctext cflist mergemax
4785 global difffilestart mdifffd
4787 $ctext conf -state normal
4789 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4790 if {![info exists diffmergeid] || $id != $diffmergeid
4791 || $mdf != $mdifffd($id)} {
4795 if {[regexp {^diff --cc (.*)} $line match fname]} {
4796 # start of a new file
4797 $ctext insert end "\n"
4798 set here [$ctext index "end - 1c"]
4799 lappend difffilestart $here
4800 add_flist [list $fname]
4801 set l [expr {(78 - [string length $fname]) / 2}]
4802 set pad [string range "----------------------------------------" 1 $l]
4803 $ctext insert end "$pad $fname $pad\n" filesep
4804 } elseif {[regexp {^@@} $line]} {
4805 $ctext insert end "$line\n" hunksep
4806 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4809 # parse the prefix - one ' ', '-' or '+' for each parent
4814 for {set j 0} {$j < $np} {incr j} {
4815 set c [string range $line $j $j]
4818 } elseif {$c == "-"} {
4820 } elseif {$c == "+"} {
4829 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4830 # line doesn't appear in result, parents in $minuses have the line
4831 set num [lindex $minuses 0]
4832 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4833 # line appears in result, parents in $pluses don't have the line
4834 lappend tags mresult
4835 set num [lindex $spaces 0]
4838 if {$num >= $mergemax} {
4843 $ctext insert end "$line\n" $tags
4846 $ctext conf -state disabled
4851 return [expr {$nr >= 1000? 2: 1}]
4854 proc startdiff {ids} {
4855 global treediffs diffids treepending diffmergeid nullid nullid2
4858 catch {unset diffmergeid}
4859 if {![info exists treediffs($ids)] ||
4860 [lsearch -exact $ids $nullid] >= 0 ||
4861 [lsearch -exact $ids $nullid2] >= 0} {
4862 if {![info exists treepending]} {
4870 proc addtocflist {ids} {
4871 global treediffs cflist
4872 add_flist $treediffs($ids)
4876 proc diffcmd {ids flags} {
4877 global nullid nullid2
4879 set i [lsearch -exact $ids $nullid]
4880 set j [lsearch -exact $ids $nullid2]
4882 if {[llength $ids] > 1 && $j < 0} {
4883 # comparing working directory with some specific revision
4884 set cmd [concat | git diff-index $flags]
4886 lappend cmd -R [lindex $ids 1]
4888 lappend cmd [lindex $ids 0]
4891 # comparing working directory with index
4892 set cmd [concat | git diff-files $flags]
4897 } elseif {$j >= 0} {
4898 set cmd [concat | git diff-index --cached $flags]
4899 if {[llength $ids] > 1} {
4900 # comparing index with specific revision
4902 lappend cmd -R [lindex $ids 1]
4904 lappend cmd [lindex $ids 0]
4907 # comparing index with HEAD
4911 set cmd [concat | git diff-tree -r $flags $ids]
4916 proc gettreediffs {ids} {
4917 global treediff treepending
4919 set treepending $ids
4921 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4922 fconfigure $gdtf -blocking 0
4923 filerun $gdtf [list gettreediffline $gdtf $ids]
4926 proc gettreediffline {gdtf ids} {
4927 global treediff treediffs treepending diffids diffmergeid
4931 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4932 set i [string first "\t" $line]
4934 set file [string range $line [expr {$i+1}] end]
4935 if {[string index $file 0] eq "\""} {
4936 set file [lindex $file 0]
4938 lappend treediff $file
4942 return [expr {$nr >= 1000? 2: 1}]
4945 set treediffs($ids) $treediff
4947 if {$cmitmode eq "tree"} {
4949 } elseif {$ids != $diffids} {
4950 if {![info exists diffmergeid]} {
4951 gettreediffs $diffids
4959 proc getblobdiffs {ids} {
4960 global diffopts blobdifffd diffids env
4961 global diffinhdr treediffs
4963 set env(GIT_DIFF_OPTS) $diffopts
4964 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4965 puts "error getting diffs: $err"
4969 fconfigure $bdf -blocking 0
4970 set blobdifffd($ids) $bdf
4971 filerun $bdf [list getblobdiffline $bdf $diffids]
4974 proc setinlist {var i val} {
4977 while {[llength [set $var]] < $i} {
4980 if {[llength [set $var]] == $i} {
4987 proc makediffhdr {fname ids} {
4988 global ctext curdiffstart treediffs
4990 set i [lsearch -exact $treediffs($ids) $fname]
4992 setinlist difffilestart $i $curdiffstart
4994 set l [expr {(78 - [string length $fname]) / 2}]
4995 set pad [string range "----------------------------------------" 1 $l]
4996 $ctext insert $curdiffstart "$pad $fname $pad" filesep
4999 proc getblobdiffline {bdf ids} {
5000 global diffids blobdifffd ctext curdiffstart
5001 global diffnexthead diffnextnote difffilestart
5002 global diffinhdr treediffs
5005 $ctext conf -state normal
5006 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5007 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5011 if {![string compare -length 11 "diff --git " $line]} {
5012 # trim off "diff --git "
5013 set line [string range $line 11 end]
5015 # start of a new file
5016 $ctext insert end "\n"
5017 set curdiffstart [$ctext index "end - 1c"]
5018 $ctext insert end "\n" filesep
5019 # If the name hasn't changed the length will be odd,
5020 # the middle char will be a space, and the two bits either
5021 # side will be a/name and b/name, or "a/name" and "b/name".
5022 # If the name has changed we'll get "rename from" and
5023 # "rename to" lines following this, and we'll use them
5024 # to get the filenames.
5025 # This complexity is necessary because spaces in the filename(s)
5026 # don't get escaped.
5027 set l [string length $line]
5028 set i [expr {$l / 2}]
5029 if {!(($l & 1) && [string index $line $i] eq " " &&
5030 [string range $line 2 [expr {$i - 1}]] eq \
5031 [string range $line [expr {$i + 3}] end])} {
5034 # unescape if quoted and chop off the a/ from the front
5035 if {[string index $line 0] eq "\""} {
5036 set fname [string range [lindex $line 0] 2 end]
5038 set fname [string range $line 2 [expr {$i - 1}]]
5040 makediffhdr $fname $ids
5042 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5043 $line match f1l f1c f2l f2c rest]} {
5044 $ctext insert end "$line\n" hunksep
5047 } elseif {$diffinhdr} {
5048 if {![string compare -length 12 "rename from " $line]} {
5049 set fname [string range $line 12 end]
5050 if {[string index $fname 0] eq "\""} {
5051 set fname [lindex $fname 0]
5053 set i [lsearch -exact $treediffs($ids) $fname]
5055 setinlist difffilestart $i $curdiffstart
5057 } elseif {![string compare -length 10 $line "rename to "]} {
5058 set fname [string range $line 10 end]
5059 if {[string index $fname 0] eq "\""} {
5060 set fname [lindex $fname 0]
5062 makediffhdr $fname $ids
5063 } elseif {[string compare -length 3 $line "---"] == 0} {
5066 } elseif {[string compare -length 3 $line "+++"] == 0} {
5070 $ctext insert end "$line\n" filesep
5073 set x [string range $line 0 0]
5074 if {$x == "-" || $x == "+"} {
5075 set tag [expr {$x == "+"}]
5076 $ctext insert end "$line\n" d$tag
5077 } elseif {$x == " "} {
5078 $ctext insert end "$line\n"
5080 # "\ No newline at end of file",
5081 # or something else we don't recognize
5082 $ctext insert end "$line\n" hunksep
5086 $ctext conf -state disabled
5091 return [expr {$nr >= 1000? 2: 1}]
5094 proc changediffdisp {} {
5095 global ctext diffelide
5097 $ctext tag conf d0 -elide [lindex $diffelide 0]
5098 $ctext tag conf d1 -elide [lindex $diffelide 1]
5102 global difffilestart ctext
5103 set prev [lindex $difffilestart 0]
5104 set here [$ctext index @0,0]
5105 foreach loc $difffilestart {
5106 if {[$ctext compare $loc >= $here]} {
5116 global difffilestart ctext
5117 set here [$ctext index @0,0]
5118 foreach loc $difffilestart {
5119 if {[$ctext compare $loc > $here]} {
5126 proc clear_ctext {{first 1.0}} {
5127 global ctext smarktop smarkbot
5129 set l [lindex [split $first .] 0]
5130 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5133 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5136 $ctext delete $first end
5139 proc incrsearch {name ix op} {
5140 global ctext searchstring searchdirn
5142 $ctext tag remove found 1.0 end
5143 if {[catch {$ctext index anchor}]} {
5144 # no anchor set, use start of selection, or of visible area
5145 set sel [$ctext tag ranges sel]
5147 $ctext mark set anchor [lindex $sel 0]
5148 } elseif {$searchdirn eq "-forwards"} {
5149 $ctext mark set anchor @0,0
5151 $ctext mark set anchor @0,[winfo height $ctext]
5154 if {$searchstring ne {}} {
5155 set here [$ctext search $searchdirn -- $searchstring anchor]
5164 global sstring ctext searchstring searchdirn
5167 $sstring icursor end
5168 set searchdirn -forwards
5169 if {$searchstring ne {}} {
5170 set sel [$ctext tag ranges sel]
5172 set start "[lindex $sel 0] + 1c"
5173 } elseif {[catch {set start [$ctext index anchor]}]} {
5176 set match [$ctext search -count mlen -- $searchstring $start]
5177 $ctext tag remove sel 1.0 end
5183 set mend "$match + $mlen c"
5184 $ctext tag add sel $match $mend
5185 $ctext mark unset anchor
5189 proc dosearchback {} {
5190 global sstring ctext searchstring searchdirn
5193 $sstring icursor end
5194 set searchdirn -backwards
5195 if {$searchstring ne {}} {
5196 set sel [$ctext tag ranges sel]
5198 set start [lindex $sel 0]
5199 } elseif {[catch {set start [$ctext index anchor]}]} {
5200 set start @0,[winfo height $ctext]
5202 set match [$ctext search -backwards -count ml -- $searchstring $start]
5203 $ctext tag remove sel 1.0 end
5209 set mend "$match + $ml c"
5210 $ctext tag add sel $match $mend
5211 $ctext mark unset anchor
5215 proc searchmark {first last} {
5216 global ctext searchstring
5220 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5221 if {$match eq {}} break
5222 set mend "$match + $mlen c"
5223 $ctext tag add found $match $mend
5227 proc searchmarkvisible {doall} {
5228 global ctext smarktop smarkbot
5230 set topline [lindex [split [$ctext index @0,0] .] 0]
5231 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5232 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5233 # no overlap with previous
5234 searchmark $topline $botline
5235 set smarktop $topline
5236 set smarkbot $botline
5238 if {$topline < $smarktop} {
5239 searchmark $topline [expr {$smarktop-1}]
5240 set smarktop $topline
5242 if {$botline > $smarkbot} {
5243 searchmark [expr {$smarkbot+1}] $botline
5244 set smarkbot $botline
5249 proc scrolltext {f0 f1} {
5252 .bleft.sb set $f0 $f1
5253 if {$searchstring ne {}} {
5259 global linespc charspc canvx0 canvy0 mainfont
5260 global xspc1 xspc2 lthickness
5262 set linespc [font metrics $mainfont -linespace]
5263 set charspc [font measure $mainfont "m"]
5264 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5265 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5266 set lthickness [expr {int($linespc / 9) + 1}]
5267 set xspc1(0) $linespc
5275 set ymax [lindex [$canv cget -scrollregion] 3]
5276 if {$ymax eq {} || $ymax == 0} return
5277 set span [$canv yview]
5280 allcanvs yview moveto [lindex $span 0]
5282 if {[info exists selectedline]} {
5283 selectline $selectedline 0
5284 allcanvs yview moveto [lindex $span 0]
5288 proc incrfont {inc} {
5289 global mainfont textfont ctext canv phase cflist
5290 global charspc tabstop
5291 global stopped entries
5293 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5294 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5296 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5297 $cflist conf -font $textfont
5298 $ctext tag conf filesep -font [concat $textfont bold]
5299 foreach e $entries {
5300 $e conf -font $mainfont
5302 if {$phase eq "getcommits"} {
5303 $canv itemconf textitems -font $mainfont
5309 global sha1entry sha1string
5310 if {[string length $sha1string] == 40} {
5311 $sha1entry delete 0 end
5315 proc sha1change {n1 n2 op} {
5316 global sha1string currentid sha1but
5317 if {$sha1string == {}
5318 || ([info exists currentid] && $sha1string == $currentid)} {
5323 if {[$sha1but cget -state] == $state} return
5324 if {$state == "normal"} {
5325 $sha1but conf -state normal -relief raised -text "Goto: "
5327 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5331 proc gotocommit {} {
5332 global sha1string currentid commitrow tagids headids
5333 global displayorder numcommits curview
5335 if {$sha1string == {}
5336 || ([info exists currentid] && $sha1string == $currentid)} return
5337 if {[info exists tagids($sha1string)]} {
5338 set id $tagids($sha1string)
5339 } elseif {[info exists headids($sha1string)]} {
5340 set id $headids($sha1string)
5342 set id [string tolower $sha1string]
5343 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5345 foreach i $displayorder {
5346 if {[string match $id* $i]} {
5350 if {$matches ne {}} {
5351 if {[llength $matches] > 1} {
5352 error_popup "Short SHA1 id $id is ambiguous"
5355 set id [lindex $matches 0]
5359 if {[info exists commitrow($curview,$id)]} {
5360 selectline $commitrow($curview,$id) 1
5363 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5368 error_popup "$type $sha1string is not known"
5371 proc lineenter {x y id} {
5372 global hoverx hovery hoverid hovertimer
5373 global commitinfo canv
5375 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5379 if {[info exists hovertimer]} {
5380 after cancel $hovertimer
5382 set hovertimer [after 500 linehover]
5386 proc linemotion {x y id} {
5387 global hoverx hovery hoverid hovertimer
5389 if {[info exists hoverid] && $id == $hoverid} {
5392 if {[info exists hovertimer]} {
5393 after cancel $hovertimer
5395 set hovertimer [after 500 linehover]
5399 proc lineleave {id} {
5400 global hoverid hovertimer canv
5402 if {[info exists hoverid] && $id == $hoverid} {
5404 if {[info exists hovertimer]} {
5405 after cancel $hovertimer
5413 global hoverx hovery hoverid hovertimer
5414 global canv linespc lthickness
5415 global commitinfo mainfont
5417 set text [lindex $commitinfo($hoverid) 0]
5418 set ymax [lindex [$canv cget -scrollregion] 3]
5419 if {$ymax == {}} return
5420 set yfrac [lindex [$canv yview] 0]
5421 set x [expr {$hoverx + 2 * $linespc}]
5422 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5423 set x0 [expr {$x - 2 * $lthickness}]
5424 set y0 [expr {$y - 2 * $lthickness}]
5425 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5426 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5427 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5428 -fill \#ffff80 -outline black -width 1 -tags hover]
5430 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5435 proc clickisonarrow {id y} {
5438 set ranges [rowranges $id]
5439 set thresh [expr {2 * $lthickness + 6}]
5440 set n [expr {[llength $ranges] - 1}]
5441 for {set i 1} {$i < $n} {incr i} {
5442 set row [lindex $ranges $i]
5443 if {abs([yc $row] - $y) < $thresh} {
5450 proc arrowjump {id n y} {
5453 # 1 <-> 2, 3 <-> 4, etc...
5454 set n [expr {(($n - 1) ^ 1) + 1}]
5455 set row [lindex [rowranges $id] $n]
5457 set ymax [lindex [$canv cget -scrollregion] 3]
5458 if {$ymax eq {} || $ymax <= 0} return
5459 set view [$canv yview]
5460 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5461 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5465 allcanvs yview moveto $yfrac
5468 proc lineclick {x y id isnew} {
5469 global ctext commitinfo children canv thickerline curview
5471 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5476 # draw this line thicker than normal
5480 set ymax [lindex [$canv cget -scrollregion] 3]
5481 if {$ymax eq {}} return
5482 set yfrac [lindex [$canv yview] 0]
5483 set y [expr {$y + $yfrac * $ymax}]
5485 set dirn [clickisonarrow $id $y]
5487 arrowjump $id $dirn $y
5492 addtohistory [list lineclick $x $y $id 0]
5494 # fill the details pane with info about this line
5495 $ctext conf -state normal
5497 $ctext tag conf link -foreground blue -underline 1
5498 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5499 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5500 $ctext insert end "Parent:\t"
5501 $ctext insert end $id [list link link0]
5502 $ctext tag bind link0 <1> [list selbyid $id]
5503 set info $commitinfo($id)
5504 $ctext insert end "\n\t[lindex $info 0]\n"
5505 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5506 set date [formatdate [lindex $info 2]]
5507 $ctext insert end "\tDate:\t$date\n"
5508 set kids $children($curview,$id)
5510 $ctext insert end "\nChildren:"
5512 foreach child $kids {
5514 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5515 set info $commitinfo($child)
5516 $ctext insert end "\n\t"
5517 $ctext insert end $child [list link link$i]
5518 $ctext tag bind link$i <1> [list selbyid $child]
5519 $ctext insert end "\n\t[lindex $info 0]"
5520 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5521 set date [formatdate [lindex $info 2]]
5522 $ctext insert end "\n\tDate:\t$date\n"
5525 $ctext conf -state disabled
5529 proc normalline {} {
5531 if {[info exists thickerline]} {
5539 global commitrow curview
5540 if {[info exists commitrow($curview,$id)]} {
5541 selectline $commitrow($curview,$id) 1
5547 if {![info exists startmstime]} {
5548 set startmstime [clock clicks -milliseconds]
5550 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5553 proc rowmenu {x y id} {
5554 global rowctxmenu commitrow selectedline rowmenuid curview
5555 global nullid nullid2 fakerowmenu mainhead
5558 if {![info exists selectedline]
5559 || $commitrow($curview,$id) eq $selectedline} {
5564 if {$id ne $nullid && $id ne $nullid2} {
5565 set menu $rowctxmenu
5566 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5568 set menu $fakerowmenu
5570 $menu entryconfigure "Diff this*" -state $state
5571 $menu entryconfigure "Diff selected*" -state $state
5572 $menu entryconfigure "Make patch" -state $state
5573 tk_popup $menu $x $y
5576 proc diffvssel {dirn} {
5577 global rowmenuid selectedline displayorder
5579 if {![info exists selectedline]} return
5581 set oldid [lindex $displayorder $selectedline]
5582 set newid $rowmenuid
5584 set oldid $rowmenuid
5585 set newid [lindex $displayorder $selectedline]
5587 addtohistory [list doseldiff $oldid $newid]
5588 doseldiff $oldid $newid
5591 proc doseldiff {oldid newid} {
5595 $ctext conf -state normal
5598 $ctext insert end "From "
5599 $ctext tag conf link -foreground blue -underline 1
5600 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5601 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5602 $ctext tag bind link0 <1> [list selbyid $oldid]
5603 $ctext insert end $oldid [list link link0]
5604 $ctext insert end "\n "
5605 $ctext insert end [lindex $commitinfo($oldid) 0]
5606 $ctext insert end "\n\nTo "
5607 $ctext tag bind link1 <1> [list selbyid $newid]
5608 $ctext insert end $newid [list link link1]
5609 $ctext insert end "\n "
5610 $ctext insert end [lindex $commitinfo($newid) 0]
5611 $ctext insert end "\n"
5612 $ctext conf -state disabled
5613 $ctext tag remove found 1.0 end
5614 startdiff [list $oldid $newid]
5618 global rowmenuid currentid commitinfo patchtop patchnum
5620 if {![info exists currentid]} return
5621 set oldid $currentid
5622 set oldhead [lindex $commitinfo($oldid) 0]
5623 set newid $rowmenuid
5624 set newhead [lindex $commitinfo($newid) 0]
5627 catch {destroy $top}
5629 label $top.title -text "Generate patch"
5630 grid $top.title - -pady 10
5631 label $top.from -text "From:"
5632 entry $top.fromsha1 -width 40 -relief flat
5633 $top.fromsha1 insert 0 $oldid
5634 $top.fromsha1 conf -state readonly
5635 grid $top.from $top.fromsha1 -sticky w
5636 entry $top.fromhead -width 60 -relief flat
5637 $top.fromhead insert 0 $oldhead
5638 $top.fromhead conf -state readonly
5639 grid x $top.fromhead -sticky w
5640 label $top.to -text "To:"
5641 entry $top.tosha1 -width 40 -relief flat
5642 $top.tosha1 insert 0 $newid
5643 $top.tosha1 conf -state readonly
5644 grid $top.to $top.tosha1 -sticky w
5645 entry $top.tohead -width 60 -relief flat
5646 $top.tohead insert 0 $newhead
5647 $top.tohead conf -state readonly
5648 grid x $top.tohead -sticky w
5649 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5650 grid $top.rev x -pady 10
5651 label $top.flab -text "Output file:"
5652 entry $top.fname -width 60
5653 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5655 grid $top.flab $top.fname -sticky w
5657 button $top.buts.gen -text "Generate" -command mkpatchgo
5658 button $top.buts.can -text "Cancel" -command mkpatchcan
5659 grid $top.buts.gen $top.buts.can
5660 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5661 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5662 grid $top.buts - -pady 10 -sticky ew
5666 proc mkpatchrev {} {
5669 set oldid [$patchtop.fromsha1 get]
5670 set oldhead [$patchtop.fromhead get]
5671 set newid [$patchtop.tosha1 get]
5672 set newhead [$patchtop.tohead get]
5673 foreach e [list fromsha1 fromhead tosha1 tohead] \
5674 v [list $newid $newhead $oldid $oldhead] {
5675 $patchtop.$e conf -state normal
5676 $patchtop.$e delete 0 end
5677 $patchtop.$e insert 0 $v
5678 $patchtop.$e conf -state readonly
5683 global patchtop nullid nullid2
5685 set oldid [$patchtop.fromsha1 get]
5686 set newid [$patchtop.tosha1 get]
5687 set fname [$patchtop.fname get]
5688 set cmd [diffcmd [list $oldid $newid] -p]
5689 lappend cmd >$fname &
5690 if {[catch {eval exec $cmd} err]} {
5691 error_popup "Error creating patch: $err"
5693 catch {destroy $patchtop}
5697 proc mkpatchcan {} {
5700 catch {destroy $patchtop}
5705 global rowmenuid mktagtop commitinfo
5709 catch {destroy $top}
5711 label $top.title -text "Create tag"
5712 grid $top.title - -pady 10
5713 label $top.id -text "ID:"
5714 entry $top.sha1 -width 40 -relief flat
5715 $top.sha1 insert 0 $rowmenuid
5716 $top.sha1 conf -state readonly
5717 grid $top.id $top.sha1 -sticky w
5718 entry $top.head -width 60 -relief flat
5719 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5720 $top.head conf -state readonly
5721 grid x $top.head -sticky w
5722 label $top.tlab -text "Tag name:"
5723 entry $top.tag -width 60
5724 grid $top.tlab $top.tag -sticky w
5726 button $top.buts.gen -text "Create" -command mktaggo
5727 button $top.buts.can -text "Cancel" -command mktagcan
5728 grid $top.buts.gen $top.buts.can
5729 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5730 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5731 grid $top.buts - -pady 10 -sticky ew
5736 global mktagtop env tagids idtags
5738 set id [$mktagtop.sha1 get]
5739 set tag [$mktagtop.tag get]
5741 error_popup "No tag name specified"
5744 if {[info exists tagids($tag)]} {
5745 error_popup "Tag \"$tag\" already exists"
5750 set fname [file join $dir "refs/tags" $tag]
5751 set f [open $fname w]
5755 error_popup "Error creating tag: $err"
5759 set tagids($tag) $id
5760 lappend idtags($id) $tag
5765 proc redrawtags {id} {
5766 global canv linehtag commitrow idpos selectedline curview
5767 global mainfont canvxmax iddrawn
5769 if {![info exists commitrow($curview,$id)]} return
5770 if {![info exists iddrawn($id)]} return
5771 drawcommits $commitrow($curview,$id)
5772 $canv delete tag.$id
5773 set xt [eval drawtags $id $idpos($id)]
5774 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5775 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5776 set xr [expr {$xt + [font measure $mainfont $text]}]
5777 if {$xr > $canvxmax} {
5781 if {[info exists selectedline]
5782 && $selectedline == $commitrow($curview,$id)} {
5783 selectline $selectedline 0
5790 catch {destroy $mktagtop}
5799 proc writecommit {} {
5800 global rowmenuid wrcomtop commitinfo wrcomcmd
5802 set top .writecommit
5804 catch {destroy $top}
5806 label $top.title -text "Write commit to file"
5807 grid $top.title - -pady 10
5808 label $top.id -text "ID:"
5809 entry $top.sha1 -width 40 -relief flat
5810 $top.sha1 insert 0 $rowmenuid
5811 $top.sha1 conf -state readonly
5812 grid $top.id $top.sha1 -sticky w
5813 entry $top.head -width 60 -relief flat
5814 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5815 $top.head conf -state readonly
5816 grid x $top.head -sticky w
5817 label $top.clab -text "Command:"
5818 entry $top.cmd -width 60 -textvariable wrcomcmd
5819 grid $top.clab $top.cmd -sticky w -pady 10
5820 label $top.flab -text "Output file:"
5821 entry $top.fname -width 60
5822 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5823 grid $top.flab $top.fname -sticky w
5825 button $top.buts.gen -text "Write" -command wrcomgo
5826 button $top.buts.can -text "Cancel" -command wrcomcan
5827 grid $top.buts.gen $top.buts.can
5828 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5829 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5830 grid $top.buts - -pady 10 -sticky ew
5837 set id [$wrcomtop.sha1 get]
5838 set cmd "echo $id | [$wrcomtop.cmd get]"
5839 set fname [$wrcomtop.fname get]
5840 if {[catch {exec sh -c $cmd >$fname &} err]} {
5841 error_popup "Error writing commit: $err"
5843 catch {destroy $wrcomtop}
5850 catch {destroy $wrcomtop}
5855 global rowmenuid mkbrtop
5858 catch {destroy $top}
5860 label $top.title -text "Create new branch"
5861 grid $top.title - -pady 10
5862 label $top.id -text "ID:"
5863 entry $top.sha1 -width 40 -relief flat
5864 $top.sha1 insert 0 $rowmenuid
5865 $top.sha1 conf -state readonly
5866 grid $top.id $top.sha1 -sticky w
5867 label $top.nlab -text "Name:"
5868 entry $top.name -width 40
5869 grid $top.nlab $top.name -sticky w
5871 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5872 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5873 grid $top.buts.go $top.buts.can
5874 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5875 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5876 grid $top.buts - -pady 10 -sticky ew
5881 global headids idheads
5883 set name [$top.name get]
5884 set id [$top.sha1 get]
5886 error_popup "Please specify a name for the new branch"
5889 catch {destroy $top}
5893 exec git branch $name $id
5898 set headids($name) $id
5899 lappend idheads($id) $name
5907 proc cherrypick {} {
5908 global rowmenuid curview commitrow
5911 set oldhead [exec git rev-parse HEAD]
5912 set dheads [descheads $rowmenuid]
5913 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5914 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5915 included in branch $mainhead -- really re-apply it?"]
5920 # Unfortunately git-cherry-pick writes stuff to stderr even when
5921 # no error occurs, and exec takes that as an indication of error...
5922 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5927 set newhead [exec git rev-parse HEAD]
5928 if {$newhead eq $oldhead} {
5930 error_popup "No changes committed"
5933 addnewchild $newhead $oldhead
5934 if {[info exists commitrow($curview,$oldhead)]} {
5935 insertrow $commitrow($curview,$oldhead) $newhead
5936 if {$mainhead ne {}} {
5937 movehead $newhead $mainhead
5938 movedhead $newhead $mainhead
5947 global mainheadid mainhead rowmenuid confirm_ok resettype
5948 global showlocalchanges
5951 set w ".confirmreset"
5954 wm title $w "Confirm reset"
5955 message $w.m -text \
5956 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5957 -justify center -aspect 1000
5958 pack $w.m -side top -fill x -padx 20 -pady 20
5959 frame $w.f -relief sunken -border 2
5960 message $w.f.rt -text "Reset type:" -aspect 1000
5961 grid $w.f.rt -sticky w
5963 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5964 -text "Soft: Leave working tree and index untouched"
5965 grid $w.f.soft -sticky w
5966 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5967 -text "Mixed: Leave working tree untouched, reset index"
5968 grid $w.f.mixed -sticky w
5969 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5970 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5971 grid $w.f.hard -sticky w
5972 pack $w.f -side top -fill x
5973 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5974 pack $w.ok -side left -fill x -padx 20 -pady 20
5975 button $w.cancel -text Cancel -command "destroy $w"
5976 pack $w.cancel -side right -fill x -padx 20 -pady 20
5977 bind $w <Visibility> "grab $w; focus $w"
5979 if {!$confirm_ok} return
5980 if {[catch {set fd [open \
5981 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5985 set w ".resetprogress"
5986 filerun $fd [list readresetstat $fd $w]
5989 wm title $w "Reset progress"
5990 message $w.m -text "Reset in progress, please wait..." \
5991 -justify center -aspect 1000
5992 pack $w.m -side top -fill x -padx 20 -pady 5
5993 canvas $w.c -width 150 -height 20 -bg white
5994 $w.c create rect 0 0 0 20 -fill green -tags rect
5995 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6000 proc readresetstat {fd w} {
6001 global mainhead mainheadid showlocalchanges
6003 if {[gets $fd line] >= 0} {
6004 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6005 set x [expr {($m * 150) / $n}]
6006 $w.c coords rect 0 0 $x 20
6012 if {[catch {close $fd} err]} {
6015 set oldhead $mainheadid
6016 set newhead [exec git rev-parse HEAD]
6017 if {$newhead ne $oldhead} {
6018 movehead $newhead $mainhead
6019 movedhead $newhead $mainhead
6020 set mainheadid $newhead
6024 if {$showlocalchanges} {
6030 # context menu for a head
6031 proc headmenu {x y id head} {
6032 global headmenuid headmenuhead headctxmenu mainhead
6035 set headmenuhead $head
6037 if {$head eq $mainhead} {
6040 $headctxmenu entryconfigure 0 -state $state
6041 $headctxmenu entryconfigure 1 -state $state
6042 tk_popup $headctxmenu $x $y
6046 global headmenuid headmenuhead mainhead headids
6047 global showlocalchanges mainheadid
6049 # check the tree is clean first??
6050 set oldmainhead $mainhead
6055 exec git checkout -q $headmenuhead
6061 set mainhead $headmenuhead
6062 set mainheadid $headmenuid
6063 if {[info exists headids($oldmainhead)]} {
6064 redrawtags $headids($oldmainhead)
6066 redrawtags $headmenuid
6068 if {$showlocalchanges} {
6074 global headmenuid headmenuhead mainhead
6075 global headids idheads
6077 set head $headmenuhead
6079 # this check shouldn't be needed any more...
6080 if {$head eq $mainhead} {
6081 error_popup "Cannot delete the currently checked-out branch"
6084 set dheads [descheads $id]
6085 if {$dheads eq $headids($head)} {
6086 # the stuff on this branch isn't on any other branch
6087 if {![confirm_popup "The commits on branch $head aren't on any other\
6088 branch.\nReally delete branch $head?"]} return
6092 if {[catch {exec git branch -D $head} err]} {
6097 removehead $id $head
6098 removedhead $id $head
6104 # Stuff for finding nearby tags
6105 proc getallcommits {} {
6106 global allcommits allids nbmp nextarc seeds
6116 # Called when the graph might have changed
6117 proc regetallcommits {} {
6118 global allcommits seeds
6120 set cmd [concat | git rev-list --all --parents]
6124 set fd [open $cmd r]
6125 fconfigure $fd -blocking 0
6128 filerun $fd [list getallclines $fd]
6131 # Since most commits have 1 parent and 1 child, we group strings of
6132 # such commits into "arcs" joining branch/merge points (BMPs), which
6133 # are commits that either don't have 1 parent or don't have 1 child.
6135 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6136 # arcout(id) - outgoing arcs for BMP
6137 # arcids(a) - list of IDs on arc including end but not start
6138 # arcstart(a) - BMP ID at start of arc
6139 # arcend(a) - BMP ID at end of arc
6140 # growing(a) - arc a is still growing
6141 # arctags(a) - IDs out of arcids (excluding end) that have tags
6142 # archeads(a) - IDs out of arcids (excluding end) that have heads
6143 # The start of an arc is at the descendent end, so "incoming" means
6144 # coming from descendents, and "outgoing" means going towards ancestors.
6146 proc getallclines {fd} {
6147 global allids allparents allchildren idtags idheads nextarc nbmp
6148 global arcnos arcids arctags arcout arcend arcstart archeads growing
6149 global seeds allcommits
6152 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6153 set id [lindex $line 0]
6154 if {[info exists allparents($id)]} {
6159 set olds [lrange $line 1 end]
6160 set allparents($id) $olds
6161 if {![info exists allchildren($id)]} {
6162 set allchildren($id) {}
6167 if {[llength $olds] == 1 && [llength $a] == 1} {
6168 lappend arcids($a) $id
6169 if {[info exists idtags($id)]} {
6170 lappend arctags($a) $id
6172 if {[info exists idheads($id)]} {
6173 lappend archeads($a) $id
6175 if {[info exists allparents($olds)]} {
6176 # seen parent already
6177 if {![info exists arcout($olds)]} {
6180 lappend arcids($a) $olds
6181 set arcend($a) $olds
6184 lappend allchildren($olds) $id
6185 lappend arcnos($olds) $a
6190 foreach a $arcnos($id) {
6191 lappend arcids($a) $id
6198 lappend allchildren($p) $id
6199 set a [incr nextarc]
6200 set arcstart($a) $id
6207 if {[info exists allparents($p)]} {
6208 # seen it already, may need to make a new branch
6209 if {![info exists arcout($p)]} {
6212 lappend arcids($a) $p
6216 lappend arcnos($p) $a
6221 global cached_dheads cached_dtags cached_atags
6222 catch {unset cached_dheads}
6223 catch {unset cached_dtags}
6224 catch {unset cached_atags}
6227 return [expr {$nid >= 1000? 2: 1}]
6230 if {[incr allcommits -1] == 0} {
6237 proc recalcarc {a} {
6238 global arctags archeads arcids idtags idheads
6242 foreach id [lrange $arcids($a) 0 end-1] {
6243 if {[info exists idtags($id)]} {
6246 if {[info exists idheads($id)]} {
6251 set archeads($a) $ah
6255 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6256 global arcstart arcend arcout allparents growing
6259 if {[llength $a] != 1} {
6260 puts "oops splitarc called but [llength $a] arcs already"
6264 set i [lsearch -exact $arcids($a) $p]
6266 puts "oops splitarc $p not in arc $a"
6269 set na [incr nextarc]
6270 if {[info exists arcend($a)]} {
6271 set arcend($na) $arcend($a)
6273 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6274 set j [lsearch -exact $arcnos($l) $a]
6275 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6277 set tail [lrange $arcids($a) [expr {$i+1}] end]
6278 set arcids($a) [lrange $arcids($a) 0 $i]
6280 set arcstart($na) $p
6282 set arcids($na) $tail
6283 if {[info exists growing($a)]} {
6290 if {[llength $arcnos($id)] == 1} {
6293 set j [lsearch -exact $arcnos($id) $a]
6294 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6298 # reconstruct tags and heads lists
6299 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6304 set archeads($na) {}
6308 # Update things for a new commit added that is a child of one
6309 # existing commit. Used when cherry-picking.
6310 proc addnewchild {id p} {
6311 global allids allparents allchildren idtags nextarc nbmp
6312 global arcnos arcids arctags arcout arcend arcstart archeads growing
6316 set allparents($id) [list $p]
6317 set allchildren($id) {}
6321 lappend allchildren($p) $id
6322 set a [incr nextarc]
6323 set arcstart($a) $id
6326 set arcids($a) [list $p]
6328 if {![info exists arcout($p)]} {
6331 lappend arcnos($p) $a
6332 set arcout($id) [list $a]
6335 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6336 # or 0 if neither is true.
6337 proc anc_or_desc {a b} {
6338 global arcout arcstart arcend arcnos cached_isanc
6340 if {$arcnos($a) eq $arcnos($b)} {
6341 # Both are on the same arc(s); either both are the same BMP,
6342 # or if one is not a BMP, the other is also not a BMP or is
6343 # the BMP at end of the arc (and it only has 1 incoming arc).
6344 # Or both can be BMPs with no incoming arcs.
6345 if {$a eq $b || $arcnos($a) eq {}} {
6348 # assert {[llength $arcnos($a)] == 1}
6349 set arc [lindex $arcnos($a) 0]
6350 set i [lsearch -exact $arcids($arc) $a]
6351 set j [lsearch -exact $arcids($arc) $b]
6352 if {$i < 0 || $i > $j} {
6359 if {![info exists arcout($a)]} {
6360 set arc [lindex $arcnos($a) 0]
6361 if {[info exists arcend($arc)]} {
6362 set aend $arcend($arc)
6366 set a $arcstart($arc)
6370 if {![info exists arcout($b)]} {
6371 set arc [lindex $arcnos($b) 0]
6372 if {[info exists arcend($arc)]} {
6373 set bend $arcend($arc)
6377 set b $arcstart($arc)
6387 if {[info exists cached_isanc($a,$bend)]} {
6388 if {$cached_isanc($a,$bend)} {
6392 if {[info exists cached_isanc($b,$aend)]} {
6393 if {$cached_isanc($b,$aend)} {
6396 if {[info exists cached_isanc($a,$bend)]} {
6401 set todo [list $a $b]
6404 for {set i 0} {$i < [llength $todo]} {incr i} {
6405 set x [lindex $todo $i]
6406 if {$anc($x) eq {}} {
6409 foreach arc $arcnos($x) {
6410 set xd $arcstart($arc)
6412 set cached_isanc($a,$bend) 1
6413 set cached_isanc($b,$aend) 0
6415 } elseif {$xd eq $aend} {
6416 set cached_isanc($b,$aend) 1
6417 set cached_isanc($a,$bend) 0
6420 if {![info exists anc($xd)]} {
6421 set anc($xd) $anc($x)
6423 } elseif {$anc($xd) ne $anc($x)} {
6428 set cached_isanc($a,$bend) 0
6429 set cached_isanc($b,$aend) 0
6433 # This identifies whether $desc has an ancestor that is
6434 # a growing tip of the graph and which is not an ancestor of $anc
6435 # and returns 0 if so and 1 if not.
6436 # If we subsequently discover a tag on such a growing tip, and that
6437 # turns out to be a descendent of $anc (which it could, since we
6438 # don't necessarily see children before parents), then $desc
6439 # isn't a good choice to display as a descendent tag of
6440 # $anc (since it is the descendent of another tag which is
6441 # a descendent of $anc). Similarly, $anc isn't a good choice to
6442 # display as a ancestor tag of $desc.
6444 proc is_certain {desc anc} {
6445 global arcnos arcout arcstart arcend growing problems
6448 if {[llength $arcnos($anc)] == 1} {
6449 # tags on the same arc are certain
6450 if {$arcnos($desc) eq $arcnos($anc)} {
6453 if {![info exists arcout($anc)]} {
6454 # if $anc is partway along an arc, use the start of the arc instead
6455 set a [lindex $arcnos($anc) 0]
6456 set anc $arcstart($a)
6459 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6462 set a [lindex $arcnos($desc) 0]
6468 set anclist [list $x]
6472 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6473 set x [lindex $anclist $i]
6478 foreach a $arcout($x) {
6479 if {[info exists growing($a)]} {
6480 if {![info exists growanc($x)] && $dl($x)} {
6486 if {[info exists dl($y)]} {
6490 if {![info exists done($y)]} {
6493 if {[info exists growanc($x)]} {
6497 for {set k 0} {$k < [llength $xl]} {incr k} {
6498 set z [lindex $xl $k]
6499 foreach c $arcout($z) {
6500 if {[info exists arcend($c)]} {
6502 if {[info exists dl($v)] && $dl($v)} {
6504 if {![info exists done($v)]} {
6507 if {[info exists growanc($v)]} {
6517 } elseif {$y eq $anc || !$dl($x)} {
6528 foreach x [array names growanc] {
6537 proc validate_arctags {a} {
6538 global arctags idtags
6542 foreach id $arctags($a) {
6544 if {![info exists idtags($id)]} {
6545 set na [lreplace $na $i $i]
6552 proc validate_archeads {a} {
6553 global archeads idheads
6556 set na $archeads($a)
6557 foreach id $archeads($a) {
6559 if {![info exists idheads($id)]} {
6560 set na [lreplace $na $i $i]
6564 set archeads($a) $na
6567 # Return the list of IDs that have tags that are descendents of id,
6568 # ignoring IDs that are descendents of IDs already reported.
6569 proc desctags {id} {
6570 global arcnos arcstart arcids arctags idtags allparents
6571 global growing cached_dtags
6573 if {![info exists allparents($id)]} {
6576 set t1 [clock clicks -milliseconds]
6578 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6579 # part-way along an arc; check that arc first
6580 set a [lindex $arcnos($id) 0]
6581 if {$arctags($a) ne {}} {
6583 set i [lsearch -exact $arcids($a) $id]
6585 foreach t $arctags($a) {
6586 set j [lsearch -exact $arcids($a) $t]
6594 set id $arcstart($a)
6595 if {[info exists idtags($id)]} {
6599 if {[info exists cached_dtags($id)]} {
6600 return $cached_dtags($id)
6607 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6608 set id [lindex $todo $i]
6610 set ta [info exists hastaggedancestor($id)]
6614 # ignore tags on starting node
6615 if {!$ta && $i > 0} {
6616 if {[info exists idtags($id)]} {
6619 } elseif {[info exists cached_dtags($id)]} {
6620 set tagloc($id) $cached_dtags($id)
6624 foreach a $arcnos($id) {
6626 if {!$ta && $arctags($a) ne {}} {
6628 if {$arctags($a) ne {}} {
6629 lappend tagloc($id) [lindex $arctags($a) end]
6632 if {$ta || $arctags($a) ne {}} {
6633 set tomark [list $d]
6634 for {set j 0} {$j < [llength $tomark]} {incr j} {
6635 set dd [lindex $tomark $j]
6636 if {![info exists hastaggedancestor($dd)]} {
6637 if {[info exists done($dd)]} {
6638 foreach b $arcnos($dd) {
6639 lappend tomark $arcstart($b)
6641 if {[info exists tagloc($dd)]} {
6644 } elseif {[info exists queued($dd)]} {
6647 set hastaggedancestor($dd) 1
6651 if {![info exists queued($d)]} {
6654 if {![info exists hastaggedancestor($d)]} {
6661 foreach id [array names tagloc] {
6662 if {![info exists hastaggedancestor($id)]} {
6663 foreach t $tagloc($id) {
6664 if {[lsearch -exact $tags $t] < 0} {
6670 set t2 [clock clicks -milliseconds]
6673 # remove tags that are descendents of other tags
6674 for {set i 0} {$i < [llength $tags]} {incr i} {
6675 set a [lindex $tags $i]
6676 for {set j 0} {$j < $i} {incr j} {
6677 set b [lindex $tags $j]
6678 set r [anc_or_desc $a $b]
6680 set tags [lreplace $tags $j $j]
6683 } elseif {$r == -1} {
6684 set tags [lreplace $tags $i $i]
6691 if {[array names growing] ne {}} {
6692 # graph isn't finished, need to check if any tag could get
6693 # eclipsed by another tag coming later. Simply ignore any
6694 # tags that could later get eclipsed.
6697 if {[is_certain $t $origid]} {
6701 if {$tags eq $ctags} {
6702 set cached_dtags($origid) $tags
6707 set cached_dtags($origid) $tags
6709 set t3 [clock clicks -milliseconds]
6710 if {0 && $t3 - $t1 >= 100} {
6711 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6712 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6718 global arcnos arcids arcout arcend arctags idtags allparents
6719 global growing cached_atags
6721 if {![info exists allparents($id)]} {
6724 set t1 [clock clicks -milliseconds]
6726 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6727 # part-way along an arc; check that arc first
6728 set a [lindex $arcnos($id) 0]
6729 if {$arctags($a) ne {}} {
6731 set i [lsearch -exact $arcids($a) $id]
6732 foreach t $arctags($a) {
6733 set j [lsearch -exact $arcids($a) $t]
6739 if {![info exists arcend($a)]} {
6743 if {[info exists idtags($id)]} {
6747 if {[info exists cached_atags($id)]} {
6748 return $cached_atags($id)
6756 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6757 set id [lindex $todo $i]
6759 set td [info exists hastaggeddescendent($id)]
6763 # ignore tags on starting node
6764 if {!$td && $i > 0} {
6765 if {[info exists idtags($id)]} {
6768 } elseif {[info exists cached_atags($id)]} {
6769 set tagloc($id) $cached_atags($id)
6773 foreach a $arcout($id) {
6774 if {!$td && $arctags($a) ne {}} {
6776 if {$arctags($a) ne {}} {
6777 lappend tagloc($id) [lindex $arctags($a) 0]
6780 if {![info exists arcend($a)]} continue
6782 if {$td || $arctags($a) ne {}} {
6783 set tomark [list $d]
6784 for {set j 0} {$j < [llength $tomark]} {incr j} {
6785 set dd [lindex $tomark $j]
6786 if {![info exists hastaggeddescendent($dd)]} {
6787 if {[info exists done($dd)]} {
6788 foreach b $arcout($dd) {
6789 if {[info exists arcend($b)]} {
6790 lappend tomark $arcend($b)
6793 if {[info exists tagloc($dd)]} {
6796 } elseif {[info exists queued($dd)]} {
6799 set hastaggeddescendent($dd) 1
6803 if {![info exists queued($d)]} {
6806 if {![info exists hastaggeddescendent($d)]} {
6812 set t2 [clock clicks -milliseconds]
6815 foreach id [array names tagloc] {
6816 if {![info exists hastaggeddescendent($id)]} {
6817 foreach t $tagloc($id) {
6818 if {[lsearch -exact $tags $t] < 0} {
6825 # remove tags that are ancestors of other tags
6826 for {set i 0} {$i < [llength $tags]} {incr i} {
6827 set a [lindex $tags $i]
6828 for {set j 0} {$j < $i} {incr j} {
6829 set b [lindex $tags $j]
6830 set r [anc_or_desc $a $b]
6832 set tags [lreplace $tags $j $j]
6835 } elseif {$r == 1} {
6836 set tags [lreplace $tags $i $i]
6843 if {[array names growing] ne {}} {
6844 # graph isn't finished, need to check if any tag could get
6845 # eclipsed by another tag coming later. Simply ignore any
6846 # tags that could later get eclipsed.
6849 if {[is_certain $origid $t]} {
6853 if {$tags eq $ctags} {
6854 set cached_atags($origid) $tags
6859 set cached_atags($origid) $tags
6861 set t3 [clock clicks -milliseconds]
6862 if {0 && $t3 - $t1 >= 100} {
6863 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6864 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6869 # Return the list of IDs that have heads that are descendents of id,
6870 # including id itself if it has a head.
6871 proc descheads {id} {
6872 global arcnos arcstart arcids archeads idheads cached_dheads
6875 if {![info exists allparents($id)]} {
6879 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6880 # part-way along an arc; check it first
6881 set a [lindex $arcnos($id) 0]
6882 if {$archeads($a) ne {}} {
6883 validate_archeads $a
6884 set i [lsearch -exact $arcids($a) $id]
6885 foreach t $archeads($a) {
6886 set j [lsearch -exact $arcids($a) $t]
6891 set id $arcstart($a)
6897 for {set i 0} {$i < [llength $todo]} {incr i} {
6898 set id [lindex $todo $i]
6899 if {[info exists cached_dheads($id)]} {
6900 set ret [concat $ret $cached_dheads($id)]
6902 if {[info exists idheads($id)]} {
6905 foreach a $arcnos($id) {
6906 if {$archeads($a) ne {}} {
6907 validate_archeads $a
6908 if {$archeads($a) ne {}} {
6909 set ret [concat $ret $archeads($a)]
6913 if {![info exists seen($d)]} {
6920 set ret [lsort -unique $ret]
6921 set cached_dheads($origid) $ret
6922 return [concat $ret $aret]
6925 proc addedtag {id} {
6926 global arcnos arcout cached_dtags cached_atags
6928 if {![info exists arcnos($id)]} return
6929 if {![info exists arcout($id)]} {
6930 recalcarc [lindex $arcnos($id) 0]
6932 catch {unset cached_dtags}
6933 catch {unset cached_atags}
6936 proc addedhead {hid head} {
6937 global arcnos arcout cached_dheads
6939 if {![info exists arcnos($hid)]} return
6940 if {![info exists arcout($hid)]} {
6941 recalcarc [lindex $arcnos($hid) 0]
6943 catch {unset cached_dheads}
6946 proc removedhead {hid head} {
6947 global cached_dheads
6949 catch {unset cached_dheads}
6952 proc movedhead {hid head} {
6953 global arcnos arcout cached_dheads
6955 if {![info exists arcnos($hid)]} return
6956 if {![info exists arcout($hid)]} {
6957 recalcarc [lindex $arcnos($hid) 0]
6959 catch {unset cached_dheads}
6962 proc changedrefs {} {
6963 global cached_dheads cached_dtags cached_atags
6964 global arctags archeads arcnos arcout idheads idtags
6966 foreach id [concat [array names idheads] [array names idtags]] {
6967 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6968 set a [lindex $arcnos($id) 0]
6969 if {![info exists donearc($a)]} {
6975 catch {unset cached_dtags}
6976 catch {unset cached_atags}
6977 catch {unset cached_dheads}
6980 proc rereadrefs {} {
6981 global idtags idheads idotherrefs mainhead
6983 set refids [concat [array names idtags] \
6984 [array names idheads] [array names idotherrefs]]
6985 foreach id $refids {
6986 if {![info exists ref($id)]} {
6987 set ref($id) [listrefs $id]
6990 set oldmainhead $mainhead
6993 set refids [lsort -unique [concat $refids [array names idtags] \
6994 [array names idheads] [array names idotherrefs]]]
6995 foreach id $refids {
6996 set v [listrefs $id]
6997 if {![info exists ref($id)] || $ref($id) != $v ||
6998 ($id eq $oldmainhead && $id ne $mainhead) ||
6999 ($id eq $mainhead && $id ne $oldmainhead)} {
7005 proc listrefs {id} {
7006 global idtags idheads idotherrefs
7009 if {[info exists idtags($id)]} {
7013 if {[info exists idheads($id)]} {
7017 if {[info exists idotherrefs($id)]} {
7018 set z $idotherrefs($id)
7020 return [list $x $y $z]
7023 proc showtag {tag isnew} {
7024 global ctext tagcontents tagids linknum tagobjid
7027 addtohistory [list showtag $tag 0]
7029 $ctext conf -state normal
7032 if {![info exists tagcontents($tag)]} {
7034 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7037 if {[info exists tagcontents($tag)]} {
7038 set text $tagcontents($tag)
7040 set text "Tag: $tag\nId: $tagids($tag)"
7042 appendwithlinks $text {}
7043 $ctext conf -state disabled
7055 global maxwidth maxgraphpct diffopts
7056 global oldprefs prefstop showneartags showlocalchanges
7057 global bgcolor fgcolor ctext diffcolors selectbgcolor
7058 global uifont tabstop
7062 if {[winfo exists $top]} {
7066 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7067 set oldprefs($v) [set $v]
7070 wm title $top "Gitk preferences"
7071 label $top.ldisp -text "Commit list display options"
7072 $top.ldisp configure -font $uifont
7073 grid $top.ldisp - -sticky w -pady 10
7074 label $top.spacer -text " "
7075 label $top.maxwidthl -text "Maximum graph width (lines)" \
7077 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7078 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7079 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7081 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7082 grid x $top.maxpctl $top.maxpct -sticky w
7083 frame $top.showlocal
7084 label $top.showlocal.l -text "Show local changes" -font optionfont
7085 checkbutton $top.showlocal.b -variable showlocalchanges
7086 pack $top.showlocal.b $top.showlocal.l -side left
7087 grid x $top.showlocal -sticky w
7089 label $top.ddisp -text "Diff display options"
7090 $top.ddisp configure -font $uifont
7091 grid $top.ddisp - -sticky w -pady 10
7092 label $top.diffoptl -text "Options for diff program" \
7094 entry $top.diffopt -width 20 -textvariable diffopts
7095 grid x $top.diffoptl $top.diffopt -sticky w
7097 label $top.ntag.l -text "Display nearby tags" -font optionfont
7098 checkbutton $top.ntag.b -variable showneartags
7099 pack $top.ntag.b $top.ntag.l -side left
7100 grid x $top.ntag -sticky w
7101 label $top.tabstopl -text "tabstop" -font optionfont
7102 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7103 grid x $top.tabstopl $top.tabstop -sticky w
7105 label $top.cdisp -text "Colors: press to choose"
7106 $top.cdisp configure -font $uifont
7107 grid $top.cdisp - -sticky w -pady 10
7108 label $top.bg -padx 40 -relief sunk -background $bgcolor
7109 button $top.bgbut -text "Background" -font optionfont \
7110 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7111 grid x $top.bgbut $top.bg -sticky w
7112 label $top.fg -padx 40 -relief sunk -background $fgcolor
7113 button $top.fgbut -text "Foreground" -font optionfont \
7114 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7115 grid x $top.fgbut $top.fg -sticky w
7116 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7117 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7118 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7119 [list $ctext tag conf d0 -foreground]]
7120 grid x $top.diffoldbut $top.diffold -sticky w
7121 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7122 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7123 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7124 [list $ctext tag conf d1 -foreground]]
7125 grid x $top.diffnewbut $top.diffnew -sticky w
7126 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7127 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7128 -command [list choosecolor diffcolors 2 $top.hunksep \
7129 "diff hunk header" \
7130 [list $ctext tag conf hunksep -foreground]]
7131 grid x $top.hunksepbut $top.hunksep -sticky w
7132 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7133 button $top.selbgbut -text "Select bg" -font optionfont \
7134 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7135 grid x $top.selbgbut $top.selbgsep -sticky w
7138 button $top.buts.ok -text "OK" -command prefsok -default active
7139 $top.buts.ok configure -font $uifont
7140 button $top.buts.can -text "Cancel" -command prefscan -default normal
7141 $top.buts.can configure -font $uifont
7142 grid $top.buts.ok $top.buts.can
7143 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7144 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7145 grid $top.buts - - -pady 10 -sticky ew
7146 bind $top <Visibility> "focus $top.buts.ok"
7149 proc choosecolor {v vi w x cmd} {
7152 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7153 -title "Gitk: choose color for $x"]
7154 if {$c eq {}} return
7155 $w conf -background $c
7161 global bglist cflist
7163 $w configure -selectbackground $c
7165 $cflist tag configure highlight \
7166 -background [$cflist cget -selectbackground]
7167 allcanvs itemconf secsel -fill $c
7174 $w conf -background $c
7182 $w conf -foreground $c
7184 allcanvs itemconf text -fill $c
7185 $canv itemconf circle -outline $c
7189 global maxwidth maxgraphpct diffopts
7190 global oldprefs prefstop showneartags showlocalchanges
7192 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7193 set $v $oldprefs($v)
7195 catch {destroy $prefstop}
7200 global maxwidth maxgraphpct
7201 global oldprefs prefstop showneartags showlocalchanges
7202 global charspc ctext tabstop
7204 catch {destroy $prefstop}
7206 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7207 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7208 if {$showlocalchanges} {
7214 if {$maxwidth != $oldprefs(maxwidth)
7215 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7217 } elseif {$showneartags != $oldprefs(showneartags)} {
7222 proc formatdate {d} {
7224 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7229 # This list of encoding names and aliases is distilled from
7230 # http://www.iana.org/assignments/character-sets.
7231 # Not all of them are supported by Tcl.
7232 set encoding_aliases {
7233 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7234 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7235 { ISO-10646-UTF-1 csISO10646UTF1 }
7236 { ISO_646.basic:1983 ref csISO646basic1983 }
7237 { INVARIANT csINVARIANT }
7238 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7239 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7240 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7241 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7242 { NATS-DANO iso-ir-9-1 csNATSDANO }
7243 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7244 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7245 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7246 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7247 { ISO-2022-KR csISO2022KR }
7249 { ISO-2022-JP csISO2022JP }
7250 { ISO-2022-JP-2 csISO2022JP2 }
7251 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7253 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7254 { IT iso-ir-15 ISO646-IT csISO15Italian }
7255 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7256 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7257 { greek7-old iso-ir-18 csISO18Greek7Old }
7258 { latin-greek iso-ir-19 csISO19LatinGreek }
7259 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7260 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7261 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7262 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7263 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7264 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7265 { INIS iso-ir-49 csISO49INIS }
7266 { INIS-8 iso-ir-50 csISO50INIS8 }
7267 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7268 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7269 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7270 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7271 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7272 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7274 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7275 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7276 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7277 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7278 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7279 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7280 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7281 { greek7 iso-ir-88 csISO88Greek7 }
7282 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7283 { iso-ir-90 csISO90 }
7284 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7285 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7286 csISO92JISC62991984b }
7287 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7288 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7289 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7290 csISO95JIS62291984handadd }
7291 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7292 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7293 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7294 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7296 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7297 { T.61-7bit iso-ir-102 csISO102T617bit }
7298 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7299 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7300 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7301 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7302 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7303 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7304 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7305 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7306 arabic csISOLatinArabic }
7307 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7308 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7309 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7310 greek greek8 csISOLatinGreek }
7311 { T.101-G2 iso-ir-128 csISO128T101G2 }
7312 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7314 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7315 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7316 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7317 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7318 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7319 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7320 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7321 csISOLatinCyrillic }
7322 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7323 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7324 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7325 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7326 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7327 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7328 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7329 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7330 { ISO_10367-box iso-ir-155 csISO10367Box }
7331 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7332 { latin-lap lap iso-ir-158 csISO158Lap }
7333 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7334 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7337 { JIS_X0201 X0201 csHalfWidthKatakana }
7338 { KSC5636 ISO646-KR csKSC5636 }
7339 { ISO-10646-UCS-2 csUnicode }
7340 { ISO-10646-UCS-4 csUCS4 }
7341 { DEC-MCS dec csDECMCS }
7342 { hp-roman8 roman8 r8 csHPRoman8 }
7343 { macintosh mac csMacintosh }
7344 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7346 { IBM038 EBCDIC-INT cp038 csIBM038 }
7347 { IBM273 CP273 csIBM273 }
7348 { IBM274 EBCDIC-BE CP274 csIBM274 }
7349 { IBM275 EBCDIC-BR cp275 csIBM275 }
7350 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7351 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7352 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7353 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7354 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7355 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7356 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7357 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7358 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7359 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7360 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7361 { IBM437 cp437 437 csPC8CodePage437 }
7362 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7363 { IBM775 cp775 csPC775Baltic }
7364 { IBM850 cp850 850 csPC850Multilingual }
7365 { IBM851 cp851 851 csIBM851 }
7366 { IBM852 cp852 852 csPCp852 }
7367 { IBM855 cp855 855 csIBM855 }
7368 { IBM857 cp857 857 csIBM857 }
7369 { IBM860 cp860 860 csIBM860 }
7370 { IBM861 cp861 861 cp-is csIBM861 }
7371 { IBM862 cp862 862 csPC862LatinHebrew }
7372 { IBM863 cp863 863 csIBM863 }
7373 { IBM864 cp864 csIBM864 }
7374 { IBM865 cp865 865 csIBM865 }
7375 { IBM866 cp866 866 csIBM866 }
7376 { IBM868 CP868 cp-ar csIBM868 }
7377 { IBM869 cp869 869 cp-gr csIBM869 }
7378 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7379 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7380 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7381 { IBM891 cp891 csIBM891 }
7382 { IBM903 cp903 csIBM903 }
7383 { IBM904 cp904 904 csIBBM904 }
7384 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7385 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7386 { IBM1026 CP1026 csIBM1026 }
7387 { EBCDIC-AT-DE csIBMEBCDICATDE }
7388 { EBCDIC-AT-DE-A csEBCDICATDEA }
7389 { EBCDIC-CA-FR csEBCDICCAFR }
7390 { EBCDIC-DK-NO csEBCDICDKNO }
7391 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7392 { EBCDIC-FI-SE csEBCDICFISE }
7393 { EBCDIC-FI-SE-A csEBCDICFISEA }
7394 { EBCDIC-FR csEBCDICFR }
7395 { EBCDIC-IT csEBCDICIT }
7396 { EBCDIC-PT csEBCDICPT }
7397 { EBCDIC-ES csEBCDICES }
7398 { EBCDIC-ES-A csEBCDICESA }
7399 { EBCDIC-ES-S csEBCDICESS }
7400 { EBCDIC-UK csEBCDICUK }
7401 { EBCDIC-US csEBCDICUS }
7402 { UNKNOWN-8BIT csUnknown8BiT }
7403 { MNEMONIC csMnemonic }
7408 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7409 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7410 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7411 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7412 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7413 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7414 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7415 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7416 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7417 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7418 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7419 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7420 { IBM1047 IBM-1047 }
7421 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7422 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7423 { UNICODE-1-1 csUnicode11 }
7426 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7427 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7429 { ISO-8859-15 ISO_8859-15 Latin-9 }
7430 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7431 { GBK CP936 MS936 windows-936 }
7432 { JIS_Encoding csJISEncoding }
7433 { Shift_JIS MS_Kanji csShiftJIS }
7434 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7436 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7437 { ISO-10646-UCS-Basic csUnicodeASCII }
7438 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7439 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7440 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7441 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7442 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7443 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7444 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7445 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7446 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7447 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7448 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7449 { Ventura-US csVenturaUS }
7450 { Ventura-International csVenturaInternational }
7451 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7452 { PC8-Turkish csPC8Turkish }
7453 { IBM-Symbols csIBMSymbols }
7454 { IBM-Thai csIBMThai }
7455 { HP-Legal csHPLegal }
7456 { HP-Pi-font csHPPiFont }
7457 { HP-Math8 csHPMath8 }
7458 { Adobe-Symbol-Encoding csHPPSMath }
7459 { HP-DeskTop csHPDesktop }
7460 { Ventura-Math csVenturaMath }
7461 { Microsoft-Publishing csMicrosoftPublishing }
7462 { Windows-31J csWindows31J }
7467 proc tcl_encoding {enc} {
7468 global encoding_aliases
7469 set names [encoding names]
7470 set lcnames [string tolower $names]
7471 set enc [string tolower $enc]
7472 set i [lsearch -exact $lcnames $enc]
7474 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7475 if {[regsub {^iso[-_]} $enc iso encx]} {
7476 set i [lsearch -exact $lcnames $encx]
7480 foreach l $encoding_aliases {
7481 set ll [string tolower $l]
7482 if {[lsearch -exact $ll $enc] < 0} continue
7483 # look through the aliases for one that tcl knows about
7485 set i [lsearch -exact $lcnames $e]
7487 if {[regsub {^iso[-_]} $e iso ex]} {
7488 set i [lsearch -exact $lcnames $ex]
7497 return [lindex $names $i]
7504 set diffopts "-U 5 -p"
7505 set wrcomcmd "git diff-tree --stdin -p --pretty"
7509 set gitencoding [exec git config --get i18n.commitencoding]
7511 if {$gitencoding == ""} {
7512 set gitencoding "utf-8"
7514 set tclencoding [tcl_encoding $gitencoding]
7515 if {$tclencoding == {}} {
7516 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7519 set mainfont {Helvetica 9}
7520 set textfont {Courier 9}
7521 set uifont {Helvetica 9 bold}
7523 set findmergefiles 0
7531 set cmitmode "patch"
7532 set wrapcomment "none"
7536 set showlocalchanges 1
7538 set colors {green red blue magenta darkgrey brown orange}
7541 set diffcolors {red "#00a000" blue}
7542 set selectbgcolor gray85
7544 catch {source ~/.gitk}
7546 font create optionfont -family sans-serif -size -12
7548 # check that we can find a .git directory somewhere...
7550 if {![file isdirectory $gitdir]} {
7551 show_error {} . "Cannot find the git directory \"$gitdir\"."
7556 set cmdline_files {}
7561 "-d" { set datemode 1 }
7563 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7567 lappend revtreeargs $arg
7573 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7574 # no -- on command line, but some arguments (other than -d)
7576 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7577 set cmdline_files [split $f "\n"]
7578 set n [llength $cmdline_files]
7579 set revtreeargs [lrange $revtreeargs 0 end-$n]
7580 # Unfortunately git rev-parse doesn't produce an error when
7581 # something is both a revision and a filename. To be consistent
7582 # with git log and git rev-list, check revtreeargs for filenames.
7583 foreach arg $revtreeargs {
7584 if {[file exists $arg]} {
7585 show_error {} . "Ambiguous argument '$arg': both revision\
7591 # unfortunately we get both stdout and stderr in $err,
7592 # so look for "fatal:".
7593 set i [string first "fatal:" $err]
7595 set err [string range $err [expr {$i + 6}] end]
7597 show_error {} . "Bad arguments to gitk:\n$err"
7602 set nullid "0000000000000000000000000000000000000000"
7603 set nullid2 "0000000000000000000000000000000000000001"
7611 set highlight_paths {}
7612 set searchdirn -forwards
7616 set markingmatches 0
7623 set selectedhlview None
7632 set lookingforhead 0
7638 wm title . "[file tail $argv0]: [file tail [pwd]]"
7641 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7642 # create a view for the files/dirs specified on the command line
7646 set viewname(1) "Command line"
7647 set viewfiles(1) $cmdline_files
7648 set viewargs(1) $revtreeargs
7651 .bar.view entryconf Edit* -state normal
7652 .bar.view entryconf Delete* -state normal
7655 if {[info exists permviews]} {
7656 foreach v $permviews {
7659 set viewname($n) [lindex $v 0]
7660 set viewfiles($n) [lindex $v 1]
7661 set viewargs($n) [lindex $v 2]