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 if {[tk windowingsystem
] eq
{aqua
}} {
818 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
819 pack .ctop
-fill both
-expand 1
820 bindall
<1> {selcanvline
%W
%x
%y
}
821 #bindall <B1-Motion> {selcanvline %W %x %y}
822 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
823 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
824 bindall
<2> "canvscan mark %W %x %y"
825 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
826 bindkey
<Home
> selfirstline
827 bindkey
<End
> sellastline
828 bind .
<Key-Up
> "selnextline -1"
829 bind .
<Key-Down
> "selnextline 1"
830 bind .
<Shift-Key-Up
> "next_highlight -1"
831 bind .
<Shift-Key-Down
> "next_highlight 1"
832 bindkey
<Key-Right
> "goforw"
833 bindkey
<Key-Left
> "goback"
834 bind .
<Key-Prior
> "selnextpage -1"
835 bind .
<Key-Next
> "selnextpage 1"
836 bind .
<$M1B-Home> "allcanvs yview moveto 0.0"
837 bind .
<$M1B-End> "allcanvs yview moveto 1.0"
838 bind .
<$M1B-Key-Up> "allcanvs yview scroll -1 units"
839 bind .
<$M1B-Key-Down> "allcanvs yview scroll 1 units"
840 bind .
<$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
841 bind .
<$M1B-Key-Next> "allcanvs yview scroll 1 pages"
842 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
843 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
844 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
845 bindkey p
"selnextline -1"
846 bindkey n
"selnextline 1"
849 bindkey i
"selnextline -1"
850 bindkey k
"selnextline 1"
853 bindkey b
"$ctext yview scroll -1 pages"
854 bindkey d
"$ctext yview scroll 18 units"
855 bindkey u
"$ctext yview scroll -18 units"
856 bindkey
/ {findnext
1}
857 bindkey
<Key-Return
> {findnext
0}
860 bindkey
<F5
> updatecommits
861 bind .
<$M1B-q> doquit
862 bind .
<$M1B-f> dofind
863 bind .
<$M1B-g> {findnext
0}
864 bind .
<$M1B-r> dosearchback
865 bind .
<$M1B-s> dosearch
866 bind .
<$M1B-equal> {incrfont
1}
867 bind .
<$M1B-KP_Add> {incrfont
1}
868 bind .
<$M1B-minus> {incrfont
-1}
869 bind .
<$M1B-KP_Subtract> {incrfont
-1}
870 wm protocol . WM_DELETE_WINDOW doquit
871 bind .
<Button-1
> "click %W"
872 bind $fstring <Key-Return
> dofind
873 bind $sha1entry <Key-Return
> gotocommit
874 bind $sha1entry <<PasteSelection>> clearsha1
875 bind $cflist <1> {sel_flist %W %x %y; break}
876 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
877 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
879 set maincursor [. cget -cursor]
880 set textcursor [$ctext cget -cursor]
881 set curtextcursor $textcursor
883 set rowctxmenu .rowctxmenu
884 menu $rowctxmenu -tearoff 0
885 $rowctxmenu add command -label "Diff this -> selected" \
886 -command {diffvssel 0}
887 $rowctxmenu add command -label "Diff selected -> this" \
888 -command {diffvssel 1}
889 $rowctxmenu add command -label "Make patch" -command mkpatch
890 $rowctxmenu add command -label "Create tag" -command mktag
891 $rowctxmenu add command -label "Write commit to file" -command writecommit
892 $rowctxmenu add command -label "Create new branch" -command mkbranch
893 $rowctxmenu add command -label "Cherry-pick this commit" \
895 $rowctxmenu add command -label "Reset HEAD branch to here" \
898 set fakerowmenu .fakerowmenu
899 menu $fakerowmenu -tearoff 0
900 $fakerowmenu add command -label "Diff this -> selected" \
901 -command {diffvssel 0}
902 $fakerowmenu add command -label "Diff selected -> this" \
903 -command {diffvssel 1}
904 $fakerowmenu add command -label "Make patch" -command mkpatch
905 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
906 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
907 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
909 set headctxmenu .headctxmenu
910 menu $headctxmenu -tearoff 0
911 $headctxmenu add command -label "Check out this branch" \
913 $headctxmenu add command -label "Remove this branch" \
917 # mouse-2 makes all windows scan vertically, but only the one
918 # the cursor is in scans horizontally
919 proc canvscan {op w x y} {
920 global canv canv2 canv3
921 foreach c [list $canv $canv2 $canv3] {
930 proc scrollcanv {cscroll f0 f1} {
936 # when we make a key binding for the toplevel, make sure
937 # it doesn't get triggered when that key is pressed in the
938 # find string entry widget.
939 proc bindkey {ev script} {
942 set escript [bind Entry $ev]
943 if {$escript == {}} {
944 set escript [bind Entry <Key>]
947 bind $e $ev "$escript; break"
951 # set the focus back to the toplevel for any click outside
962 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
963 global stuffsaved findmergefiles maxgraphpct
964 global maxwidth showneartags showlocalchanges
965 global viewname viewfiles viewargs viewperm nextviewnum
966 global cmitmode wrapcomment
967 global colors bgcolor fgcolor diffcolors selectbgcolor
969 if {$stuffsaved} return
970 if {![winfo viewable .]} return
972 set f [open "~/.gitk-new" w]
973 puts $f [list set mainfont $mainfont]
974 puts $f [list set textfont $textfont]
975 puts $f [list set uifont $uifont]
976 puts $f [list set tabstop $tabstop]
977 puts $f [list set findmergefiles $findmergefiles]
978 puts $f [list set maxgraphpct $maxgraphpct]
979 puts $f [list set maxwidth $maxwidth]
980 puts $f [list set cmitmode $cmitmode]
981 puts $f [list set wrapcomment $wrapcomment]
982 puts $f [list set showneartags $showneartags]
983 puts $f [list set showlocalchanges $showlocalchanges]
984 puts $f [list set bgcolor $bgcolor]
985 puts $f [list set fgcolor $fgcolor]
986 puts $f [list set colors $colors]
987 puts $f [list set diffcolors $diffcolors]
988 puts $f [list set selectbgcolor $selectbgcolor]
990 puts $f "set geometry(main) [wm geometry .]"
991 puts $f "set geometry(topwidth) [winfo width .tf]"
992 puts $f "set geometry(topheight) [winfo height .tf]"
993 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
994 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
995 puts $f "set geometry(botwidth) [winfo width .bleft]"
996 puts $f "set geometry(botheight) [winfo height .bleft]"
998 puts -nonewline $f "set permviews {"
999 for {set v 0} {$v < $nextviewnum} {incr v} {
1000 if {$viewperm($v)} {
1001 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1006 file rename -force "~/.gitk-new" "~/.gitk"
1011 proc resizeclistpanes {win w} {
1013 if {[info exists oldwidth($win)]} {
1014 set s0 [$win sash coord 0]
1015 set s1 [$win sash coord 1]
1017 set sash0 [expr {int($w/2 - 2)}]
1018 set sash1 [expr {int($w*5/6 - 2)}]
1020 set factor [expr {1.0 * $w / $oldwidth($win)}]
1021 set sash0 [expr {int($factor * [lindex $s0 0])}]
1022 set sash1 [expr {int($factor * [lindex $s1 0])}]
1026 if {$sash1 < $sash0 + 20} {
1027 set sash1 [expr {$sash0 + 20}]
1029 if {$sash1 > $w - 10} {
1030 set sash1 [expr {$w - 10}]
1031 if {$sash0 > $sash1 - 20} {
1032 set sash0 [expr {$sash1 - 20}]
1036 $win sash place 0 $sash0 [lindex $s0 1]
1037 $win sash place 1 $sash1 [lindex $s1 1]
1039 set oldwidth($win) $w
1042 proc resizecdetpanes {win w} {
1044 if {[info exists oldwidth($win)]} {
1045 set s0 [$win sash coord 0]
1047 set sash0 [expr {int($w*3/4 - 2)}]
1049 set factor [expr {1.0 * $w / $oldwidth($win)}]
1050 set sash0 [expr {int($factor * [lindex $s0 0])}]
1054 if {$sash0 > $w - 15} {
1055 set sash0 [expr {$w - 15}]
1058 $win sash place 0 $sash0 [lindex $s0 1]
1060 set oldwidth($win) $w
1063 proc allcanvs args {
1064 global canv canv2 canv3
1070 proc bindall {event action} {
1071 global canv canv2 canv3
1072 bind $canv $event $action
1073 bind $canv2 $event $action
1074 bind $canv3 $event $action
1080 if {[winfo exists $w]} {
1085 wm title $w "About gitk"
1086 message $w.m -text {
1087 Gitk - a commit viewer for git
1089 Copyright © 2005-2006 Paul Mackerras
1091 Use and redistribute under the terms of the GNU General Public License} \
1092 -justify center -aspect 400 -border 2 -bg white -relief groove
1093 pack $w.m -side top -fill x -padx 2 -pady 2
1094 $w.m configure -font $uifont
1095 button $w.ok -text Close -command "destroy $w" -default active
1096 pack $w.ok -side bottom
1097 $w.ok configure -font $uifont
1098 bind $w <Visibility> "focus $w.ok"
1099 bind $w <Key-Escape> "destroy $w"
1100 bind $w <Key-Return> "destroy $w"
1106 if {[winfo exists $w]} {
1110 if {[tk windowingsystem] eq {aqua}} {
1116 wm title $w "Gitk key bindings"
1117 message $w.m -text "
1121 <Home> Move to first commit
1122 <End> Move to last commit
1123 <Up>, p, i Move up one commit
1124 <Down>, n, k Move down one commit
1125 <Left>, z, j Go back in history list
1126 <Right>, x, l Go forward in history list
1127 <PageUp> Move up one page in commit list
1128 <PageDown> Move down one page in commit list
1129 <$M1T-Home> Scroll to top of commit list
1130 <$M1T-End> Scroll to bottom of commit list
1131 <$M1T-Up> Scroll commit list up one line
1132 <$M1T-Down> Scroll commit list down one line
1133 <$M1T-PageUp> Scroll commit list up one page
1134 <$M1T-PageDown> Scroll commit list down one page
1135 <Shift-Up> Move to previous highlighted line
1136 <Shift-Down> Move to next highlighted line
1137 <Delete>, b Scroll diff view up one page
1138 <Backspace> Scroll diff view up one page
1139 <Space> Scroll diff view down one page
1140 u Scroll diff view up 18 lines
1141 d Scroll diff view down 18 lines
1143 <$M1T-G> Move to next find hit
1144 <Return> Move to next find hit
1145 / Move to next find hit, or redo find
1146 ? Move to previous find hit
1147 f Scroll diff view to next file
1148 <$M1T-S> Search for next hit in diff view
1149 <$M1T-R> Search for previous hit in diff view
1150 <$M1T-KP+> Increase font size
1151 <$M1T-plus> Increase font size
1152 <$M1T-KP-> Decrease font size
1153 <$M1T-minus> Decrease font size
1156 -justify left -bg white -border 2 -relief groove
1157 pack $w.m -side top -fill both -padx 2 -pady 2
1158 $w.m configure -font $uifont
1159 button $w.ok -text Close -command "destroy $w" -default active
1160 pack $w.ok -side bottom
1161 $w.ok configure -font $uifont
1162 bind $w <Visibility> "focus $w.ok"
1163 bind $w <Key-Escape> "destroy $w"
1164 bind $w <Key-Return> "destroy $w"
1167 # Procedures for manipulating the file list window at the
1168 # bottom right of the overall window.
1170 proc treeview {w l openlevs} {
1171 global treecontents treediropen treeheight treeparent treeindex
1181 set treecontents() {}
1182 $w conf -state normal
1184 while {[string range $f 0 $prefixend] ne $prefix} {
1185 if {$lev <= $openlevs} {
1186 $w mark set e:$treeindex($prefix) "end -1c"
1187 $w mark gravity e:$treeindex($prefix) left
1189 set treeheight($prefix) $ht
1190 incr ht [lindex $htstack end]
1191 set htstack [lreplace $htstack end end]
1192 set prefixend [lindex $prefendstack end]
1193 set prefendstack [lreplace $prefendstack end end]
1194 set prefix [string range $prefix 0 $prefixend]
1197 set tail [string range $f [expr {$prefixend+1}] end]
1198 while {[set slash [string first "/" $tail]] >= 0} {
1201 lappend prefendstack $prefixend
1202 incr prefixend [expr {$slash + 1}]
1203 set d [string range $tail 0 $slash]
1204 lappend treecontents($prefix) $d
1205 set oldprefix $prefix
1207 set treecontents($prefix) {}
1208 set treeindex($prefix) [incr ix]
1209 set treeparent($prefix) $oldprefix
1210 set tail [string range $tail [expr {$slash+1}] end]
1211 if {$lev <= $openlevs} {
1213 set treediropen($prefix) [expr {$lev < $openlevs}]
1214 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1215 $w mark set d:$ix "end -1c"
1216 $w mark gravity d:$ix left
1218 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1220 $w image create end -align center -image $bm -padx 1 \
1222 $w insert end $d [highlight_tag $prefix]
1223 $w mark set s:$ix "end -1c"
1224 $w mark gravity s:$ix left
1229 if {$lev <= $openlevs} {
1232 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1234 $w insert end $tail [highlight_tag $f]
1236 lappend treecontents($prefix) $tail
1239 while {$htstack ne {}} {
1240 set treeheight($prefix) $ht
1241 incr ht [lindex $htstack end]
1242 set htstack [lreplace $htstack end end]
1243 set prefixend [lindex $prefendstack end]
1244 set prefendstack [lreplace $prefendstack end end]
1245 set prefix [string range $prefix 0 $prefixend]
1247 $w conf -state disabled
1250 proc linetoelt {l} {
1251 global treeheight treecontents
1256 foreach e $treecontents($prefix) {
1261 if {[string index $e end] eq "/"} {
1262 set n $treeheight($prefix$e)
1274 proc highlight_tree {y prefix} {
1275 global treeheight treecontents cflist
1277 foreach e $treecontents($prefix) {
1279 if {[highlight_tag $path] ne {}} {
1280 $cflist tag add bold $y.0 "$y.0 lineend"
1283 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1284 set y [highlight_tree $y $path]
1290 proc treeclosedir {w dir} {
1291 global treediropen treeheight treeparent treeindex
1293 set ix $treeindex($dir)
1294 $w conf -state normal
1295 $w delete s:$ix e:$ix
1296 set treediropen($dir) 0
1297 $w image configure a:$ix -image tri-rt
1298 $w conf -state disabled
1299 set n [expr {1 - $treeheight($dir)}]
1300 while {$dir ne {}} {
1301 incr treeheight($dir) $n
1302 set dir $treeparent($dir)
1306 proc treeopendir {w dir} {
1307 global treediropen treeheight treeparent treecontents treeindex
1309 set ix $treeindex($dir)
1310 $w conf -state normal
1311 $w image configure a:$ix -image tri-dn
1312 $w mark set e:$ix s:$ix
1313 $w mark gravity e:$ix right
1316 set n [llength $treecontents($dir)]
1317 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1320 incr treeheight($x) $n
1322 foreach e $treecontents($dir) {
1324 if {[string index $e end] eq "/"} {
1325 set iy $treeindex($de)
1326 $w mark set d:$iy e:$ix
1327 $w mark gravity d:$iy left
1328 $w insert e:$ix $str
1329 set treediropen($de) 0
1330 $w image create e:$ix -align center -image tri-rt -padx 1 \
1332 $w insert e:$ix $e [highlight_tag $de]
1333 $w mark set s:$iy e:$ix
1334 $w mark gravity s:$iy left
1335 set treeheight($de) 1
1337 $w insert e:$ix $str
1338 $w insert e:$ix $e [highlight_tag $de]
1341 $w mark gravity e:$ix left
1342 $w conf -state disabled
1343 set treediropen($dir) 1
1344 set top [lindex [split [$w index @0,0] .] 0]
1345 set ht [$w cget -height]
1346 set l [lindex [split [$w index s:$ix] .] 0]
1349 } elseif {$l + $n + 1 > $top + $ht} {
1350 set top [expr {$l + $n + 2 - $ht}]
1358 proc treeclick {w x y} {
1359 global treediropen cmitmode ctext cflist cflist_top
1361 if {$cmitmode ne "tree"} return
1362 if {![info exists cflist_top]} return
1363 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1364 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1365 $cflist tag add highlight $l.0 "$l.0 lineend"
1371 set e [linetoelt $l]
1372 if {[string index $e end] ne "/"} {
1374 } elseif {$treediropen($e)} {
1381 proc setfilelist {id} {
1382 global treefilelist cflist
1384 treeview $cflist $treefilelist($id) 0
1387 image create bitmap tri-rt -background black -foreground blue -data {
1388 #define tri-rt_width 13
1389 #define tri-rt_height 13
1390 static unsigned char tri-rt_bits[] = {
1391 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1392 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1395 #define tri-rt-mask_width 13
1396 #define tri-rt-mask_height 13
1397 static unsigned char tri-rt-mask_bits[] = {
1398 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1399 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1402 image create bitmap tri-dn -background black -foreground blue -data {
1403 #define tri-dn_width 13
1404 #define tri-dn_height 13
1405 static unsigned char tri-dn_bits[] = {
1406 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1407 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1410 #define tri-dn-mask_width 13
1411 #define tri-dn-mask_height 13
1412 static unsigned char tri-dn-mask_bits[] = {
1413 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1414 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1418 proc init_flist {first} {
1419 global cflist cflist_top selectedline difffilestart
1421 $cflist conf -state normal
1422 $cflist delete 0.0 end
1424 $cflist insert end $first
1426 $cflist tag add highlight 1.0 "1.0 lineend"
1428 catch {unset cflist_top}
1430 $cflist conf -state disabled
1431 set difffilestart {}
1434 proc highlight_tag {f} {
1435 global highlight_paths
1437 foreach p $highlight_paths {
1438 if {[string match $p $f]} {
1445 proc highlight_filelist {} {
1446 global cmitmode cflist
1448 $cflist conf -state normal
1449 if {$cmitmode ne "tree"} {
1450 set end [lindex [split [$cflist index end] .] 0]
1451 for {set l 2} {$l < $end} {incr l} {
1452 set line [$cflist get $l.0 "$l.0 lineend"]
1453 if {[highlight_tag $line] ne {}} {
1454 $cflist tag add bold $l.0 "$l.0 lineend"
1460 $cflist conf -state disabled
1463 proc unhighlight_filelist {} {
1466 $cflist conf -state normal
1467 $cflist tag remove bold 1.0 end
1468 $cflist conf -state disabled
1471 proc add_flist {fl} {
1474 $cflist conf -state normal
1476 $cflist insert end "\n"
1477 $cflist insert end $f [highlight_tag $f]
1479 $cflist conf -state disabled
1482 proc sel_flist {w x y} {
1483 global ctext difffilestart cflist cflist_top cmitmode
1485 if {$cmitmode eq "tree"} return
1486 if {![info exists cflist_top]} return
1487 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1488 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1489 $cflist tag add highlight $l.0 "$l.0 lineend"
1494 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1498 # Functions for adding and removing shell-type quoting
1500 proc shellquote {str} {
1501 if {![string match "*\['\"\\ \t]*" $str]} {
1504 if {![string match "*\['\"\\]*" $str]} {
1507 if {![string match "*'*" $str]} {
1510 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1513 proc shellarglist {l} {
1519 append str [shellquote $a]
1524 proc shelldequote {str} {
1529 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1530 append ret [string range $str $used end]
1531 set used [string length $str]
1534 set first [lindex $first 0]
1535 set ch [string index $str $first]
1536 if {$first > $used} {
1537 append ret [string range $str $used [expr {$first - 1}]]
1540 if {$ch eq " " || $ch eq "\t"} break
1543 set first [string first "'" $str $used]
1545 error "unmatched single-quote"
1547 append ret [string range $str $used [expr {$first - 1}]]
1552 if {$used >= [string length $str]} {
1553 error "trailing backslash"
1555 append ret [string index $str $used]
1560 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1561 error "unmatched double-quote"
1563 set first [lindex $first 0]
1564 set ch [string index $str $first]
1565 if {$first > $used} {
1566 append ret [string range $str $used [expr {$first - 1}]]
1569 if {$ch eq "\""} break
1571 append ret [string index $str $used]
1575 return [list $used $ret]
1578 proc shellsplit {str} {
1581 set str [string trimleft $str]
1582 if {$str eq {}} break
1583 set dq [shelldequote $str]
1584 set n [lindex $dq 0]
1585 set word [lindex $dq 1]
1586 set str [string range $str $n end]
1592 # Code to implement multiple views
1594 proc newview {ishighlight} {
1595 global nextviewnum newviewname newviewperm uifont newishighlight
1596 global newviewargs revtreeargs
1598 set newishighlight $ishighlight
1600 if {[winfo exists $top]} {
1604 set newviewname($nextviewnum) "View $nextviewnum"
1605 set newviewperm($nextviewnum) 0
1606 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1607 vieweditor $top $nextviewnum "Gitk view definition"
1612 global viewname viewperm newviewname newviewperm
1613 global viewargs newviewargs
1615 set top .gitkvedit-$curview
1616 if {[winfo exists $top]} {
1620 set newviewname($curview) $viewname($curview)
1621 set newviewperm($curview) $viewperm($curview)
1622 set newviewargs($curview) [shellarglist $viewargs($curview)]
1623 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1626 proc vieweditor {top n title} {
1627 global newviewname newviewperm viewfiles
1631 wm title $top $title
1632 label $top.nl -text "Name" -font $uifont
1633 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1634 grid $top.nl $top.name -sticky w -pady 5
1635 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1637 grid $top.perm - -pady 5 -sticky w
1638 message $top.al -aspect 1000 -font $uifont \
1639 -text "Commits to include (arguments to git rev-list):"
1640 grid $top.al - -sticky w -pady 5
1641 entry $top.args -width 50 -textvariable newviewargs($n) \
1642 -background white -font $uifont
1643 grid $top.args - -sticky ew -padx 5
1644 message $top.l -aspect 1000 -font $uifont \
1645 -text "Enter files and directories to include, one per line:"
1646 grid $top.l - -sticky w
1647 text $top.t -width 40 -height 10 -background white -font $uifont
1648 if {[info exists viewfiles($n)]} {
1649 foreach f $viewfiles($n) {
1650 $top.t insert end $f
1651 $top.t insert end "\n"
1653 $top.t delete {end - 1c} end
1654 $top.t mark set insert 0.0
1656 grid $top.t - -sticky ew -padx 5
1658 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1660 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1662 grid $top.buts.ok $top.buts.can
1663 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1664 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1665 grid $top.buts - -pady 10 -sticky ew
1669 proc doviewmenu {m first cmd op argv} {
1670 set nmenu [$m index end]
1671 for {set i $first} {$i <= $nmenu} {incr i} {
1672 if {[$m entrycget $i -command] eq $cmd} {
1673 eval $m $op $i $argv
1679 proc allviewmenus {n op args} {
1682 doviewmenu .bar.view 5 [list showview $n] $op $args
1683 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1686 proc newviewok {top n} {
1687 global nextviewnum newviewperm newviewname newishighlight
1688 global viewname viewfiles viewperm selectedview curview
1689 global viewargs newviewargs viewhlmenu
1692 set newargs [shellsplit $newviewargs($n)]
1694 error_popup "Error in commit selection arguments: $err"
1700 foreach f [split [$top.t get 0.0 end] "\n"] {
1701 set ft [string trim $f]
1706 if {![info exists viewfiles($n)]} {
1707 # creating a new view
1709 set viewname($n) $newviewname($n)
1710 set viewperm($n) $newviewperm($n)
1711 set viewfiles($n) $files
1712 set viewargs($n) $newargs
1714 if {!$newishighlight} {
1717 run addvhighlight $n
1720 # editing an existing view
1721 set viewperm($n) $newviewperm($n)
1722 if {$newviewname($n) ne $viewname($n)} {
1723 set viewname($n) $newviewname($n)
1724 doviewmenu .bar.view 5 [list showview $n] \
1725 entryconf [list -label $viewname($n)]
1726 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1727 entryconf [list -label $viewname($n) -value $viewname($n)]
1729 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1730 set viewfiles($n) $files
1731 set viewargs($n) $newargs
1732 if {$curview == $n} {
1737 catch {destroy $top}
1741 global curview viewdata viewperm hlview selectedhlview
1743 if {$curview == 0} return
1744 if {[info exists hlview] && $hlview == $curview} {
1745 set selectedhlview None
1748 allviewmenus $curview delete
1749 set viewdata($curview) {}
1750 set viewperm($curview) 0
1754 proc addviewmenu {n} {
1755 global viewname viewhlmenu
1757 .bar.view add radiobutton -label $viewname($n) \
1758 -command [list showview $n] -variable selectedview -value $n
1759 $viewhlmenu add radiobutton -label $viewname($n) \
1760 -command [list addvhighlight $n] -variable selectedhlview
1763 proc flatten {var} {
1767 foreach i [array names $var] {
1768 lappend ret $i [set $var\($i\)]
1773 proc unflatten {var l} {
1783 global curview viewdata viewfiles
1784 global displayorder parentlist rowidlist rowoffsets
1785 global colormap rowtextx commitrow nextcolor canvxmax
1786 global numcommits rowrangelist commitlisted idrowranges rowchk
1787 global selectedline currentid canv canvy0
1789 global pending_select phase
1790 global commitidx rowlaidout rowoptim
1792 global selectedview selectfirst
1793 global vparentlist vdisporder vcmitlisted
1794 global hlview selectedhlview
1796 if {$n == $curview} return
1798 if {[info exists selectedline]} {
1799 set selid $currentid
1800 set y [yc $selectedline]
1801 set ymax [lindex [$canv cget -scrollregion] 3]
1802 set span [$canv yview]
1803 set ytop [expr {[lindex $span 0] * $ymax}]
1804 set ybot [expr {[lindex $span 1] * $ymax}]
1805 if {$ytop < $y && $y < $ybot} {
1806 set yscreen [expr {$y - $ytop}]
1808 set yscreen [expr {($ybot - $ytop) / 2}]
1810 } elseif {[info exists pending_select]} {
1811 set selid $pending_select
1812 unset pending_select
1816 if {$curview >= 0} {
1817 set vparentlist($curview) $parentlist
1818 set vdisporder($curview) $displayorder
1819 set vcmitlisted($curview) $commitlisted
1821 set viewdata($curview) \
1822 [list $phase $rowidlist $rowoffsets $rowrangelist \
1823 [flatten idrowranges] [flatten idinlist] \
1824 $rowlaidout $rowoptim $numcommits]
1825 } elseif {![info exists viewdata($curview)]
1826 || [lindex $viewdata($curview) 0] ne {}} {
1827 set viewdata($curview) \
1828 [list {} $rowidlist $rowoffsets $rowrangelist]
1831 catch {unset treediffs}
1833 if {[info exists hlview] && $hlview == $n} {
1835 set selectedhlview None
1840 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1841 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1843 if {![info exists viewdata($n)]} {
1845 set pending_select $selid
1852 set phase [lindex $v 0]
1853 set displayorder $vdisporder($n)
1854 set parentlist $vparentlist($n)
1855 set commitlisted $vcmitlisted($n)
1856 set rowidlist [lindex $v 1]
1857 set rowoffsets [lindex $v 2]
1858 set rowrangelist [lindex $v 3]
1860 set numcommits [llength $displayorder]
1861 catch {unset idrowranges}
1863 unflatten idrowranges [lindex $v 4]
1864 unflatten idinlist [lindex $v 5]
1865 set rowlaidout [lindex $v 6]
1866 set rowoptim [lindex $v 7]
1867 set numcommits [lindex $v 8]
1868 catch {unset rowchk}
1871 catch {unset colormap}
1872 catch {unset rowtextx}
1874 set canvxmax [$canv cget -width]
1881 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1882 set row $commitrow($n,$selid)
1883 # try to get the selected row in the same position on the screen
1884 set ymax [lindex [$canv cget -scrollregion] 3]
1885 set ytop [expr {[yc $row] - $yscreen}]
1889 set yf [expr {$ytop * 1.0 / $ymax}]
1891 allcanvs yview moveto $yf
1895 } elseif {$selid ne {}} {
1896 set pending_select $selid
1898 set row [first_real_row]
1899 if {$row < $numcommits} {
1906 if {$phase eq "getcommits"} {
1907 show_status "Reading commits..."
1910 } elseif {$numcommits == 0} {
1911 show_status "No commits selected"
1915 # Stuff relating to the highlighting facility
1917 proc ishighlighted {row} {
1918 global vhighlights fhighlights nhighlights rhighlights
1920 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1921 return $nhighlights($row)
1923 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1924 return $vhighlights($row)
1926 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1927 return $fhighlights($row)
1929 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1930 return $rhighlights($row)
1935 proc bolden {row font} {
1936 global canv linehtag selectedline boldrows
1938 lappend boldrows $row
1939 $canv itemconf $linehtag($row) -font $font
1940 if {[info exists selectedline] && $row == $selectedline} {
1942 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1943 -outline {{}} -tags secsel \
1944 -fill [$canv cget -selectbackground]]
1949 proc bolden_name {row font} {
1950 global canv2 linentag selectedline boldnamerows
1952 lappend boldnamerows $row
1953 $canv2 itemconf $linentag($row) -font $font
1954 if {[info exists selectedline] && $row == $selectedline} {
1955 $canv2 delete secsel
1956 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1957 -outline {{}} -tags secsel \
1958 -fill [$canv2 cget -selectbackground]]
1964 global mainfont boldrows
1967 foreach row $boldrows {
1968 if {![ishighlighted $row]} {
1969 bolden $row $mainfont
1971 lappend stillbold $row
1974 set boldrows $stillbold
1977 proc addvhighlight {n} {
1978 global hlview curview viewdata vhl_done vhighlights commitidx
1980 if {[info exists hlview]} {
1984 if {$n != $curview && ![info exists viewdata($n)]} {
1985 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1986 set vparentlist($n) {}
1987 set vdisporder($n) {}
1988 set vcmitlisted($n) {}
1991 set vhl_done $commitidx($hlview)
1992 if {$vhl_done > 0} {
1997 proc delvhighlight {} {
1998 global hlview vhighlights
2000 if {![info exists hlview]} return
2002 catch {unset vhighlights}
2006 proc vhighlightmore {} {
2007 global hlview vhl_done commitidx vhighlights
2008 global displayorder vdisporder curview mainfont
2010 set font [concat $mainfont bold]
2011 set max $commitidx($hlview)
2012 if {$hlview == $curview} {
2013 set disp $displayorder
2015 set disp $vdisporder($hlview)
2017 set vr [visiblerows]
2018 set r0 [lindex $vr 0]
2019 set r1 [lindex $vr 1]
2020 for {set i $vhl_done} {$i < $max} {incr i} {
2021 set id [lindex $disp $i]
2022 if {[info exists commitrow($curview,$id)]} {
2023 set row $commitrow($curview,$id)
2024 if {$r0 <= $row && $row <= $r1} {
2025 if {![highlighted $row]} {
2028 set vhighlights($row) 1
2035 proc askvhighlight {row id} {
2036 global hlview vhighlights commitrow iddrawn mainfont
2038 if {[info exists commitrow($hlview,$id)]} {
2039 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2040 bolden $row [concat $mainfont bold]
2042 set vhighlights($row) 1
2044 set vhighlights($row) 0
2048 proc hfiles_change {name ix op} {
2049 global highlight_files filehighlight fhighlights fh_serial
2050 global mainfont highlight_paths
2052 if {[info exists filehighlight]} {
2053 # delete previous highlights
2054 catch {close $filehighlight}
2056 catch {unset fhighlights}
2058 unhighlight_filelist
2060 set highlight_paths {}
2061 after cancel do_file_hl $fh_serial
2063 if {$highlight_files ne {}} {
2064 after 300 do_file_hl $fh_serial
2068 proc makepatterns {l} {
2071 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2072 if {[string index $ee end] eq "/"} {
2082 proc do_file_hl {serial} {
2083 global highlight_files filehighlight highlight_paths gdttype fhl_list
2085 if {$gdttype eq "touching paths:"} {
2086 if {[catch {set paths [shellsplit $highlight_files]}]} return
2087 set highlight_paths [makepatterns $paths]
2089 set gdtargs [concat -- $paths]
2091 set gdtargs [list "-S$highlight_files"]
2093 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2094 set filehighlight [open $cmd r+]
2095 fconfigure $filehighlight -blocking 0
2096 filerun $filehighlight readfhighlight
2102 proc flushhighlights {} {
2103 global filehighlight fhl_list
2105 if {[info exists filehighlight]} {
2107 puts $filehighlight ""
2108 flush $filehighlight
2112 proc askfilehighlight {row id} {
2113 global filehighlight fhighlights fhl_list
2115 lappend fhl_list $id
2116 set fhighlights($row) -1
2117 puts $filehighlight $id
2120 proc readfhighlight {} {
2121 global filehighlight fhighlights commitrow curview mainfont iddrawn
2124 if {![info exists filehighlight]} {
2128 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2129 set line [string trim $line]
2130 set i [lsearch -exact $fhl_list $line]
2131 if {$i < 0} continue
2132 for {set j 0} {$j < $i} {incr j} {
2133 set id [lindex $fhl_list $j]
2134 if {[info exists commitrow($curview,$id)]} {
2135 set fhighlights($commitrow($curview,$id)) 0
2138 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2139 if {$line eq {}} continue
2140 if {![info exists commitrow($curview,$line)]} continue
2141 set row $commitrow($curview,$line)
2142 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2143 bolden $row [concat $mainfont bold]
2145 set fhighlights($row) 1
2147 if {[eof $filehighlight]} {
2149 puts "oops, git diff-tree died"
2150 catch {close $filehighlight}
2158 proc find_change {name ix op} {
2159 global nhighlights mainfont boldnamerows
2160 global findstring findpattern findtype markingmatches
2162 # delete previous highlights, if any
2163 foreach row $boldnamerows {
2164 bolden_name $row $mainfont
2167 catch {unset nhighlights}
2170 if {$findtype ne "Regexp"} {
2171 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2173 set findpattern "*$e*"
2175 set markingmatches [expr {$findstring ne {}}]
2179 proc doesmatch {f} {
2180 global findtype findstring findpattern
2182 if {$findtype eq "Regexp"} {
2183 return [regexp $findstring $f]
2184 } elseif {$findtype eq "IgnCase"} {
2185 return [string match -nocase $findpattern $f]
2187 return [string match $findpattern $f]
2191 proc askfindhighlight {row id} {
2192 global nhighlights commitinfo iddrawn mainfont
2194 global markingmatches
2196 if {![info exists commitinfo($id)]} {
2199 set info $commitinfo($id)
2201 set fldtypes {Headline Author Date Committer CDate Comments}
2202 foreach f $info ty $fldtypes {
2203 if {($findloc eq "All fields" || $findloc eq $ty) &&
2205 if {$ty eq "Author"} {
2212 if {$isbold && [info exists iddrawn($id)]} {
2213 set f [concat $mainfont bold]
2214 if {![ishighlighted $row]} {
2220 if {$markingmatches} {
2221 markrowmatches $row [lindex $info 0] [lindex $info 1]
2224 set nhighlights($row) $isbold
2227 proc markrowmatches {row headline author} {
2228 global canv canv2 linehtag linentag
2230 $canv delete match$row
2231 $canv2 delete match$row
2232 set m [findmatches $headline]
2234 markmatches $canv $row $headline $linehtag($row) $m \
2235 [$canv itemcget $linehtag($row) -font]
2237 set m [findmatches $author]
2239 markmatches $canv2 $row $author $linentag($row) $m \
2240 [$canv2 itemcget $linentag($row) -font]
2244 proc vrel_change {name ix op} {
2245 global highlight_related
2248 if {$highlight_related ne "None"} {
2253 # prepare for testing whether commits are descendents or ancestors of a
2254 proc rhighlight_sel {a} {
2255 global descendent desc_todo ancestor anc_todo
2256 global highlight_related rhighlights
2258 catch {unset descendent}
2259 set desc_todo [list $a]
2260 catch {unset ancestor}
2261 set anc_todo [list $a]
2262 if {$highlight_related ne "None"} {
2268 proc rhighlight_none {} {
2271 catch {unset rhighlights}
2275 proc is_descendent {a} {
2276 global curview children commitrow descendent desc_todo
2279 set la $commitrow($v,$a)
2283 for {set i 0} {$i < [llength $todo]} {incr i} {
2284 set do [lindex $todo $i]
2285 if {$commitrow($v,$do) < $la} {
2286 lappend leftover $do
2289 foreach nk $children($v,$do) {
2290 if {![info exists descendent($nk)]} {
2291 set descendent($nk) 1
2299 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2303 set descendent($a) 0
2304 set desc_todo $leftover
2307 proc is_ancestor {a} {
2308 global curview parentlist commitrow ancestor anc_todo
2311 set la $commitrow($v,$a)
2315 for {set i 0} {$i < [llength $todo]} {incr i} {
2316 set do [lindex $todo $i]
2317 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2318 lappend leftover $do
2321 foreach np [lindex $parentlist $commitrow($v,$do)] {
2322 if {![info exists ancestor($np)]} {
2331 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2336 set anc_todo $leftover
2339 proc askrelhighlight {row id} {
2340 global descendent highlight_related iddrawn mainfont rhighlights
2341 global selectedline ancestor
2343 if {![info exists selectedline]} return
2345 if {$highlight_related eq "Descendent" ||
2346 $highlight_related eq "Not descendent"} {
2347 if {![info exists descendent($id)]} {
2350 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2353 } elseif {$highlight_related eq "Ancestor" ||
2354 $highlight_related eq "Not ancestor"} {
2355 if {![info exists ancestor($id)]} {
2358 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2362 if {[info exists iddrawn($id)]} {
2363 if {$isbold && ![ishighlighted $row]} {
2364 bolden $row [concat $mainfont bold]
2367 set rhighlights($row) $isbold
2370 proc next_hlcont {} {
2371 global fhl_row fhl_dirn displayorder numcommits
2372 global vhighlights fhighlights nhighlights rhighlights
2373 global hlview filehighlight findstring highlight_related
2375 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2378 if {$row < 0 || $row >= $numcommits} {
2383 set id [lindex $displayorder $row]
2384 if {[info exists hlview]} {
2385 if {![info exists vhighlights($row)]} {
2386 askvhighlight $row $id
2388 if {$vhighlights($row) > 0} break
2390 if {$findstring ne {}} {
2391 if {![info exists nhighlights($row)]} {
2392 askfindhighlight $row $id
2394 if {$nhighlights($row) > 0} break
2396 if {$highlight_related ne "None"} {
2397 if {![info exists rhighlights($row)]} {
2398 askrelhighlight $row $id
2400 if {$rhighlights($row) > 0} break
2402 if {[info exists filehighlight]} {
2403 if {![info exists fhighlights($row)]} {
2404 # ask for a few more while we're at it...
2406 for {set n 0} {$n < 100} {incr n} {
2407 if {![info exists fhighlights($r)]} {
2408 askfilehighlight $r [lindex $displayorder $r]
2411 if {$r < 0 || $r >= $numcommits} break
2415 if {$fhighlights($row) < 0} {
2419 if {$fhighlights($row) > 0} break
2427 proc next_highlight {dirn} {
2428 global selectedline fhl_row fhl_dirn
2429 global hlview filehighlight findstring highlight_related
2431 if {![info exists selectedline]} return
2432 if {!([info exists hlview] || $findstring ne {} ||
2433 $highlight_related ne "None" || [info exists filehighlight])} return
2434 set fhl_row [expr {$selectedline + $dirn}]
2439 proc cancel_next_highlight {} {
2445 # Graph layout functions
2447 proc shortids {ids} {
2450 if {[llength $id] > 1} {
2451 lappend res [shortids $id]
2452 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2453 lappend res [string range $id 0 7]
2461 proc incrange {l x o} {
2464 set e [lindex $l $x]
2466 lset l $x [expr {$e + $o}]
2475 for {} {$n > 0} {incr n -1} {
2481 proc usedinrange {id l1 l2} {
2482 global children commitrow curview
2484 if {[info exists commitrow($curview,$id)]} {
2485 set r $commitrow($curview,$id)
2486 if {$l1 <= $r && $r <= $l2} {
2487 return [expr {$r - $l1 + 1}]
2490 set kids $children($curview,$id)
2492 set r $commitrow($curview,$c)
2493 if {$l1 <= $r && $r <= $l2} {
2494 return [expr {$r - $l1 + 1}]
2500 proc sanity {row {full 0}} {
2501 global rowidlist rowoffsets
2504 set ids [lindex $rowidlist $row]
2507 if {$id eq {}} continue
2508 if {$col < [llength $ids] - 1 &&
2509 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2510 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2512 set o [lindex $rowoffsets $row $col]
2518 if {[lindex $rowidlist $y $x] != $id} {
2519 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2520 puts " id=[shortids $id] check started at row $row"
2521 for {set i $row} {$i >= $y} {incr i -1} {
2522 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2527 set o [lindex $rowoffsets $y $x]
2532 proc makeuparrow {oid x y z} {
2533 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2535 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2538 set off0 [lindex $rowoffsets $y]
2539 for {set x0 $x} {1} {incr x0} {
2540 if {$x0 >= [llength $off0]} {
2541 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2544 set z [lindex $off0 $x0]
2550 set z [expr {$x0 - $x}]
2551 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2552 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2554 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2555 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2556 lappend idrowranges($oid) [lindex $displayorder $y]
2559 proc initlayout {} {
2560 global rowidlist rowoffsets displayorder commitlisted
2561 global rowlaidout rowoptim
2562 global idinlist rowchk rowrangelist idrowranges
2563 global numcommits canvxmax canv
2566 global colormap rowtextx
2577 catch {unset idinlist}
2578 catch {unset rowchk}
2581 set canvxmax [$canv cget -width]
2582 catch {unset colormap}
2583 catch {unset rowtextx}
2584 catch {unset idrowranges}
2588 proc setcanvscroll {} {
2589 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2591 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2592 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2593 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2594 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2597 proc visiblerows {} {
2598 global canv numcommits linespc
2600 set ymax [lindex [$canv cget -scrollregion] 3]
2601 if {$ymax eq {} || $ymax == 0} return
2603 set y0 [expr {int([lindex $f 0] * $ymax)}]
2604 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2608 set y1 [expr {int([lindex $f 1] * $ymax)}]
2609 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2610 if {$r1 >= $numcommits} {
2611 set r1 [expr {$numcommits - 1}]
2613 return [list $r0 $r1]
2616 proc layoutmore {tmax allread} {
2617 global rowlaidout rowoptim commitidx numcommits optim_delay
2618 global uparrowlen curview rowidlist idinlist
2621 set showdelay $optim_delay
2622 set optdelay [expr {$uparrowlen + 1}]
2624 if {$rowoptim - $showdelay > $numcommits} {
2625 showstuff [expr {$rowoptim - $showdelay}] $showlast
2626 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2627 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2631 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2633 } elseif {$commitidx($curview) > $rowlaidout} {
2634 set nr [expr {$commitidx($curview) - $rowlaidout}]
2635 # may need to increase this threshold if uparrowlen or
2636 # mingaplen are increased...
2641 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2642 if {$rowlaidout == $row} {
2645 } elseif {$allread} {
2647 set nrows $commitidx($curview)
2648 if {[lindex $rowidlist $nrows] ne {} ||
2649 [array names idinlist] ne {}} {
2651 set rowlaidout $commitidx($curview)
2652 } elseif {$rowoptim == $nrows} {
2655 if {$numcommits == $nrows} {
2662 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2668 proc showstuff {canshow last} {
2669 global numcommits commitrow pending_select selectedline curview
2670 global lookingforhead mainheadid displayorder selectfirst
2671 global lastscrollset
2673 if {$numcommits == 0} {
2675 set phase "incrdraw"
2679 set prev $numcommits
2680 set numcommits $canshow
2681 set t [clock clicks -milliseconds]
2682 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2683 set lastscrollset $t
2686 set rows [visiblerows]
2687 set r1 [lindex $rows 1]
2688 if {$r1 >= $canshow} {
2689 set r1 [expr {$canshow - 1}]
2694 if {[info exists pending_select] &&
2695 [info exists commitrow($curview,$pending_select)] &&
2696 $commitrow($curview,$pending_select) < $numcommits} {
2697 selectline $commitrow($curview,$pending_select) 1
2700 if {[info exists selectedline] || [info exists pending_select]} {
2703 set l [first_real_row]
2708 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2709 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2710 set lookingforhead 0
2715 proc doshowlocalchanges {} {
2716 global lookingforhead curview mainheadid phase commitrow
2718 if {[info exists commitrow($curview,$mainheadid)] &&
2719 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2721 } elseif {$phase ne {}} {
2722 set lookingforhead 1
2726 proc dohidelocalchanges {} {
2727 global lookingforhead localfrow localirow lserial
2729 set lookingforhead 0
2730 if {$localfrow >= 0} {
2731 removerow $localfrow
2733 if {$localirow > 0} {
2737 if {$localirow >= 0} {
2738 removerow $localirow
2744 # spawn off a process to do git diff-index --cached HEAD
2745 proc dodiffindex {} {
2746 global localirow localfrow lserial
2751 set fd [open "|git diff-index --cached HEAD" r]
2752 fconfigure $fd -blocking 0
2753 filerun $fd [list readdiffindex $fd $lserial]
2756 proc readdiffindex {fd serial} {
2757 global localirow commitrow mainheadid nullid2 curview
2758 global commitinfo commitdata lserial
2761 if {[gets $fd line] < 0} {
2767 # we only need to see one line and we don't really care what it says...
2770 # now see if there are any local changes not checked in to the index
2771 if {$serial == $lserial} {
2772 set fd [open "|git diff-files" r]
2773 fconfigure $fd -blocking 0
2774 filerun $fd [list readdifffiles $fd $serial]
2777 if {$isdiff && $serial == $lserial && $localirow == -1} {
2778 # add the line for the changes in the index to the graph
2779 set localirow $commitrow($curview,$mainheadid)
2780 set hl "Local changes checked in to index but not committed"
2781 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2782 set commitdata($nullid2) "\n $hl\n"
2783 insertrow $localirow $nullid2
2788 proc readdifffiles {fd serial} {
2789 global localirow localfrow commitrow mainheadid nullid curview
2790 global commitinfo commitdata lserial
2793 if {[gets $fd line] < 0} {
2799 # we only need to see one line and we don't really care what it says...
2802 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2803 # add the line for the local diff to the graph
2804 if {$localirow >= 0} {
2805 set localfrow $localirow
2808 set localfrow $commitrow($curview,$mainheadid)
2810 set hl "Local uncommitted changes, not checked in to index"
2811 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2812 set commitdata($nullid) "\n $hl\n"
2813 insertrow $localfrow $nullid
2818 proc layoutrows {row endrow last} {
2819 global rowidlist rowoffsets displayorder
2820 global uparrowlen downarrowlen maxwidth mingaplen
2821 global children parentlist
2823 global commitidx curview
2824 global idinlist rowchk rowrangelist
2826 set idlist [lindex $rowidlist $row]
2827 set offs [lindex $rowoffsets $row]
2828 while {$row < $endrow} {
2829 set id [lindex $displayorder $row]
2832 foreach p [lindex $parentlist $row] {
2833 if {![info exists idinlist($p)]} {
2835 } elseif {!$idinlist($p)} {
2839 set nev [expr {[llength $idlist] + [llength $newolds]
2840 + [llength $oldolds] - $maxwidth + 1}]
2843 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2844 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2845 set i [lindex $idlist $x]
2846 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2847 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2848 [expr {$row + $uparrowlen + $mingaplen}]]
2850 set idlist [lreplace $idlist $x $x]
2851 set offs [lreplace $offs $x $x]
2852 set offs [incrange $offs $x 1]
2854 set rm1 [expr {$row - 1}]
2855 lappend idrowranges($i) [lindex $displayorder $rm1]
2856 if {[incr nev -1] <= 0} break
2859 set rowchk($id) [expr {$row + $r}]
2862 lset rowidlist $row $idlist
2863 lset rowoffsets $row $offs
2865 set col [lsearch -exact $idlist $id]
2867 set col [llength $idlist]
2869 lset rowidlist $row $idlist
2871 if {$children($curview,$id) ne {}} {
2872 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2876 lset rowoffsets $row $offs
2878 makeuparrow $id $col $row $z
2884 if {[info exists idrowranges($id)]} {
2885 set ranges $idrowranges($id)
2887 unset idrowranges($id)
2889 lappend rowrangelist $ranges
2891 set offs [ntimes [llength $idlist] 0]
2892 set l [llength $newolds]
2893 set idlist [eval lreplace \$idlist $col $col $newolds]
2896 set offs [lrange $offs 0 [expr {$col - 1}]]
2897 foreach x $newolds {
2902 set tmp [expr {[llength $idlist] - [llength $offs]}]
2904 set offs [concat $offs [ntimes $tmp $o]]
2909 foreach i $newolds {
2911 set idrowranges($i) $id
2914 foreach oid $oldolds {
2915 set idinlist($oid) 1
2916 set idlist [linsert $idlist $col $oid]
2917 set offs [linsert $offs $col $o]
2918 makeuparrow $oid $col $row $o
2921 lappend rowidlist $idlist
2922 lappend rowoffsets $offs
2927 proc addextraid {id row} {
2928 global displayorder commitrow commitinfo
2929 global commitidx commitlisted
2930 global parentlist children curview
2932 incr commitidx($curview)
2933 lappend displayorder $id
2934 lappend commitlisted 0
2935 lappend parentlist {}
2936 set commitrow($curview,$id) $row
2938 if {![info exists commitinfo($id)]} {
2939 set commitinfo($id) {"No commit information available"}
2941 if {![info exists children($curview,$id)]} {
2942 set children($curview,$id) {}
2946 proc layouttail {} {
2947 global rowidlist rowoffsets idinlist commitidx curview
2948 global idrowranges rowrangelist
2950 set row $commitidx($curview)
2951 set idlist [lindex $rowidlist $row]
2952 while {$idlist ne {}} {
2953 set col [expr {[llength $idlist] - 1}]
2954 set id [lindex $idlist $col]
2957 lappend idrowranges($id) $id
2958 lappend rowrangelist $idrowranges($id)
2959 unset idrowranges($id)
2961 set offs [ntimes $col 0]
2962 set idlist [lreplace $idlist $col $col]
2963 lappend rowidlist $idlist
2964 lappend rowoffsets $offs
2967 foreach id [array names idinlist] {
2970 lset rowidlist $row [list $id]
2971 lset rowoffsets $row 0
2972 makeuparrow $id 0 $row 0
2973 lappend idrowranges($id) $id
2974 lappend rowrangelist $idrowranges($id)
2975 unset idrowranges($id)
2977 lappend rowidlist {}
2978 lappend rowoffsets {}
2982 proc insert_pad {row col npad} {
2983 global rowidlist rowoffsets
2985 set pad [ntimes $npad {}]
2986 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2987 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2988 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2991 proc optimize_rows {row col endrow} {
2992 global rowidlist rowoffsets displayorder
2994 for {} {$row < $endrow} {incr row} {
2995 set idlist [lindex $rowidlist $row]
2996 set offs [lindex $rowoffsets $row]
2998 for {} {$col < [llength $offs]} {incr col} {
2999 if {[lindex $idlist $col] eq {}} {
3003 set z [lindex $offs $col]
3004 if {$z eq {}} continue
3006 set x0 [expr {$col + $z}]
3007 set y0 [expr {$row - 1}]
3008 set z0 [lindex $rowoffsets $y0 $x0]
3010 set id [lindex $idlist $col]
3011 set ranges [rowranges $id]
3012 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3016 # Looking at lines from this row to the previous row,
3017 # make them go straight up if they end in an arrow on
3018 # the previous row; otherwise make them go straight up
3020 if {$z < -1 || ($z < 0 && $isarrow)} {
3021 # Line currently goes left too much;
3022 # insert pads in the previous row, then optimize it
3023 set npad [expr {-1 - $z + $isarrow}]
3024 set offs [incrange $offs $col $npad]
3025 insert_pad $y0 $x0 $npad
3027 optimize_rows $y0 $x0 $row
3029 set z [lindex $offs $col]
3030 set x0 [expr {$col + $z}]
3031 set z0 [lindex $rowoffsets $y0 $x0]
3032 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3033 # Line currently goes right too much;
3034 # insert pads in this line and adjust the next's rowoffsets
3035 set npad [expr {$z - 1 + $isarrow}]
3036 set y1 [expr {$row + 1}]
3037 set offs2 [lindex $rowoffsets $y1]
3041 if {$z eq {} || $x1 + $z < $col} continue
3042 if {$x1 + $z > $col} {
3045 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3048 set pad [ntimes $npad {}]
3049 set idlist [eval linsert \$idlist $col $pad]
3050 set tmp [eval linsert \$offs $col $pad]
3052 set offs [incrange $tmp $col [expr {-$npad}]]
3053 set z [lindex $offs $col]
3056 if {$z0 eq {} && !$isarrow} {
3057 # this line links to its first child on row $row-2
3058 set rm2 [expr {$row - 2}]
3059 set id [lindex $displayorder $rm2]
3060 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3062 set z0 [expr {$xc - $x0}]
3065 # avoid lines jigging left then immediately right
3066 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3067 insert_pad $y0 $x0 1
3068 set offs [incrange $offs $col 1]
3069 optimize_rows $y0 [expr {$x0 + 1}] $row
3074 # Find the first column that doesn't have a line going right
3075 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3076 set o [lindex $offs $col]
3078 # check if this is the link to the first child
3079 set id [lindex $idlist $col]
3080 set ranges [rowranges $id]
3081 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3082 # it is, work out offset to child
3083 set y0 [expr {$row - 1}]
3084 set id [lindex $displayorder $y0]
3085 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3087 set o [expr {$x0 - $col}]
3091 if {$o eq {} || $o <= 0} break
3093 # Insert a pad at that column as long as it has a line and
3094 # isn't the last column, and adjust the next row' offsets
3095 if {$o ne {} && [incr col] < [llength $idlist]} {
3096 set y1 [expr {$row + 1}]
3097 set offs2 [lindex $rowoffsets $y1]
3101 if {$z eq {} || $x1 + $z < $col} continue
3102 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3105 set idlist [linsert $idlist $col {}]
3106 set tmp [linsert $offs $col {}]
3108 set offs [incrange $tmp $col -1]
3111 lset rowidlist $row $idlist
3112 lset rowoffsets $row $offs
3118 global canvx0 linespc
3119 return [expr {$canvx0 + $col * $linespc}]
3123 global canvy0 linespc
3124 return [expr {$canvy0 + $row * $linespc}]
3127 proc linewidth {id} {
3128 global thickerline lthickness
3131 if {[info exists thickerline] && $id eq $thickerline} {
3132 set wid [expr {2 * $lthickness}]
3137 proc rowranges {id} {
3138 global phase idrowranges commitrow rowlaidout rowrangelist curview
3142 ([info exists commitrow($curview,$id)]
3143 && $commitrow($curview,$id) < $rowlaidout)} {
3144 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3145 } elseif {[info exists idrowranges($id)]} {
3146 set ranges $idrowranges($id)
3149 foreach rid $ranges {
3150 lappend linenos $commitrow($curview,$rid)
3152 if {$linenos ne {}} {
3153 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3158 # work around tk8.4 refusal to draw arrows on diagonal segments
3159 proc adjarrowhigh {coords} {
3162 set x0 [lindex $coords 0]
3163 set x1 [lindex $coords 2]
3165 set y0 [lindex $coords 1]
3166 set y1 [lindex $coords 3]
3167 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3168 # we have a nearby vertical segment, just trim off the diag bit
3169 set coords [lrange $coords 2 end]
3171 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3172 set xi [expr {$x0 - $slope * $linespc / 2}]
3173 set yi [expr {$y0 - $linespc / 2}]
3174 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3180 proc drawlineseg {id row endrow arrowlow} {
3181 global rowidlist displayorder iddrawn linesegs
3182 global canv colormap linespc curview maxlinelen
3184 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3185 set le [expr {$row + 1}]
3188 set c [lsearch -exact [lindex $rowidlist $le] $id]
3194 set x [lindex $displayorder $le]
3199 if {[info exists iddrawn($x)] || $le == $endrow} {
3200 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3216 if {[info exists linesegs($id)]} {
3217 set lines $linesegs($id)
3219 set r0 [lindex $li 0]
3221 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3231 set li [lindex $lines [expr {$i-1}]]
3232 set r1 [lindex $li 1]
3233 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3238 set x [lindex $cols [expr {$le - $row}]]
3239 set xp [lindex $cols [expr {$le - 1 - $row}]]
3240 set dir [expr {$xp - $x}]
3242 set ith [lindex $lines $i 2]
3243 set coords [$canv coords $ith]
3244 set ah [$canv itemcget $ith -arrow]
3245 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3246 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3247 if {$x2 ne {} && $x - $x2 == $dir} {
3248 set coords [lrange $coords 0 end-2]
3251 set coords [list [xc $le $x] [yc $le]]
3254 set itl [lindex $lines [expr {$i-1}] 2]
3255 set al [$canv itemcget $itl -arrow]
3256 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3257 } elseif {$arrowlow &&
3258 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3261 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3262 for {set y $le} {[incr y -1] > $row} {} {
3264 set xp [lindex $cols [expr {$y - 1 - $row}]]
3265 set ndir [expr {$xp - $x}]
3266 if {$dir != $ndir || $xp < 0} {
3267 lappend coords [xc $y $x] [yc $y]
3273 # join parent line to first child
3274 set ch [lindex $displayorder $row]
3275 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3277 puts "oops: drawlineseg: child $ch not on row $row"
3280 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3281 } elseif {$xc > $x + 1} {
3282 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3286 lappend coords [xc $row $x] [yc $row]
3288 set xn [xc $row $xp]
3290 # work around tk8.4 refusal to draw arrows on diagonal segments
3291 if {$arrowlow && $xn != [lindex $coords end-1]} {
3292 if {[llength $coords] < 4 ||
3293 [lindex $coords end-3] != [lindex $coords end-1] ||
3294 [lindex $coords end] - $yn > 2 * $linespc} {
3295 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3296 set yo [yc [expr {$row + 0.5}]]
3297 lappend coords $xn $yo $xn $yn
3300 lappend coords $xn $yn
3305 set coords [adjarrowhigh $coords]
3308 set t [$canv create line $coords -width [linewidth $id] \
3309 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3312 set lines [linsert $lines $i [list $row $le $t]]
3314 $canv coords $ith $coords
3315 if {$arrow ne $ah} {
3316 $canv itemconf $ith -arrow $arrow
3318 lset lines $i 0 $row
3321 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3322 set ndir [expr {$xo - $xp}]
3323 set clow [$canv coords $itl]
3324 if {$dir == $ndir} {
3325 set clow [lrange $clow 2 end]
3327 set coords [concat $coords $clow]
3329 lset lines [expr {$i-1}] 1 $le
3331 set coords [adjarrowhigh $coords]
3334 # coalesce two pieces
3336 set b [lindex $lines [expr {$i-1}] 0]
3337 set e [lindex $lines $i 1]
3338 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3340 $canv coords $itl $coords
3341 if {$arrow ne $al} {
3342 $canv itemconf $itl -arrow $arrow
3346 set linesegs($id) $lines
3350 proc drawparentlinks {id row} {
3351 global rowidlist canv colormap curview parentlist
3354 set rowids [lindex $rowidlist $row]
3355 set col [lsearch -exact $rowids $id]
3356 if {$col < 0} return
3357 set olds [lindex $parentlist $row]
3358 set row2 [expr {$row + 1}]
3359 set x [xc $row $col]
3362 set ids [lindex $rowidlist $row2]
3363 # rmx = right-most X coord used
3366 set i [lsearch -exact $ids $p]
3368 puts "oops, parent $p of $id not in list"
3371 set x2 [xc $row2 $i]
3375 if {[lsearch -exact $rowids $p] < 0} {
3376 # drawlineseg will do this one for us
3380 # should handle duplicated parents here...
3381 set coords [list $x $y]
3382 if {$i < $col - 1} {
3383 lappend coords [xc $row [expr {$i + 1}]] $y
3384 } elseif {$i > $col + 1} {
3385 lappend coords [xc $row [expr {$i - 1}]] $y
3387 lappend coords $x2 $y2
3388 set t [$canv create line $coords -width [linewidth $p] \
3389 -fill $colormap($p) -tags lines.$p]
3393 if {$rmx > [lindex $idpos($id) 1]} {
3394 lset idpos($id) 1 $rmx
3399 proc drawlines {id} {
3402 $canv itemconf lines.$id -width [linewidth $id]
3405 proc drawcmittext {id row col} {
3406 global linespc canv canv2 canv3 canvy0 fgcolor curview
3407 global commitlisted commitinfo rowidlist parentlist
3408 global rowtextx idpos idtags idheads idotherrefs
3409 global linehtag linentag linedtag markingmatches
3410 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3412 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3413 set listed [lindex $commitlisted $row]
3414 if {$id eq $nullid} {
3416 } elseif {$id eq $nullid2} {
3419 set ofill [expr {$listed != 0? "blue": "white"}]
3421 set x [xc $row $col]
3423 set orad [expr {$linespc / 3}]
3425 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3426 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3427 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3428 } elseif {$listed == 2} {
3429 # triangle pointing left for left-side commits
3430 set t [$canv create polygon \
3431 [expr {$x - $orad}] $y \
3432 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3433 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3434 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3436 # triangle pointing right for right-side commits
3437 set t [$canv create polygon \
3438 [expr {$x + $orad - 1}] $y \
3439 [expr {$x - $orad}] [expr {$y - $orad}] \
3440 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3441 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3444 $canv bind $t <1> {selcanvline {} %x %y}
3445 set rmx [llength [lindex $rowidlist $row]]
3446 set olds [lindex $parentlist $row]
3448 set nextids [lindex $rowidlist [expr {$row + 1}]]
3450 set i [lsearch -exact $nextids $p]
3456 set xt [xc $row $rmx]
3457 set rowtextx($row) $xt
3458 set idpos($id) [list $x $xt $y]
3459 if {[info exists idtags($id)] || [info exists idheads($id)]
3460 || [info exists idotherrefs($id)]} {
3461 set xt [drawtags $id $x $xt $y]
3463 set headline [lindex $commitinfo($id) 0]
3464 set name [lindex $commitinfo($id) 1]
3465 set date [lindex $commitinfo($id) 2]
3466 set date [formatdate $date]
3469 set isbold [ishighlighted $row]
3471 lappend boldrows $row
3474 lappend boldnamerows $row
3478 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3479 -text $headline -font $font -tags text]
3480 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3481 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3482 -text $name -font $nfont -tags text]
3483 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3484 -text $date -font $mainfont -tags text]
3485 set xr [expr {$xt + [font measure $mainfont $headline]}]
3486 if {$markingmatches} {
3487 markrowmatches $row $headline $name
3489 if {$xr > $canvxmax} {
3495 proc drawcmitrow {row} {
3496 global displayorder rowidlist
3498 global commitinfo parentlist numcommits
3499 global filehighlight fhighlights findstring nhighlights
3500 global hlview vhighlights
3501 global highlight_related rhighlights
3503 if {$row >= $numcommits} return
3505 set id [lindex $displayorder $row]
3506 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3507 askvhighlight $row $id
3509 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3510 askfilehighlight $row $id
3512 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3513 askfindhighlight $row $id
3515 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3516 askrelhighlight $row $id
3518 if {[info exists iddrawn($id)]} return
3519 set col [lsearch -exact [lindex $rowidlist $row] $id]
3521 puts "oops, row $row id $id not in list"
3524 if {![info exists commitinfo($id)]} {
3528 drawcmittext $id $row $col
3532 proc drawcommits {row {endrow {}}} {
3533 global numcommits iddrawn displayorder curview
3534 global parentlist rowidlist
3539 if {$endrow eq {}} {
3542 if {$endrow >= $numcommits} {
3543 set endrow [expr {$numcommits - 1}]
3546 # make the lines join to already-drawn rows either side
3547 set r [expr {$row - 1}]
3548 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3551 set er [expr {$endrow + 1}]
3552 if {$er >= $numcommits ||
3553 ![info exists iddrawn([lindex $displayorder $er])]} {
3556 for {} {$r <= $er} {incr r} {
3557 set id [lindex $displayorder $r]
3558 set wasdrawn [info exists iddrawn($id)]
3560 if {$r == $er} break
3561 set nextid [lindex $displayorder [expr {$r + 1}]]
3562 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3563 catch {unset prevlines}
3566 drawparentlinks $id $r
3568 if {[info exists lineends($r)]} {
3569 foreach lid $lineends($r) {
3570 unset prevlines($lid)
3573 set rowids [lindex $rowidlist $r]
3574 foreach lid $rowids {
3575 if {$lid eq {}} continue
3577 # see if this is the first child of any of its parents
3578 foreach p [lindex $parentlist $r] {
3579 if {[lsearch -exact $rowids $p] < 0} {
3580 # make this line extend up to the child
3581 set le [drawlineseg $p $r $er 0]
3582 lappend lineends($le) $p
3586 } elseif {![info exists prevlines($lid)]} {
3587 set le [drawlineseg $lid $r $er 1]
3588 lappend lineends($le) $lid
3589 set prevlines($lid) 1
3595 proc drawfrac {f0 f1} {
3598 set ymax [lindex [$canv cget -scrollregion] 3]
3599 if {$ymax eq {} || $ymax == 0} return
3600 set y0 [expr {int($f0 * $ymax)}]
3601 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3602 set y1 [expr {int($f1 * $ymax)}]
3603 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3604 drawcommits $row $endrow
3607 proc drawvisible {} {
3609 eval drawfrac [$canv yview]
3612 proc clear_display {} {
3613 global iddrawn linesegs
3614 global vhighlights fhighlights nhighlights rhighlights
3617 catch {unset iddrawn}
3618 catch {unset linesegs}
3619 catch {unset vhighlights}
3620 catch {unset fhighlights}
3621 catch {unset nhighlights}
3622 catch {unset rhighlights}
3625 proc findcrossings {id} {
3626 global rowidlist parentlist numcommits rowoffsets displayorder
3630 foreach {s e} [rowranges $id] {
3631 if {$e >= $numcommits} {
3632 set e [expr {$numcommits - 1}]
3634 if {$e <= $s} continue
3635 set x [lsearch -exact [lindex $rowidlist $e] $id]
3637 puts "findcrossings: oops, no [shortids $id] in row $e"
3640 for {set row $e} {[incr row -1] >= $s} {} {
3641 set olds [lindex $parentlist $row]
3642 set kid [lindex $displayorder $row]
3643 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3644 if {$kidx < 0} continue
3645 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3647 set px [lsearch -exact $nextrow $p]
3648 if {$px < 0} continue
3649 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3650 if {[lsearch -exact $ccross $p] >= 0} continue
3651 if {$x == $px + ($kidx < $px? -1: 1)} {
3653 } elseif {[lsearch -exact $cross $p] < 0} {
3658 set inc [lindex $rowoffsets $row $x]
3659 if {$inc eq {}} break
3663 return [concat $ccross {{}} $cross]
3666 proc assigncolor {id} {
3667 global colormap colors nextcolor
3668 global commitrow parentlist children children curview
3670 if {[info exists colormap($id)]} return
3671 set ncolors [llength $colors]
3672 if {[info exists children($curview,$id)]} {
3673 set kids $children($curview,$id)
3677 if {[llength $kids] == 1} {
3678 set child [lindex $kids 0]
3679 if {[info exists colormap($child)]
3680 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3681 set colormap($id) $colormap($child)
3687 foreach x [findcrossings $id] {
3689 # delimiter between corner crossings and other crossings
3690 if {[llength $badcolors] >= $ncolors - 1} break
3691 set origbad $badcolors
3693 if {[info exists colormap($x)]
3694 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3695 lappend badcolors $colormap($x)
3698 if {[llength $badcolors] >= $ncolors} {
3699 set badcolors $origbad
3701 set origbad $badcolors
3702 if {[llength $badcolors] < $ncolors - 1} {
3703 foreach child $kids {
3704 if {[info exists colormap($child)]
3705 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3706 lappend badcolors $colormap($child)
3708 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3709 if {[info exists colormap($p)]
3710 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3711 lappend badcolors $colormap($p)
3715 if {[llength $badcolors] >= $ncolors} {
3716 set badcolors $origbad
3719 for {set i 0} {$i <= $ncolors} {incr i} {
3720 set c [lindex $colors $nextcolor]
3721 if {[incr nextcolor] >= $ncolors} {
3724 if {[lsearch -exact $badcolors $c]} break
3726 set colormap($id) $c
3729 proc bindline {t id} {
3732 $canv bind $t <Enter> "lineenter %x %y $id"
3733 $canv bind $t <Motion> "linemotion %x %y $id"
3734 $canv bind $t <Leave> "lineleave $id"
3735 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3738 proc drawtags {id x xt y1} {
3739 global idtags idheads idotherrefs mainhead
3740 global linespc lthickness
3741 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3746 if {[info exists idtags($id)]} {
3747 set marks $idtags($id)
3748 set ntags [llength $marks]
3750 if {[info exists idheads($id)]} {
3751 set marks [concat $marks $idheads($id)]
3752 set nheads [llength $idheads($id)]
3754 if {[info exists idotherrefs($id)]} {
3755 set marks [concat $marks $idotherrefs($id)]
3761 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3762 set yt [expr {$y1 - 0.5 * $linespc}]
3763 set yb [expr {$yt + $linespc - 1}]
3767 foreach tag $marks {
3769 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3770 set wid [font measure [concat $mainfont bold] $tag]
3772 set wid [font measure $mainfont $tag]
3776 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3778 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3779 -width $lthickness -fill black -tags tag.$id]
3781 foreach tag $marks x $xvals wid $wvals {
3782 set xl [expr {$x + $delta}]
3783 set xr [expr {$x + $delta + $wid + $lthickness}]
3785 if {[incr ntags -1] >= 0} {
3787 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3788 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3789 -width 1 -outline black -fill yellow -tags tag.$id]
3790 $canv bind $t <1> [list showtag $tag 1]
3791 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3793 # draw a head or other ref
3794 if {[incr nheads -1] >= 0} {
3796 if {$tag eq $mainhead} {
3802 set xl [expr {$xl - $delta/2}]
3803 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3804 -width 1 -outline black -fill $col -tags tag.$id
3805 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3806 set rwid [font measure $mainfont $remoteprefix]
3807 set xi [expr {$x + 1}]
3808 set yti [expr {$yt + 1}]
3809 set xri [expr {$x + $rwid}]
3810 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3811 -width 0 -fill "#ffddaa" -tags tag.$id
3814 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3815 -font $font -tags [list tag.$id text]]
3817 $canv bind $t <1> [list showtag $tag 1]
3818 } elseif {$nheads >= 0} {
3819 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3825 proc xcoord {i level ln} {
3826 global canvx0 xspc1 xspc2
3828 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3829 if {$i > 0 && $i == $level} {
3830 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3831 } elseif {$i > $level} {
3832 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3837 proc show_status {msg} {
3838 global canv mainfont fgcolor
3841 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3842 -tags text -fill $fgcolor
3845 # Insert a new commit as the child of the commit on row $row.
3846 # The new commit will be displayed on row $row and the commits
3847 # on that row and below will move down one row.
3848 proc insertrow {row newcmit} {
3849 global displayorder parentlist commitlisted children
3850 global commitrow curview rowidlist rowoffsets numcommits
3851 global rowrangelist rowlaidout rowoptim numcommits
3852 global selectedline rowchk commitidx
3854 if {$row >= $numcommits} {
3855 puts "oops, inserting new row $row but only have $numcommits rows"
3858 set p [lindex $displayorder $row]
3859 set displayorder [linsert $displayorder $row $newcmit]
3860 set parentlist [linsert $parentlist $row $p]
3861 set kids $children($curview,$p)
3862 lappend kids $newcmit
3863 set children($curview,$p) $kids
3864 set children($curview,$newcmit) {}
3865 set commitlisted [linsert $commitlisted $row 1]
3866 set l [llength $displayorder]
3867 for {set r $row} {$r < $l} {incr r} {
3868 set id [lindex $displayorder $r]
3869 set commitrow($curview,$id) $r
3871 incr commitidx($curview)
3873 set idlist [lindex $rowidlist $row]
3874 set offs [lindex $rowoffsets $row]
3877 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3883 if {[llength $kids] == 1} {
3884 set col [lsearch -exact $idlist $p]
3885 lset idlist $col $newcmit
3887 set col [llength $idlist]
3888 lappend idlist $newcmit
3890 lset rowoffsets $row $offs
3892 set rowidlist [linsert $rowidlist $row $idlist]
3893 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3895 set rowrangelist [linsert $rowrangelist $row {}]
3896 if {[llength $kids] > 1} {
3897 set rp1 [expr {$row + 1}]
3898 set ranges [lindex $rowrangelist $rp1]
3899 if {$ranges eq {}} {
3900 set ranges [list $newcmit $p]
3901 } elseif {[lindex $ranges end-1] eq $p} {
3902 lset ranges end-1 $newcmit
3904 lset rowrangelist $rp1 $ranges
3907 catch {unset rowchk}
3913 if {[info exists selectedline] && $selectedline >= $row} {
3919 # Remove a commit that was inserted with insertrow on row $row.
3920 proc removerow {row} {
3921 global displayorder parentlist commitlisted children
3922 global commitrow curview rowidlist rowoffsets numcommits
3923 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3924 global linesegends selectedline rowchk commitidx
3926 if {$row >= $numcommits} {
3927 puts "oops, removing row $row but only have $numcommits rows"
3930 set rp1 [expr {$row + 1}]
3931 set id [lindex $displayorder $row]
3932 set p [lindex $parentlist $row]
3933 set displayorder [lreplace $displayorder $row $row]
3934 set parentlist [lreplace $parentlist $row $row]
3935 set commitlisted [lreplace $commitlisted $row $row]
3936 set kids $children($curview,$p)
3937 set i [lsearch -exact $kids $id]
3939 set kids [lreplace $kids $i $i]
3940 set children($curview,$p) $kids
3942 set l [llength $displayorder]
3943 for {set r $row} {$r < $l} {incr r} {
3944 set id [lindex $displayorder $r]
3945 set commitrow($curview,$id) $r
3947 incr commitidx($curview) -1
3949 set rowidlist [lreplace $rowidlist $row $row]
3950 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3952 set offs [lindex $rowoffsets $row]
3953 set offs [lreplace $offs end end]
3954 lset rowoffsets $row $offs
3957 set rowrangelist [lreplace $rowrangelist $row $row]
3958 if {[llength $kids] > 0} {
3959 set ranges [lindex $rowrangelist $row]
3960 if {[lindex $ranges end-1] eq $id} {
3961 set ranges [lreplace $ranges end-1 end]
3962 lset rowrangelist $row $ranges
3966 catch {unset rowchk}
3972 if {[info exists selectedline] && $selectedline > $row} {
3973 incr selectedline -1
3978 # Don't change the text pane cursor if it is currently the hand cursor,
3979 # showing that we are over a sha1 ID link.
3980 proc settextcursor {c} {
3981 global ctext curtextcursor
3983 if {[$ctext cget -cursor] == $curtextcursor} {
3984 $ctext config -cursor $c
3986 set curtextcursor $c
3989 proc nowbusy {what} {
3992 if {[array names isbusy] eq {}} {
3993 . config -cursor watch
3999 proc notbusy {what} {
4000 global isbusy maincursor textcursor
4002 catch {unset isbusy($what)}
4003 if {[array names isbusy] eq {}} {
4004 . config -cursor $maincursor
4005 settextcursor $textcursor
4009 proc findmatches {f} {
4010 global findtype findstring
4011 if {$findtype == "Regexp"} {
4012 set matches [regexp -indices -all -inline $findstring $f]
4015 if {$findtype == "IgnCase"} {
4016 set f [string tolower $f]
4017 set fs [string tolower $fs]
4021 set l [string length $fs]
4022 while {[set j [string first $fs $f $i]] >= 0} {
4023 lappend matches [list $j [expr {$j+$l-1}]]
4024 set i [expr {$j + $l}]
4030 proc dofind {{rev 0}} {
4031 global findstring findstartline findcurline selectedline numcommits
4034 cancel_next_highlight
4036 if {$findstring eq {} || $numcommits == 0} return
4037 if {![info exists selectedline]} {
4038 set findstartline [lindex [visiblerows] $rev]
4040 set findstartline $selectedline
4042 set findcurline $findstartline
4047 set findcurline $findstartline
4048 if {$findcurline == 0} {
4049 set findcurline $numcommits
4056 proc findnext {restart} {
4058 if {![info exists findcurline]} {
4072 if {![info exists findcurline]} {
4081 global commitdata commitinfo numcommits findstring findpattern findloc
4082 global findstartline findcurline markingmatches displayorder
4084 set fldtypes {Headline Author Date Committer CDate Comments}
4085 set l [expr {$findcurline + 1}]
4086 if {$l >= $numcommits} {
4089 if {$l <= $findstartline} {
4090 set lim [expr {$findstartline + 1}]
4094 if {$lim - $l > 500} {
4095 set lim [expr {$l + 500}]
4098 for {} {$l < $lim} {incr l} {
4099 set id [lindex $displayorder $l]
4100 if {![doesmatch $commitdata($id)]} continue
4101 if {![info exists commitinfo($id)]} {
4104 set info $commitinfo($id)
4105 foreach f $info ty $fldtypes {
4106 if {($findloc eq "All fields" || $findloc eq $ty) &&
4108 set markingmatches 1
4115 if {$l == $findstartline + 1} {
4121 set findcurline [expr {$l - 1}]
4125 proc findmorerev {} {
4126 global commitdata commitinfo numcommits findstring findpattern findloc
4127 global findstartline findcurline markingmatches displayorder
4129 set fldtypes {Headline Author Date Committer CDate Comments}
4135 if {$l >= $findstartline} {
4136 set lim [expr {$findstartline - 1}]
4140 if {$l - $lim > 500} {
4141 set lim [expr {$l - 500}]
4144 for {} {$l > $lim} {incr l -1} {
4145 set id [lindex $displayorder $l]
4146 if {![doesmatch $commitdata($id)]} continue
4147 if {![info exists commitinfo($id)]} {
4150 set info $commitinfo($id)
4151 foreach f $info ty $fldtypes {
4152 if {($findloc eq "All fields" || $findloc eq $ty) &&
4154 set markingmatches 1
4167 set findcurline [expr {$l + 1}]
4171 proc findselectline {l} {
4172 global findloc commentend ctext
4174 if {$findloc == "All fields" || $findloc == "Comments"} {
4175 # highlight the matches in the comments
4176 set f [$ctext get 1.0 $commentend]
4177 set matches [findmatches $f]
4178 foreach match $matches {
4179 set start [lindex $match 0]
4180 set end [expr {[lindex $match 1] + 1}]
4181 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4186 # mark the bits of a headline or author that match a find string
4187 proc markmatches {canv l str tag matches font} {
4188 set bbox [$canv bbox $tag]
4189 set x0 [lindex $bbox 0]
4190 set y0 [lindex $bbox 1]
4191 set y1 [lindex $bbox 3]
4192 foreach match $matches {
4193 set start [lindex $match 0]
4194 set end [lindex $match 1]
4195 if {$start > $end} continue
4196 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4197 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4198 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4199 [expr {$x0+$xlen+2}] $y1 \
4200 -outline {} -tags [list match$l matches] -fill yellow]
4205 proc unmarkmatches {} {
4206 global findids markingmatches findcurline
4208 allcanvs delete matches
4209 catch {unset findids}
4210 set markingmatches 0
4211 catch {unset findcurline}
4214 proc selcanvline {w x y} {
4215 global canv canvy0 ctext linespc
4217 set ymax [lindex [$canv cget -scrollregion] 3]
4218 if {$ymax == {}} return
4219 set yfrac [lindex [$canv yview] 0]
4220 set y [expr {$y + $yfrac * $ymax}]
4221 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4226 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4232 proc commit_descriptor {p} {
4234 if {![info exists commitinfo($p)]} {
4238 if {[llength $commitinfo($p)] > 1} {
4239 set l [lindex $commitinfo($p) 0]
4244 # append some text to the ctext widget, and make any SHA1 ID
4245 # that we know about be a clickable link.
4246 proc appendwithlinks {text tags} {
4247 global ctext commitrow linknum curview
4249 set start [$ctext index "end - 1c"]
4250 $ctext insert end $text $tags
4251 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4255 set linkid [string range $text $s $e]
4256 if {![info exists commitrow($curview,$linkid)]} continue
4258 $ctext tag add link "$start + $s c" "$start + $e c"
4259 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4260 $ctext tag bind link$linknum <1> \
4261 [list selectline $commitrow($curview,$linkid) 1]
4264 $ctext tag conf link -foreground blue -underline 1
4265 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4266 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4269 proc viewnextline {dir} {
4273 set ymax [lindex [$canv cget -scrollregion] 3]
4274 set wnow [$canv yview]
4275 set wtop [expr {[lindex $wnow 0] * $ymax}]
4276 set newtop [expr {$wtop + $dir * $linespc}]
4279 } elseif {$newtop > $ymax} {
4282 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4285 # add a list of tag or branch names at position pos
4286 # returns the number of names inserted
4287 proc appendrefs {pos ids var} {
4288 global ctext commitrow linknum curview $var maxrefs
4290 if {[catch {$ctext index $pos}]} {
4293 $ctext conf -state normal
4294 $ctext delete $pos "$pos lineend"
4297 foreach tag [set $var\($id\)] {
4298 lappend tags [list $tag $id]
4301 if {[llength $tags] > $maxrefs} {
4302 $ctext insert $pos "many ([llength $tags])"
4304 set tags [lsort -index 0 -decreasing $tags]
4307 set id [lindex $ti 1]
4310 $ctext tag delete $lk
4311 $ctext insert $pos $sep
4312 $ctext insert $pos [lindex $ti 0] $lk
4313 if {[info exists commitrow($curview,$id)]} {
4314 $ctext tag conf $lk -foreground blue
4315 $ctext tag bind $lk <1> \
4316 [list selectline $commitrow($curview,$id) 1]
4317 $ctext tag conf $lk -underline 1
4318 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4319 $ctext tag bind $lk <Leave> \
4320 { %W configure -cursor $curtextcursor }
4325 $ctext conf -state disabled
4326 return [llength $tags]
4329 # called when we have finished computing the nearby tags
4330 proc dispneartags {delay} {
4331 global selectedline currentid showneartags tagphase
4333 if {![info exists selectedline] || !$showneartags} return
4334 after cancel dispnexttag
4336 after 200 dispnexttag
4339 after idle dispnexttag
4344 proc dispnexttag {} {
4345 global selectedline currentid showneartags tagphase ctext
4347 if {![info exists selectedline] || !$showneartags} return
4348 switch -- $tagphase {
4350 set dtags [desctags $currentid]
4352 appendrefs precedes $dtags idtags
4356 set atags [anctags $currentid]
4358 appendrefs follows $atags idtags
4362 set dheads [descheads $currentid]
4363 if {$dheads ne {}} {
4364 if {[appendrefs branch $dheads idheads] > 1
4365 && [$ctext get "branch -3c"] eq "h"} {
4366 # turn "Branch" into "Branches"
4367 $ctext conf -state normal
4368 $ctext insert "branch -2c" "es"
4369 $ctext conf -state disabled
4374 if {[incr tagphase] <= 2} {
4375 after idle dispnexttag
4379 proc selectline {l isnew} {
4380 global canv canv2 canv3 ctext commitinfo selectedline
4381 global displayorder linehtag linentag linedtag
4382 global canvy0 linespc parentlist children curview
4383 global currentid sha1entry
4384 global commentend idtags linknum
4385 global mergemax numcommits pending_select
4386 global cmitmode showneartags allcommits
4388 catch {unset pending_select}
4391 cancel_next_highlight
4392 if {$l < 0 || $l >= $numcommits} return
4393 set y [expr {$canvy0 + $l * $linespc}]
4394 set ymax [lindex [$canv cget -scrollregion] 3]
4395 set ytop [expr {$y - $linespc - 1}]
4396 set ybot [expr {$y + $linespc + 1}]
4397 set wnow [$canv yview]
4398 set wtop [expr {[lindex $wnow 0] * $ymax}]
4399 set wbot [expr {[lindex $wnow 1] * $ymax}]
4400 set wh [expr {$wbot - $wtop}]
4402 if {$ytop < $wtop} {
4403 if {$ybot < $wtop} {
4404 set newtop [expr {$y - $wh / 2.0}]
4407 if {$newtop > $wtop - $linespc} {
4408 set newtop [expr {$wtop - $linespc}]
4411 } elseif {$ybot > $wbot} {
4412 if {$ytop > $wbot} {
4413 set newtop [expr {$y - $wh / 2.0}]
4415 set newtop [expr {$ybot - $wh}]
4416 if {$newtop < $wtop + $linespc} {
4417 set newtop [expr {$wtop + $linespc}]
4421 if {$newtop != $wtop} {
4425 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4429 if {![info exists linehtag($l)]} return
4431 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4432 -tags secsel -fill [$canv cget -selectbackground]]
4434 $canv2 delete secsel
4435 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4436 -tags secsel -fill [$canv2 cget -selectbackground]]
4438 $canv3 delete secsel
4439 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4440 -tags secsel -fill [$canv3 cget -selectbackground]]
4444 addtohistory [list selectline $l 0]
4449 set id [lindex $displayorder $l]
4451 $sha1entry delete 0 end
4452 $sha1entry insert 0 $id
4453 $sha1entry selection from 0
4454 $sha1entry selection to end
4457 $ctext conf -state normal
4460 set info $commitinfo($id)
4461 set date [formatdate [lindex $info 2]]
4462 $ctext insert end "Author: [lindex $info 1] $date\n"
4463 set date [formatdate [lindex $info 4]]
4464 $ctext insert end "Committer: [lindex $info 3] $date\n"
4465 if {[info exists idtags($id)]} {
4466 $ctext insert end "Tags:"
4467 foreach tag $idtags($id) {
4468 $ctext insert end " $tag"
4470 $ctext insert end "\n"
4474 set olds [lindex $parentlist $l]
4475 if {[llength $olds] > 1} {
4478 if {$np >= $mergemax} {
4483 $ctext insert end "Parent: " $tag
4484 appendwithlinks [commit_descriptor $p] {}
4489 append headers "Parent: [commit_descriptor $p]"
4493 foreach c $children($curview,$id) {
4494 append headers "Child: [commit_descriptor $c]"
4497 # make anything that looks like a SHA1 ID be a clickable link
4498 appendwithlinks $headers {}
4499 if {$showneartags} {
4500 if {![info exists allcommits]} {
4503 $ctext insert end "Branch: "
4504 $ctext mark set branch "end -1c"
4505 $ctext mark gravity branch left
4506 $ctext insert end "\nFollows: "
4507 $ctext mark set follows "end -1c"
4508 $ctext mark gravity follows left
4509 $ctext insert end "\nPrecedes: "
4510 $ctext mark set precedes "end -1c"
4511 $ctext mark gravity precedes left
4512 $ctext insert end "\n"
4515 $ctext insert end "\n"
4516 set comment [lindex $info 5]
4517 if {[string first "\r" $comment] >= 0} {
4518 set comment [string map {"\r" "\n "} $comment]
4520 appendwithlinks $comment {comment}
4522 $ctext tag remove found 1.0 end
4523 $ctext conf -state disabled
4524 set commentend [$ctext index "end - 1c"]
4526 init_flist "Comments"
4527 if {$cmitmode eq "tree"} {
4529 } elseif {[llength $olds] <= 1} {
4536 proc selfirstline {} {
4541 proc sellastline {} {
4544 set l [expr {$numcommits - 1}]
4548 proc selnextline {dir} {
4550 if {![info exists selectedline]} return
4551 set l [expr {$selectedline + $dir}]
4556 proc selnextpage {dir} {
4557 global canv linespc selectedline numcommits
4559 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4563 allcanvs yview scroll [expr {$dir * $lpp}] units
4565 if {![info exists selectedline]} return
4566 set l [expr {$selectedline + $dir * $lpp}]
4569 } elseif {$l >= $numcommits} {
4570 set l [expr $numcommits - 1]
4576 proc unselectline {} {
4577 global selectedline currentid
4579 catch {unset selectedline}
4580 catch {unset currentid}
4581 allcanvs delete secsel
4583 cancel_next_highlight
4586 proc reselectline {} {
4589 if {[info exists selectedline]} {
4590 selectline $selectedline 0
4594 proc addtohistory {cmd} {
4595 global history historyindex curview
4597 set elt [list $curview $cmd]
4598 if {$historyindex > 0
4599 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4603 if {$historyindex < [llength $history]} {
4604 set history [lreplace $history $historyindex end $elt]
4606 lappend history $elt
4609 if {$historyindex > 1} {
4610 .tf.bar.leftbut conf -state normal
4612 .tf.bar.leftbut conf -state disabled
4614 .tf.bar.rightbut conf -state disabled
4620 set view [lindex $elt 0]
4621 set cmd [lindex $elt 1]
4622 if {$curview != $view} {
4629 global history historyindex
4631 if {$historyindex > 1} {
4632 incr historyindex -1
4633 godo [lindex $history [expr {$historyindex - 1}]]
4634 .tf.bar.rightbut conf -state normal
4636 if {$historyindex <= 1} {
4637 .tf.bar.leftbut conf -state disabled
4642 global history historyindex
4644 if {$historyindex < [llength $history]} {
4645 set cmd [lindex $history $historyindex]
4648 .tf.bar.leftbut conf -state normal
4650 if {$historyindex >= [llength $history]} {
4651 .tf.bar.rightbut conf -state disabled
4656 global treefilelist treeidlist diffids diffmergeid treepending
4657 global nullid nullid2
4660 catch {unset diffmergeid}
4661 if {![info exists treefilelist($id)]} {
4662 if {![info exists treepending]} {
4663 if {$id eq $nullid} {
4664 set cmd [list | git ls-files]
4665 } elseif {$id eq $nullid2} {
4666 set cmd [list | git ls-files --stage -t]
4668 set cmd [list | git ls-tree -r $id]
4670 if {[catch {set gtf [open $cmd r]}]} {
4674 set treefilelist($id) {}
4675 set treeidlist($id) {}
4676 fconfigure $gtf -blocking 0
4677 filerun $gtf [list gettreeline $gtf $id]
4684 proc gettreeline {gtf id} {
4685 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4688 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4689 if {$diffids eq $nullid} {
4692 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4693 set i [string first "\t" $line]
4694 if {$i < 0} continue
4695 set sha1 [lindex $line 2]
4696 set fname [string range $line [expr {$i+1}] end]
4697 if {[string index $fname 0] eq "\""} {
4698 set fname [lindex $fname 0]
4700 lappend treeidlist($id) $sha1
4702 lappend treefilelist($id) $fname
4705 return [expr {$nl >= 1000? 2: 1}]
4709 if {$cmitmode ne "tree"} {
4710 if {![info exists diffmergeid]} {
4711 gettreediffs $diffids
4713 } elseif {$id ne $diffids} {
4722 global treefilelist treeidlist diffids nullid nullid2
4723 global ctext commentend
4725 set i [lsearch -exact $treefilelist($diffids) $f]
4727 puts "oops, $f not in list for id $diffids"
4730 if {$diffids eq $nullid} {
4731 if {[catch {set bf [open $f r]} err]} {
4732 puts "oops, can't read $f: $err"
4736 set blob [lindex $treeidlist($diffids) $i]
4737 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4738 puts "oops, error reading blob $blob: $err"
4742 fconfigure $bf -blocking 0
4743 filerun $bf [list getblobline $bf $diffids]
4744 $ctext config -state normal
4745 clear_ctext $commentend
4746 $ctext insert end "\n"
4747 $ctext insert end "$f\n" filesep
4748 $ctext config -state disabled
4749 $ctext yview $commentend
4752 proc getblobline {bf id} {
4753 global diffids cmitmode ctext
4755 if {$id ne $diffids || $cmitmode ne "tree"} {
4759 $ctext config -state normal
4761 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4762 $ctext insert end "$line\n"
4765 # delete last newline
4766 $ctext delete "end - 2c" "end - 1c"
4770 $ctext config -state disabled
4771 return [expr {$nl >= 1000? 2: 1}]
4774 proc mergediff {id l} {
4775 global diffmergeid diffopts mdifffd
4781 # this doesn't seem to actually affect anything...
4782 set env(GIT_DIFF_OPTS) $diffopts
4783 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4784 if {[catch {set mdf [open $cmd r]} err]} {
4785 error_popup "Error getting merge diffs: $err"
4788 fconfigure $mdf -blocking 0
4789 set mdifffd($id) $mdf
4790 set np [llength [lindex $parentlist $l]]
4791 filerun $mdf [list getmergediffline $mdf $id $np]
4794 proc getmergediffline {mdf id np} {
4795 global diffmergeid ctext cflist mergemax
4796 global difffilestart mdifffd
4798 $ctext conf -state normal
4800 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4801 if {![info exists diffmergeid] || $id != $diffmergeid
4802 || $mdf != $mdifffd($id)} {
4806 if {[regexp {^diff --cc (.*)} $line match fname]} {
4807 # start of a new file
4808 $ctext insert end "\n"
4809 set here [$ctext index "end - 1c"]
4810 lappend difffilestart $here
4811 add_flist [list $fname]
4812 set l [expr {(78 - [string length $fname]) / 2}]
4813 set pad [string range "----------------------------------------" 1 $l]
4814 $ctext insert end "$pad $fname $pad\n" filesep
4815 } elseif {[regexp {^@@} $line]} {
4816 $ctext insert end "$line\n" hunksep
4817 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4820 # parse the prefix - one ' ', '-' or '+' for each parent
4825 for {set j 0} {$j < $np} {incr j} {
4826 set c [string range $line $j $j]
4829 } elseif {$c == "-"} {
4831 } elseif {$c == "+"} {
4840 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4841 # line doesn't appear in result, parents in $minuses have the line
4842 set num [lindex $minuses 0]
4843 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4844 # line appears in result, parents in $pluses don't have the line
4845 lappend tags mresult
4846 set num [lindex $spaces 0]
4849 if {$num >= $mergemax} {
4854 $ctext insert end "$line\n" $tags
4857 $ctext conf -state disabled
4862 return [expr {$nr >= 1000? 2: 1}]
4865 proc startdiff {ids} {
4866 global treediffs diffids treepending diffmergeid nullid nullid2
4869 catch {unset diffmergeid}
4870 if {![info exists treediffs($ids)] ||
4871 [lsearch -exact $ids $nullid] >= 0 ||
4872 [lsearch -exact $ids $nullid2] >= 0} {
4873 if {![info exists treepending]} {
4881 proc addtocflist {ids} {
4882 global treediffs cflist
4883 add_flist $treediffs($ids)
4887 proc diffcmd {ids flags} {
4888 global nullid nullid2
4890 set i [lsearch -exact $ids $nullid]
4891 set j [lsearch -exact $ids $nullid2]
4893 if {[llength $ids] > 1 && $j < 0} {
4894 # comparing working directory with some specific revision
4895 set cmd [concat | git diff-index $flags]
4897 lappend cmd -R [lindex $ids 1]
4899 lappend cmd [lindex $ids 0]
4902 # comparing working directory with index
4903 set cmd [concat | git diff-files $flags]
4908 } elseif {$j >= 0} {
4909 set cmd [concat | git diff-index --cached $flags]
4910 if {[llength $ids] > 1} {
4911 # comparing index with specific revision
4913 lappend cmd -R [lindex $ids 1]
4915 lappend cmd [lindex $ids 0]
4918 # comparing index with HEAD
4922 set cmd [concat | git diff-tree -r $flags $ids]
4927 proc gettreediffs {ids} {
4928 global treediff treepending
4930 set treepending $ids
4932 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4933 fconfigure $gdtf -blocking 0
4934 filerun $gdtf [list gettreediffline $gdtf $ids]
4937 proc gettreediffline {gdtf ids} {
4938 global treediff treediffs treepending diffids diffmergeid
4942 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4943 set i [string first "\t" $line]
4945 set file [string range $line [expr {$i+1}] end]
4946 if {[string index $file 0] eq "\""} {
4947 set file [lindex $file 0]
4949 lappend treediff $file
4953 return [expr {$nr >= 1000? 2: 1}]
4956 set treediffs($ids) $treediff
4958 if {$cmitmode eq "tree"} {
4960 } elseif {$ids != $diffids} {
4961 if {![info exists diffmergeid]} {
4962 gettreediffs $diffids
4970 proc getblobdiffs {ids} {
4971 global diffopts blobdifffd diffids env
4972 global diffinhdr treediffs
4974 set env(GIT_DIFF_OPTS) $diffopts
4975 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4976 puts "error getting diffs: $err"
4980 fconfigure $bdf -blocking 0
4981 set blobdifffd($ids) $bdf
4982 filerun $bdf [list getblobdiffline $bdf $diffids]
4985 proc setinlist {var i val} {
4988 while {[llength [set $var]] < $i} {
4991 if {[llength [set $var]] == $i} {
4998 proc makediffhdr {fname ids} {
4999 global ctext curdiffstart treediffs
5001 set i [lsearch -exact $treediffs($ids) $fname]
5003 setinlist difffilestart $i $curdiffstart
5005 set l [expr {(78 - [string length $fname]) / 2}]
5006 set pad [string range "----------------------------------------" 1 $l]
5007 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5010 proc getblobdiffline {bdf ids} {
5011 global diffids blobdifffd ctext curdiffstart
5012 global diffnexthead diffnextnote difffilestart
5013 global diffinhdr treediffs
5016 $ctext conf -state normal
5017 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5018 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5022 if {![string compare -length 11 "diff --git " $line]} {
5023 # trim off "diff --git "
5024 set line [string range $line 11 end]
5026 # start of a new file
5027 $ctext insert end "\n"
5028 set curdiffstart [$ctext index "end - 1c"]
5029 $ctext insert end "\n" filesep
5030 # If the name hasn't changed the length will be odd,
5031 # the middle char will be a space, and the two bits either
5032 # side will be a/name and b/name, or "a/name" and "b/name".
5033 # If the name has changed we'll get "rename from" and
5034 # "rename to" lines following this, and we'll use them
5035 # to get the filenames.
5036 # This complexity is necessary because spaces in the filename(s)
5037 # don't get escaped.
5038 set l [string length $line]
5039 set i [expr {$l / 2}]
5040 if {!(($l & 1) && [string index $line $i] eq " " &&
5041 [string range $line 2 [expr {$i - 1}]] eq \
5042 [string range $line [expr {$i + 3}] end])} {
5045 # unescape if quoted and chop off the a/ from the front
5046 if {[string index $line 0] eq "\""} {
5047 set fname [string range [lindex $line 0] 2 end]
5049 set fname [string range $line 2 [expr {$i - 1}]]
5051 makediffhdr $fname $ids
5053 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5054 $line match f1l f1c f2l f2c rest]} {
5055 $ctext insert end "$line\n" hunksep
5058 } elseif {$diffinhdr} {
5059 if {![string compare -length 12 "rename from " $line]} {
5060 set fname [string range $line 12 end]
5061 if {[string index $fname 0] eq "\""} {
5062 set fname [lindex $fname 0]
5064 set i [lsearch -exact $treediffs($ids) $fname]
5066 setinlist difffilestart $i $curdiffstart
5068 } elseif {![string compare -length 10 $line "rename to "]} {
5069 set fname [string range $line 10 end]
5070 if {[string index $fname 0] eq "\""} {
5071 set fname [lindex $fname 0]
5073 makediffhdr $fname $ids
5074 } elseif {[string compare -length 3 $line "---"] == 0} {
5077 } elseif {[string compare -length 3 $line "+++"] == 0} {
5081 $ctext insert end "$line\n" filesep
5084 set x [string range $line 0 0]
5085 if {$x == "-" || $x == "+"} {
5086 set tag [expr {$x == "+"}]
5087 $ctext insert end "$line\n" d$tag
5088 } elseif {$x == " "} {
5089 $ctext insert end "$line\n"
5091 # "\ No newline at end of file",
5092 # or something else we don't recognize
5093 $ctext insert end "$line\n" hunksep
5097 $ctext conf -state disabled
5102 return [expr {$nr >= 1000? 2: 1}]
5105 proc changediffdisp {} {
5106 global ctext diffelide
5108 $ctext tag conf d0 -elide [lindex $diffelide 0]
5109 $ctext tag conf d1 -elide [lindex $diffelide 1]
5113 global difffilestart ctext
5114 set prev [lindex $difffilestart 0]
5115 set here [$ctext index @0,0]
5116 foreach loc $difffilestart {
5117 if {[$ctext compare $loc >= $here]} {
5127 global difffilestart ctext
5128 set here [$ctext index @0,0]
5129 foreach loc $difffilestart {
5130 if {[$ctext compare $loc > $here]} {
5137 proc clear_ctext {{first 1.0}} {
5138 global ctext smarktop smarkbot
5140 set l [lindex [split $first .] 0]
5141 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5144 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5147 $ctext delete $first end
5150 proc incrsearch {name ix op} {
5151 global ctext searchstring searchdirn
5153 $ctext tag remove found 1.0 end
5154 if {[catch {$ctext index anchor}]} {
5155 # no anchor set, use start of selection, or of visible area
5156 set sel [$ctext tag ranges sel]
5158 $ctext mark set anchor [lindex $sel 0]
5159 } elseif {$searchdirn eq "-forwards"} {
5160 $ctext mark set anchor @0,0
5162 $ctext mark set anchor @0,[winfo height $ctext]
5165 if {$searchstring ne {}} {
5166 set here [$ctext search $searchdirn -- $searchstring anchor]
5175 global sstring ctext searchstring searchdirn
5178 $sstring icursor end
5179 set searchdirn -forwards
5180 if {$searchstring ne {}} {
5181 set sel [$ctext tag ranges sel]
5183 set start "[lindex $sel 0] + 1c"
5184 } elseif {[catch {set start [$ctext index anchor]}]} {
5187 set match [$ctext search -count mlen -- $searchstring $start]
5188 $ctext tag remove sel 1.0 end
5194 set mend "$match + $mlen c"
5195 $ctext tag add sel $match $mend
5196 $ctext mark unset anchor
5200 proc dosearchback {} {
5201 global sstring ctext searchstring searchdirn
5204 $sstring icursor end
5205 set searchdirn -backwards
5206 if {$searchstring ne {}} {
5207 set sel [$ctext tag ranges sel]
5209 set start [lindex $sel 0]
5210 } elseif {[catch {set start [$ctext index anchor]}]} {
5211 set start @0,[winfo height $ctext]
5213 set match [$ctext search -backwards -count ml -- $searchstring $start]
5214 $ctext tag remove sel 1.0 end
5220 set mend "$match + $ml c"
5221 $ctext tag add sel $match $mend
5222 $ctext mark unset anchor
5226 proc searchmark {first last} {
5227 global ctext searchstring
5231 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5232 if {$match eq {}} break
5233 set mend "$match + $mlen c"
5234 $ctext tag add found $match $mend
5238 proc searchmarkvisible {doall} {
5239 global ctext smarktop smarkbot
5241 set topline [lindex [split [$ctext index @0,0] .] 0]
5242 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5243 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5244 # no overlap with previous
5245 searchmark $topline $botline
5246 set smarktop $topline
5247 set smarkbot $botline
5249 if {$topline < $smarktop} {
5250 searchmark $topline [expr {$smarktop-1}]
5251 set smarktop $topline
5253 if {$botline > $smarkbot} {
5254 searchmark [expr {$smarkbot+1}] $botline
5255 set smarkbot $botline
5260 proc scrolltext {f0 f1} {
5263 .bleft.sb set $f0 $f1
5264 if {$searchstring ne {}} {
5270 global linespc charspc canvx0 canvy0 mainfont
5271 global xspc1 xspc2 lthickness
5273 set linespc [font metrics $mainfont -linespace]
5274 set charspc [font measure $mainfont "m"]
5275 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5276 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5277 set lthickness [expr {int($linespc / 9) + 1}]
5278 set xspc1(0) $linespc
5286 set ymax [lindex [$canv cget -scrollregion] 3]
5287 if {$ymax eq {} || $ymax == 0} return
5288 set span [$canv yview]
5291 allcanvs yview moveto [lindex $span 0]
5293 if {[info exists selectedline]} {
5294 selectline $selectedline 0
5295 allcanvs yview moveto [lindex $span 0]
5299 proc incrfont {inc} {
5300 global mainfont textfont ctext canv phase cflist
5301 global charspc tabstop
5302 global stopped entries
5304 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5305 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5307 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5308 $cflist conf -font $textfont
5309 $ctext tag conf filesep -font [concat $textfont bold]
5310 foreach e $entries {
5311 $e conf -font $mainfont
5313 if {$phase eq "getcommits"} {
5314 $canv itemconf textitems -font $mainfont
5320 global sha1entry sha1string
5321 if {[string length $sha1string] == 40} {
5322 $sha1entry delete 0 end
5326 proc sha1change {n1 n2 op} {
5327 global sha1string currentid sha1but
5328 if {$sha1string == {}
5329 || ([info exists currentid] && $sha1string == $currentid)} {
5334 if {[$sha1but cget -state] == $state} return
5335 if {$state == "normal"} {
5336 $sha1but conf -state normal -relief raised -text "Goto: "
5338 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5342 proc gotocommit {} {
5343 global sha1string currentid commitrow tagids headids
5344 global displayorder numcommits curview
5346 if {$sha1string == {}
5347 || ([info exists currentid] && $sha1string == $currentid)} return
5348 if {[info exists tagids($sha1string)]} {
5349 set id $tagids($sha1string)
5350 } elseif {[info exists headids($sha1string)]} {
5351 set id $headids($sha1string)
5353 set id [string tolower $sha1string]
5354 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5356 foreach i $displayorder {
5357 if {[string match $id* $i]} {
5361 if {$matches ne {}} {
5362 if {[llength $matches] > 1} {
5363 error_popup "Short SHA1 id $id is ambiguous"
5366 set id [lindex $matches 0]
5370 if {[info exists commitrow($curview,$id)]} {
5371 selectline $commitrow($curview,$id) 1
5374 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5379 error_popup "$type $sha1string is not known"
5382 proc lineenter {x y id} {
5383 global hoverx hovery hoverid hovertimer
5384 global commitinfo canv
5386 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5390 if {[info exists hovertimer]} {
5391 after cancel $hovertimer
5393 set hovertimer [after 500 linehover]
5397 proc linemotion {x y id} {
5398 global hoverx hovery hoverid hovertimer
5400 if {[info exists hoverid] && $id == $hoverid} {
5403 if {[info exists hovertimer]} {
5404 after cancel $hovertimer
5406 set hovertimer [after 500 linehover]
5410 proc lineleave {id} {
5411 global hoverid hovertimer canv
5413 if {[info exists hoverid] && $id == $hoverid} {
5415 if {[info exists hovertimer]} {
5416 after cancel $hovertimer
5424 global hoverx hovery hoverid hovertimer
5425 global canv linespc lthickness
5426 global commitinfo mainfont
5428 set text [lindex $commitinfo($hoverid) 0]
5429 set ymax [lindex [$canv cget -scrollregion] 3]
5430 if {$ymax == {}} return
5431 set yfrac [lindex [$canv yview] 0]
5432 set x [expr {$hoverx + 2 * $linespc}]
5433 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5434 set x0 [expr {$x - 2 * $lthickness}]
5435 set y0 [expr {$y - 2 * $lthickness}]
5436 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5437 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5438 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5439 -fill \#ffff80 -outline black -width 1 -tags hover]
5441 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5446 proc clickisonarrow {id y} {
5449 set ranges [rowranges $id]
5450 set thresh [expr {2 * $lthickness + 6}]
5451 set n [expr {[llength $ranges] - 1}]
5452 for {set i 1} {$i < $n} {incr i} {
5453 set row [lindex $ranges $i]
5454 if {abs([yc $row] - $y) < $thresh} {
5461 proc arrowjump {id n y} {
5464 # 1 <-> 2, 3 <-> 4, etc...
5465 set n [expr {(($n - 1) ^ 1) + 1}]
5466 set row [lindex [rowranges $id] $n]
5468 set ymax [lindex [$canv cget -scrollregion] 3]
5469 if {$ymax eq {} || $ymax <= 0} return
5470 set view [$canv yview]
5471 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5472 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5476 allcanvs yview moveto $yfrac
5479 proc lineclick {x y id isnew} {
5480 global ctext commitinfo children canv thickerline curview
5482 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5487 # draw this line thicker than normal
5491 set ymax [lindex [$canv cget -scrollregion] 3]
5492 if {$ymax eq {}} return
5493 set yfrac [lindex [$canv yview] 0]
5494 set y [expr {$y + $yfrac * $ymax}]
5496 set dirn [clickisonarrow $id $y]
5498 arrowjump $id $dirn $y
5503 addtohistory [list lineclick $x $y $id 0]
5505 # fill the details pane with info about this line
5506 $ctext conf -state normal
5508 $ctext tag conf link -foreground blue -underline 1
5509 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5510 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5511 $ctext insert end "Parent:\t"
5512 $ctext insert end $id [list link link0]
5513 $ctext tag bind link0 <1> [list selbyid $id]
5514 set info $commitinfo($id)
5515 $ctext insert end "\n\t[lindex $info 0]\n"
5516 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5517 set date [formatdate [lindex $info 2]]
5518 $ctext insert end "\tDate:\t$date\n"
5519 set kids $children($curview,$id)
5521 $ctext insert end "\nChildren:"
5523 foreach child $kids {
5525 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5526 set info $commitinfo($child)
5527 $ctext insert end "\n\t"
5528 $ctext insert end $child [list link link$i]
5529 $ctext tag bind link$i <1> [list selbyid $child]
5530 $ctext insert end "\n\t[lindex $info 0]"
5531 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5532 set date [formatdate [lindex $info 2]]
5533 $ctext insert end "\n\tDate:\t$date\n"
5536 $ctext conf -state disabled
5540 proc normalline {} {
5542 if {[info exists thickerline]} {
5550 global commitrow curview
5551 if {[info exists commitrow($curview,$id)]} {
5552 selectline $commitrow($curview,$id) 1
5558 if {![info exists startmstime]} {
5559 set startmstime [clock clicks -milliseconds]
5561 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5564 proc rowmenu {x y id} {
5565 global rowctxmenu commitrow selectedline rowmenuid curview
5566 global nullid nullid2 fakerowmenu mainhead
5569 if {![info exists selectedline]
5570 || $commitrow($curview,$id) eq $selectedline} {
5575 if {$id ne $nullid && $id ne $nullid2} {
5576 set menu $rowctxmenu
5577 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5579 set menu $fakerowmenu
5581 $menu entryconfigure "Diff this*" -state $state
5582 $menu entryconfigure "Diff selected*" -state $state
5583 $menu entryconfigure "Make patch" -state $state
5584 tk_popup $menu $x $y
5587 proc diffvssel {dirn} {
5588 global rowmenuid selectedline displayorder
5590 if {![info exists selectedline]} return
5592 set oldid [lindex $displayorder $selectedline]
5593 set newid $rowmenuid
5595 set oldid $rowmenuid
5596 set newid [lindex $displayorder $selectedline]
5598 addtohistory [list doseldiff $oldid $newid]
5599 doseldiff $oldid $newid
5602 proc doseldiff {oldid newid} {
5606 $ctext conf -state normal
5609 $ctext insert end "From "
5610 $ctext tag conf link -foreground blue -underline 1
5611 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5612 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5613 $ctext tag bind link0 <1> [list selbyid $oldid]
5614 $ctext insert end $oldid [list link link0]
5615 $ctext insert end "\n "
5616 $ctext insert end [lindex $commitinfo($oldid) 0]
5617 $ctext insert end "\n\nTo "
5618 $ctext tag bind link1 <1> [list selbyid $newid]
5619 $ctext insert end $newid [list link link1]
5620 $ctext insert end "\n "
5621 $ctext insert end [lindex $commitinfo($newid) 0]
5622 $ctext insert end "\n"
5623 $ctext conf -state disabled
5624 $ctext tag remove found 1.0 end
5625 startdiff [list $oldid $newid]
5629 global rowmenuid currentid commitinfo patchtop patchnum
5631 if {![info exists currentid]} return
5632 set oldid $currentid
5633 set oldhead [lindex $commitinfo($oldid) 0]
5634 set newid $rowmenuid
5635 set newhead [lindex $commitinfo($newid) 0]
5638 catch {destroy $top}
5640 label $top.title -text "Generate patch"
5641 grid $top.title - -pady 10
5642 label $top.from -text "From:"
5643 entry $top.fromsha1 -width 40 -relief flat
5644 $top.fromsha1 insert 0 $oldid
5645 $top.fromsha1 conf -state readonly
5646 grid $top.from $top.fromsha1 -sticky w
5647 entry $top.fromhead -width 60 -relief flat
5648 $top.fromhead insert 0 $oldhead
5649 $top.fromhead conf -state readonly
5650 grid x $top.fromhead -sticky w
5651 label $top.to -text "To:"
5652 entry $top.tosha1 -width 40 -relief flat
5653 $top.tosha1 insert 0 $newid
5654 $top.tosha1 conf -state readonly
5655 grid $top.to $top.tosha1 -sticky w
5656 entry $top.tohead -width 60 -relief flat
5657 $top.tohead insert 0 $newhead
5658 $top.tohead conf -state readonly
5659 grid x $top.tohead -sticky w
5660 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5661 grid $top.rev x -pady 10
5662 label $top.flab -text "Output file:"
5663 entry $top.fname -width 60
5664 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5666 grid $top.flab $top.fname -sticky w
5668 button $top.buts.gen -text "Generate" -command mkpatchgo
5669 button $top.buts.can -text "Cancel" -command mkpatchcan
5670 grid $top.buts.gen $top.buts.can
5671 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5672 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5673 grid $top.buts - -pady 10 -sticky ew
5677 proc mkpatchrev {} {
5680 set oldid [$patchtop.fromsha1 get]
5681 set oldhead [$patchtop.fromhead get]
5682 set newid [$patchtop.tosha1 get]
5683 set newhead [$patchtop.tohead get]
5684 foreach e [list fromsha1 fromhead tosha1 tohead] \
5685 v [list $newid $newhead $oldid $oldhead] {
5686 $patchtop.$e conf -state normal
5687 $patchtop.$e delete 0 end
5688 $patchtop.$e insert 0 $v
5689 $patchtop.$e conf -state readonly
5694 global patchtop nullid nullid2
5696 set oldid [$patchtop.fromsha1 get]
5697 set newid [$patchtop.tosha1 get]
5698 set fname [$patchtop.fname get]
5699 set cmd [diffcmd [list $oldid $newid] -p]
5700 lappend cmd >$fname &
5701 if {[catch {eval exec $cmd} err]} {
5702 error_popup "Error creating patch: $err"
5704 catch {destroy $patchtop}
5708 proc mkpatchcan {} {
5711 catch {destroy $patchtop}
5716 global rowmenuid mktagtop commitinfo
5720 catch {destroy $top}
5722 label $top.title -text "Create tag"
5723 grid $top.title - -pady 10
5724 label $top.id -text "ID:"
5725 entry $top.sha1 -width 40 -relief flat
5726 $top.sha1 insert 0 $rowmenuid
5727 $top.sha1 conf -state readonly
5728 grid $top.id $top.sha1 -sticky w
5729 entry $top.head -width 60 -relief flat
5730 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5731 $top.head conf -state readonly
5732 grid x $top.head -sticky w
5733 label $top.tlab -text "Tag name:"
5734 entry $top.tag -width 60
5735 grid $top.tlab $top.tag -sticky w
5737 button $top.buts.gen -text "Create" -command mktaggo
5738 button $top.buts.can -text "Cancel" -command mktagcan
5739 grid $top.buts.gen $top.buts.can
5740 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5741 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5742 grid $top.buts - -pady 10 -sticky ew
5747 global mktagtop env tagids idtags
5749 set id [$mktagtop.sha1 get]
5750 set tag [$mktagtop.tag get]
5752 error_popup "No tag name specified"
5755 if {[info exists tagids($tag)]} {
5756 error_popup "Tag \"$tag\" already exists"
5761 set fname [file join $dir "refs/tags" $tag]
5762 set f [open $fname w]
5766 error_popup "Error creating tag: $err"
5770 set tagids($tag) $id
5771 lappend idtags($id) $tag
5776 proc redrawtags {id} {
5777 global canv linehtag commitrow idpos selectedline curview
5778 global mainfont canvxmax iddrawn
5780 if {![info exists commitrow($curview,$id)]} return
5781 if {![info exists iddrawn($id)]} return
5782 drawcommits $commitrow($curview,$id)
5783 $canv delete tag.$id
5784 set xt [eval drawtags $id $idpos($id)]
5785 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5786 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5787 set xr [expr {$xt + [font measure $mainfont $text]}]
5788 if {$xr > $canvxmax} {
5792 if {[info exists selectedline]
5793 && $selectedline == $commitrow($curview,$id)} {
5794 selectline $selectedline 0
5801 catch {destroy $mktagtop}
5810 proc writecommit {} {
5811 global rowmenuid wrcomtop commitinfo wrcomcmd
5813 set top .writecommit
5815 catch {destroy $top}
5817 label $top.title -text "Write commit to file"
5818 grid $top.title - -pady 10
5819 label $top.id -text "ID:"
5820 entry $top.sha1 -width 40 -relief flat
5821 $top.sha1 insert 0 $rowmenuid
5822 $top.sha1 conf -state readonly
5823 grid $top.id $top.sha1 -sticky w
5824 entry $top.head -width 60 -relief flat
5825 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5826 $top.head conf -state readonly
5827 grid x $top.head -sticky w
5828 label $top.clab -text "Command:"
5829 entry $top.cmd -width 60 -textvariable wrcomcmd
5830 grid $top.clab $top.cmd -sticky w -pady 10
5831 label $top.flab -text "Output file:"
5832 entry $top.fname -width 60
5833 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5834 grid $top.flab $top.fname -sticky w
5836 button $top.buts.gen -text "Write" -command wrcomgo
5837 button $top.buts.can -text "Cancel" -command wrcomcan
5838 grid $top.buts.gen $top.buts.can
5839 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5840 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5841 grid $top.buts - -pady 10 -sticky ew
5848 set id [$wrcomtop.sha1 get]
5849 set cmd "echo $id | [$wrcomtop.cmd get]"
5850 set fname [$wrcomtop.fname get]
5851 if {[catch {exec sh -c $cmd >$fname &} err]} {
5852 error_popup "Error writing commit: $err"
5854 catch {destroy $wrcomtop}
5861 catch {destroy $wrcomtop}
5866 global rowmenuid mkbrtop
5869 catch {destroy $top}
5871 label $top.title -text "Create new branch"
5872 grid $top.title - -pady 10
5873 label $top.id -text "ID:"
5874 entry $top.sha1 -width 40 -relief flat
5875 $top.sha1 insert 0 $rowmenuid
5876 $top.sha1 conf -state readonly
5877 grid $top.id $top.sha1 -sticky w
5878 label $top.nlab -text "Name:"
5879 entry $top.name -width 40
5880 grid $top.nlab $top.name -sticky w
5882 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5883 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5884 grid $top.buts.go $top.buts.can
5885 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5886 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5887 grid $top.buts - -pady 10 -sticky ew
5892 global headids idheads
5894 set name [$top.name get]
5895 set id [$top.sha1 get]
5897 error_popup "Please specify a name for the new branch"
5900 catch {destroy $top}
5904 exec git branch $name $id
5909 set headids($name) $id
5910 lappend idheads($id) $name
5918 proc cherrypick {} {
5919 global rowmenuid curview commitrow
5922 set oldhead [exec git rev-parse HEAD]
5923 set dheads [descheads $rowmenuid]
5924 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5925 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5926 included in branch $mainhead -- really re-apply it?"]
5931 # Unfortunately git-cherry-pick writes stuff to stderr even when
5932 # no error occurs, and exec takes that as an indication of error...
5933 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5938 set newhead [exec git rev-parse HEAD]
5939 if {$newhead eq $oldhead} {
5941 error_popup "No changes committed"
5944 addnewchild $newhead $oldhead
5945 if {[info exists commitrow($curview,$oldhead)]} {
5946 insertrow $commitrow($curview,$oldhead) $newhead
5947 if {$mainhead ne {}} {
5948 movehead $newhead $mainhead
5949 movedhead $newhead $mainhead
5958 global mainheadid mainhead rowmenuid confirm_ok resettype
5959 global showlocalchanges
5962 set w ".confirmreset"
5965 wm title $w "Confirm reset"
5966 message $w.m -text \
5967 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5968 -justify center -aspect 1000
5969 pack $w.m -side top -fill x -padx 20 -pady 20
5970 frame $w.f -relief sunken -border 2
5971 message $w.f.rt -text "Reset type:" -aspect 1000
5972 grid $w.f.rt -sticky w
5974 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5975 -text "Soft: Leave working tree and index untouched"
5976 grid $w.f.soft -sticky w
5977 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5978 -text "Mixed: Leave working tree untouched, reset index"
5979 grid $w.f.mixed -sticky w
5980 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5981 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5982 grid $w.f.hard -sticky w
5983 pack $w.f -side top -fill x
5984 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5985 pack $w.ok -side left -fill x -padx 20 -pady 20
5986 button $w.cancel -text Cancel -command "destroy $w"
5987 pack $w.cancel -side right -fill x -padx 20 -pady 20
5988 bind $w <Visibility> "grab $w; focus $w"
5990 if {!$confirm_ok} return
5991 if {[catch {set fd [open \
5992 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5996 set w ".resetprogress"
5997 filerun $fd [list readresetstat $fd $w]
6000 wm title $w "Reset progress"
6001 message $w.m -text "Reset in progress, please wait..." \
6002 -justify center -aspect 1000
6003 pack $w.m -side top -fill x -padx 20 -pady 5
6004 canvas $w.c -width 150 -height 20 -bg white
6005 $w.c create rect 0 0 0 20 -fill green -tags rect
6006 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6011 proc readresetstat {fd w} {
6012 global mainhead mainheadid showlocalchanges
6014 if {[gets $fd line] >= 0} {
6015 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6016 set x [expr {($m * 150) / $n}]
6017 $w.c coords rect 0 0 $x 20
6023 if {[catch {close $fd} err]} {
6026 set oldhead $mainheadid
6027 set newhead [exec git rev-parse HEAD]
6028 if {$newhead ne $oldhead} {
6029 movehead $newhead $mainhead
6030 movedhead $newhead $mainhead
6031 set mainheadid $newhead
6035 if {$showlocalchanges} {
6041 # context menu for a head
6042 proc headmenu {x y id head} {
6043 global headmenuid headmenuhead headctxmenu mainhead
6046 set headmenuhead $head
6048 if {$head eq $mainhead} {
6051 $headctxmenu entryconfigure 0 -state $state
6052 $headctxmenu entryconfigure 1 -state $state
6053 tk_popup $headctxmenu $x $y
6057 global headmenuid headmenuhead mainhead headids
6058 global showlocalchanges mainheadid
6060 # check the tree is clean first??
6061 set oldmainhead $mainhead
6066 exec git checkout -q $headmenuhead
6072 set mainhead $headmenuhead
6073 set mainheadid $headmenuid
6074 if {[info exists headids($oldmainhead)]} {
6075 redrawtags $headids($oldmainhead)
6077 redrawtags $headmenuid
6079 if {$showlocalchanges} {
6085 global headmenuid headmenuhead mainhead
6086 global headids idheads
6088 set head $headmenuhead
6090 # this check shouldn't be needed any more...
6091 if {$head eq $mainhead} {
6092 error_popup "Cannot delete the currently checked-out branch"
6095 set dheads [descheads $id]
6096 if {$dheads eq $headids($head)} {
6097 # the stuff on this branch isn't on any other branch
6098 if {![confirm_popup "The commits on branch $head aren't on any other\
6099 branch.\nReally delete branch $head?"]} return
6103 if {[catch {exec git branch -D $head} err]} {
6108 removehead $id $head
6109 removedhead $id $head
6115 # Stuff for finding nearby tags
6116 proc getallcommits {} {
6117 global allcommits allids nbmp nextarc seeds
6127 # Called when the graph might have changed
6128 proc regetallcommits {} {
6129 global allcommits seeds
6131 set cmd [concat | git rev-list --all --parents]
6135 set fd [open $cmd r]
6136 fconfigure $fd -blocking 0
6139 filerun $fd [list getallclines $fd]
6142 # Since most commits have 1 parent and 1 child, we group strings of
6143 # such commits into "arcs" joining branch/merge points (BMPs), which
6144 # are commits that either don't have 1 parent or don't have 1 child.
6146 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6147 # arcout(id) - outgoing arcs for BMP
6148 # arcids(a) - list of IDs on arc including end but not start
6149 # arcstart(a) - BMP ID at start of arc
6150 # arcend(a) - BMP ID at end of arc
6151 # growing(a) - arc a is still growing
6152 # arctags(a) - IDs out of arcids (excluding end) that have tags
6153 # archeads(a) - IDs out of arcids (excluding end) that have heads
6154 # The start of an arc is at the descendent end, so "incoming" means
6155 # coming from descendents, and "outgoing" means going towards ancestors.
6157 proc getallclines {fd} {
6158 global allids allparents allchildren idtags idheads nextarc nbmp
6159 global arcnos arcids arctags arcout arcend arcstart archeads growing
6160 global seeds allcommits
6163 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6164 set id [lindex $line 0]
6165 if {[info exists allparents($id)]} {
6170 set olds [lrange $line 1 end]
6171 set allparents($id) $olds
6172 if {![info exists allchildren($id)]} {
6173 set allchildren($id) {}
6178 if {[llength $olds] == 1 && [llength $a] == 1} {
6179 lappend arcids($a) $id
6180 if {[info exists idtags($id)]} {
6181 lappend arctags($a) $id
6183 if {[info exists idheads($id)]} {
6184 lappend archeads($a) $id
6186 if {[info exists allparents($olds)]} {
6187 # seen parent already
6188 if {![info exists arcout($olds)]} {
6191 lappend arcids($a) $olds
6192 set arcend($a) $olds
6195 lappend allchildren($olds) $id
6196 lappend arcnos($olds) $a
6201 foreach a $arcnos($id) {
6202 lappend arcids($a) $id
6209 lappend allchildren($p) $id
6210 set a [incr nextarc]
6211 set arcstart($a) $id
6218 if {[info exists allparents($p)]} {
6219 # seen it already, may need to make a new branch
6220 if {![info exists arcout($p)]} {
6223 lappend arcids($a) $p
6227 lappend arcnos($p) $a
6232 global cached_dheads cached_dtags cached_atags
6233 catch {unset cached_dheads}
6234 catch {unset cached_dtags}
6235 catch {unset cached_atags}
6238 return [expr {$nid >= 1000? 2: 1}]
6241 if {[incr allcommits -1] == 0} {
6248 proc recalcarc {a} {
6249 global arctags archeads arcids idtags idheads
6253 foreach id [lrange $arcids($a) 0 end-1] {
6254 if {[info exists idtags($id)]} {
6257 if {[info exists idheads($id)]} {
6262 set archeads($a) $ah
6266 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6267 global arcstart arcend arcout allparents growing
6270 if {[llength $a] != 1} {
6271 puts "oops splitarc called but [llength $a] arcs already"
6275 set i [lsearch -exact $arcids($a) $p]
6277 puts "oops splitarc $p not in arc $a"
6280 set na [incr nextarc]
6281 if {[info exists arcend($a)]} {
6282 set arcend($na) $arcend($a)
6284 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6285 set j [lsearch -exact $arcnos($l) $a]
6286 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6288 set tail [lrange $arcids($a) [expr {$i+1}] end]
6289 set arcids($a) [lrange $arcids($a) 0 $i]
6291 set arcstart($na) $p
6293 set arcids($na) $tail
6294 if {[info exists growing($a)]} {
6301 if {[llength $arcnos($id)] == 1} {
6304 set j [lsearch -exact $arcnos($id) $a]
6305 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6309 # reconstruct tags and heads lists
6310 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6315 set archeads($na) {}
6319 # Update things for a new commit added that is a child of one
6320 # existing commit. Used when cherry-picking.
6321 proc addnewchild {id p} {
6322 global allids allparents allchildren idtags nextarc nbmp
6323 global arcnos arcids arctags arcout arcend arcstart archeads growing
6327 set allparents($id) [list $p]
6328 set allchildren($id) {}
6332 lappend allchildren($p) $id
6333 set a [incr nextarc]
6334 set arcstart($a) $id
6337 set arcids($a) [list $p]
6339 if {![info exists arcout($p)]} {
6342 lappend arcnos($p) $a
6343 set arcout($id) [list $a]
6346 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6347 # or 0 if neither is true.
6348 proc anc_or_desc {a b} {
6349 global arcout arcstart arcend arcnos cached_isanc
6351 if {$arcnos($a) eq $arcnos($b)} {
6352 # Both are on the same arc(s); either both are the same BMP,
6353 # or if one is not a BMP, the other is also not a BMP or is
6354 # the BMP at end of the arc (and it only has 1 incoming arc).
6355 # Or both can be BMPs with no incoming arcs.
6356 if {$a eq $b || $arcnos($a) eq {}} {
6359 # assert {[llength $arcnos($a)] == 1}
6360 set arc [lindex $arcnos($a) 0]
6361 set i [lsearch -exact $arcids($arc) $a]
6362 set j [lsearch -exact $arcids($arc) $b]
6363 if {$i < 0 || $i > $j} {
6370 if {![info exists arcout($a)]} {
6371 set arc [lindex $arcnos($a) 0]
6372 if {[info exists arcend($arc)]} {
6373 set aend $arcend($arc)
6377 set a $arcstart($arc)
6381 if {![info exists arcout($b)]} {
6382 set arc [lindex $arcnos($b) 0]
6383 if {[info exists arcend($arc)]} {
6384 set bend $arcend($arc)
6388 set b $arcstart($arc)
6398 if {[info exists cached_isanc($a,$bend)]} {
6399 if {$cached_isanc($a,$bend)} {
6403 if {[info exists cached_isanc($b,$aend)]} {
6404 if {$cached_isanc($b,$aend)} {
6407 if {[info exists cached_isanc($a,$bend)]} {
6412 set todo [list $a $b]
6415 for {set i 0} {$i < [llength $todo]} {incr i} {
6416 set x [lindex $todo $i]
6417 if {$anc($x) eq {}} {
6420 foreach arc $arcnos($x) {
6421 set xd $arcstart($arc)
6423 set cached_isanc($a,$bend) 1
6424 set cached_isanc($b,$aend) 0
6426 } elseif {$xd eq $aend} {
6427 set cached_isanc($b,$aend) 1
6428 set cached_isanc($a,$bend) 0
6431 if {![info exists anc($xd)]} {
6432 set anc($xd) $anc($x)
6434 } elseif {$anc($xd) ne $anc($x)} {
6439 set cached_isanc($a,$bend) 0
6440 set cached_isanc($b,$aend) 0
6444 # This identifies whether $desc has an ancestor that is
6445 # a growing tip of the graph and which is not an ancestor of $anc
6446 # and returns 0 if so and 1 if not.
6447 # If we subsequently discover a tag on such a growing tip, and that
6448 # turns out to be a descendent of $anc (which it could, since we
6449 # don't necessarily see children before parents), then $desc
6450 # isn't a good choice to display as a descendent tag of
6451 # $anc (since it is the descendent of another tag which is
6452 # a descendent of $anc). Similarly, $anc isn't a good choice to
6453 # display as a ancestor tag of $desc.
6455 proc is_certain {desc anc} {
6456 global arcnos arcout arcstart arcend growing problems
6459 if {[llength $arcnos($anc)] == 1} {
6460 # tags on the same arc are certain
6461 if {$arcnos($desc) eq $arcnos($anc)} {
6464 if {![info exists arcout($anc)]} {
6465 # if $anc is partway along an arc, use the start of the arc instead
6466 set a [lindex $arcnos($anc) 0]
6467 set anc $arcstart($a)
6470 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6473 set a [lindex $arcnos($desc) 0]
6479 set anclist [list $x]
6483 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6484 set x [lindex $anclist $i]
6489 foreach a $arcout($x) {
6490 if {[info exists growing($a)]} {
6491 if {![info exists growanc($x)] && $dl($x)} {
6497 if {[info exists dl($y)]} {
6501 if {![info exists done($y)]} {
6504 if {[info exists growanc($x)]} {
6508 for {set k 0} {$k < [llength $xl]} {incr k} {
6509 set z [lindex $xl $k]
6510 foreach c $arcout($z) {
6511 if {[info exists arcend($c)]} {
6513 if {[info exists dl($v)] && $dl($v)} {
6515 if {![info exists done($v)]} {
6518 if {[info exists growanc($v)]} {
6528 } elseif {$y eq $anc || !$dl($x)} {
6539 foreach x [array names growanc] {
6548 proc validate_arctags {a} {
6549 global arctags idtags
6553 foreach id $arctags($a) {
6555 if {![info exists idtags($id)]} {
6556 set na [lreplace $na $i $i]
6563 proc validate_archeads {a} {
6564 global archeads idheads
6567 set na $archeads($a)
6568 foreach id $archeads($a) {
6570 if {![info exists idheads($id)]} {
6571 set na [lreplace $na $i $i]
6575 set archeads($a) $na
6578 # Return the list of IDs that have tags that are descendents of id,
6579 # ignoring IDs that are descendents of IDs already reported.
6580 proc desctags {id} {
6581 global arcnos arcstart arcids arctags idtags allparents
6582 global growing cached_dtags
6584 if {![info exists allparents($id)]} {
6587 set t1 [clock clicks -milliseconds]
6589 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6590 # part-way along an arc; check that arc first
6591 set a [lindex $arcnos($id) 0]
6592 if {$arctags($a) ne {}} {
6594 set i [lsearch -exact $arcids($a) $id]
6596 foreach t $arctags($a) {
6597 set j [lsearch -exact $arcids($a) $t]
6605 set id $arcstart($a)
6606 if {[info exists idtags($id)]} {
6610 if {[info exists cached_dtags($id)]} {
6611 return $cached_dtags($id)
6618 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6619 set id [lindex $todo $i]
6621 set ta [info exists hastaggedancestor($id)]
6625 # ignore tags on starting node
6626 if {!$ta && $i > 0} {
6627 if {[info exists idtags($id)]} {
6630 } elseif {[info exists cached_dtags($id)]} {
6631 set tagloc($id) $cached_dtags($id)
6635 foreach a $arcnos($id) {
6637 if {!$ta && $arctags($a) ne {}} {
6639 if {$arctags($a) ne {}} {
6640 lappend tagloc($id) [lindex $arctags($a) end]
6643 if {$ta || $arctags($a) ne {}} {
6644 set tomark [list $d]
6645 for {set j 0} {$j < [llength $tomark]} {incr j} {
6646 set dd [lindex $tomark $j]
6647 if {![info exists hastaggedancestor($dd)]} {
6648 if {[info exists done($dd)]} {
6649 foreach b $arcnos($dd) {
6650 lappend tomark $arcstart($b)
6652 if {[info exists tagloc($dd)]} {
6655 } elseif {[info exists queued($dd)]} {
6658 set hastaggedancestor($dd) 1
6662 if {![info exists queued($d)]} {
6665 if {![info exists hastaggedancestor($d)]} {
6672 foreach id [array names tagloc] {
6673 if {![info exists hastaggedancestor($id)]} {
6674 foreach t $tagloc($id) {
6675 if {[lsearch -exact $tags $t] < 0} {
6681 set t2 [clock clicks -milliseconds]
6684 # remove tags that are descendents of other tags
6685 for {set i 0} {$i < [llength $tags]} {incr i} {
6686 set a [lindex $tags $i]
6687 for {set j 0} {$j < $i} {incr j} {
6688 set b [lindex $tags $j]
6689 set r [anc_or_desc $a $b]
6691 set tags [lreplace $tags $j $j]
6694 } elseif {$r == -1} {
6695 set tags [lreplace $tags $i $i]
6702 if {[array names growing] ne {}} {
6703 # graph isn't finished, need to check if any tag could get
6704 # eclipsed by another tag coming later. Simply ignore any
6705 # tags that could later get eclipsed.
6708 if {[is_certain $t $origid]} {
6712 if {$tags eq $ctags} {
6713 set cached_dtags($origid) $tags
6718 set cached_dtags($origid) $tags
6720 set t3 [clock clicks -milliseconds]
6721 if {0 && $t3 - $t1 >= 100} {
6722 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6723 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6729 global arcnos arcids arcout arcend arctags idtags allparents
6730 global growing cached_atags
6732 if {![info exists allparents($id)]} {
6735 set t1 [clock clicks -milliseconds]
6737 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6738 # part-way along an arc; check that arc first
6739 set a [lindex $arcnos($id) 0]
6740 if {$arctags($a) ne {}} {
6742 set i [lsearch -exact $arcids($a) $id]
6743 foreach t $arctags($a) {
6744 set j [lsearch -exact $arcids($a) $t]
6750 if {![info exists arcend($a)]} {
6754 if {[info exists idtags($id)]} {
6758 if {[info exists cached_atags($id)]} {
6759 return $cached_atags($id)
6767 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6768 set id [lindex $todo $i]
6770 set td [info exists hastaggeddescendent($id)]
6774 # ignore tags on starting node
6775 if {!$td && $i > 0} {
6776 if {[info exists idtags($id)]} {
6779 } elseif {[info exists cached_atags($id)]} {
6780 set tagloc($id) $cached_atags($id)
6784 foreach a $arcout($id) {
6785 if {!$td && $arctags($a) ne {}} {
6787 if {$arctags($a) ne {}} {
6788 lappend tagloc($id) [lindex $arctags($a) 0]
6791 if {![info exists arcend($a)]} continue
6793 if {$td || $arctags($a) ne {}} {
6794 set tomark [list $d]
6795 for {set j 0} {$j < [llength $tomark]} {incr j} {
6796 set dd [lindex $tomark $j]
6797 if {![info exists hastaggeddescendent($dd)]} {
6798 if {[info exists done($dd)]} {
6799 foreach b $arcout($dd) {
6800 if {[info exists arcend($b)]} {
6801 lappend tomark $arcend($b)
6804 if {[info exists tagloc($dd)]} {
6807 } elseif {[info exists queued($dd)]} {
6810 set hastaggeddescendent($dd) 1
6814 if {![info exists queued($d)]} {
6817 if {![info exists hastaggeddescendent($d)]} {
6823 set t2 [clock clicks -milliseconds]
6826 foreach id [array names tagloc] {
6827 if {![info exists hastaggeddescendent($id)]} {
6828 foreach t $tagloc($id) {
6829 if {[lsearch -exact $tags $t] < 0} {
6836 # remove tags that are ancestors of other tags
6837 for {set i 0} {$i < [llength $tags]} {incr i} {
6838 set a [lindex $tags $i]
6839 for {set j 0} {$j < $i} {incr j} {
6840 set b [lindex $tags $j]
6841 set r [anc_or_desc $a $b]
6843 set tags [lreplace $tags $j $j]
6846 } elseif {$r == 1} {
6847 set tags [lreplace $tags $i $i]
6854 if {[array names growing] ne {}} {
6855 # graph isn't finished, need to check if any tag could get
6856 # eclipsed by another tag coming later. Simply ignore any
6857 # tags that could later get eclipsed.
6860 if {[is_certain $origid $t]} {
6864 if {$tags eq $ctags} {
6865 set cached_atags($origid) $tags
6870 set cached_atags($origid) $tags
6872 set t3 [clock clicks -milliseconds]
6873 if {0 && $t3 - $t1 >= 100} {
6874 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6875 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6880 # Return the list of IDs that have heads that are descendents of id,
6881 # including id itself if it has a head.
6882 proc descheads {id} {
6883 global arcnos arcstart arcids archeads idheads cached_dheads
6886 if {![info exists allparents($id)]} {
6890 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6891 # part-way along an arc; check it first
6892 set a [lindex $arcnos($id) 0]
6893 if {$archeads($a) ne {}} {
6894 validate_archeads $a
6895 set i [lsearch -exact $arcids($a) $id]
6896 foreach t $archeads($a) {
6897 set j [lsearch -exact $arcids($a) $t]
6902 set id $arcstart($a)
6908 for {set i 0} {$i < [llength $todo]} {incr i} {
6909 set id [lindex $todo $i]
6910 if {[info exists cached_dheads($id)]} {
6911 set ret [concat $ret $cached_dheads($id)]
6913 if {[info exists idheads($id)]} {
6916 foreach a $arcnos($id) {
6917 if {$archeads($a) ne {}} {
6918 validate_archeads $a
6919 if {$archeads($a) ne {}} {
6920 set ret [concat $ret $archeads($a)]
6924 if {![info exists seen($d)]} {
6931 set ret [lsort -unique $ret]
6932 set cached_dheads($origid) $ret
6933 return [concat $ret $aret]
6936 proc addedtag {id} {
6937 global arcnos arcout cached_dtags cached_atags
6939 if {![info exists arcnos($id)]} return
6940 if {![info exists arcout($id)]} {
6941 recalcarc [lindex $arcnos($id) 0]
6943 catch {unset cached_dtags}
6944 catch {unset cached_atags}
6947 proc addedhead {hid head} {
6948 global arcnos arcout cached_dheads
6950 if {![info exists arcnos($hid)]} return
6951 if {![info exists arcout($hid)]} {
6952 recalcarc [lindex $arcnos($hid) 0]
6954 catch {unset cached_dheads}
6957 proc removedhead {hid head} {
6958 global cached_dheads
6960 catch {unset cached_dheads}
6963 proc movedhead {hid head} {
6964 global arcnos arcout cached_dheads
6966 if {![info exists arcnos($hid)]} return
6967 if {![info exists arcout($hid)]} {
6968 recalcarc [lindex $arcnos($hid) 0]
6970 catch {unset cached_dheads}
6973 proc changedrefs {} {
6974 global cached_dheads cached_dtags cached_atags
6975 global arctags archeads arcnos arcout idheads idtags
6977 foreach id [concat [array names idheads] [array names idtags]] {
6978 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6979 set a [lindex $arcnos($id) 0]
6980 if {![info exists donearc($a)]} {
6986 catch {unset cached_dtags}
6987 catch {unset cached_atags}
6988 catch {unset cached_dheads}
6991 proc rereadrefs {} {
6992 global idtags idheads idotherrefs mainhead
6994 set refids [concat [array names idtags] \
6995 [array names idheads] [array names idotherrefs]]
6996 foreach id $refids {
6997 if {![info exists ref($id)]} {
6998 set ref($id) [listrefs $id]
7001 set oldmainhead $mainhead
7004 set refids [lsort -unique [concat $refids [array names idtags] \
7005 [array names idheads] [array names idotherrefs]]]
7006 foreach id $refids {
7007 set v [listrefs $id]
7008 if {![info exists ref($id)] || $ref($id) != $v ||
7009 ($id eq $oldmainhead && $id ne $mainhead) ||
7010 ($id eq $mainhead && $id ne $oldmainhead)} {
7016 proc listrefs {id} {
7017 global idtags idheads idotherrefs
7020 if {[info exists idtags($id)]} {
7024 if {[info exists idheads($id)]} {
7028 if {[info exists idotherrefs($id)]} {
7029 set z $idotherrefs($id)
7031 return [list $x $y $z]
7034 proc showtag {tag isnew} {
7035 global ctext tagcontents tagids linknum tagobjid
7038 addtohistory [list showtag $tag 0]
7040 $ctext conf -state normal
7043 if {![info exists tagcontents($tag)]} {
7045 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7048 if {[info exists tagcontents($tag)]} {
7049 set text $tagcontents($tag)
7051 set text "Tag: $tag\nId: $tagids($tag)"
7053 appendwithlinks $text {}
7054 $ctext conf -state disabled
7066 global maxwidth maxgraphpct diffopts
7067 global oldprefs prefstop showneartags showlocalchanges
7068 global bgcolor fgcolor ctext diffcolors selectbgcolor
7069 global uifont tabstop
7073 if {[winfo exists $top]} {
7077 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7078 set oldprefs($v) [set $v]
7081 wm title $top "Gitk preferences"
7082 label $top.ldisp -text "Commit list display options"
7083 $top.ldisp configure -font $uifont
7084 grid $top.ldisp - -sticky w -pady 10
7085 label $top.spacer -text " "
7086 label $top.maxwidthl -text "Maximum graph width (lines)" \
7088 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7089 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7090 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7092 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7093 grid x $top.maxpctl $top.maxpct -sticky w
7094 frame $top.showlocal
7095 label $top.showlocal.l -text "Show local changes" -font optionfont
7096 checkbutton $top.showlocal.b -variable showlocalchanges
7097 pack $top.showlocal.b $top.showlocal.l -side left
7098 grid x $top.showlocal -sticky w
7100 label $top.ddisp -text "Diff display options"
7101 $top.ddisp configure -font $uifont
7102 grid $top.ddisp - -sticky w -pady 10
7103 label $top.diffoptl -text "Options for diff program" \
7105 entry $top.diffopt -width 20 -textvariable diffopts
7106 grid x $top.diffoptl $top.diffopt -sticky w
7108 label $top.ntag.l -text "Display nearby tags" -font optionfont
7109 checkbutton $top.ntag.b -variable showneartags
7110 pack $top.ntag.b $top.ntag.l -side left
7111 grid x $top.ntag -sticky w
7112 label $top.tabstopl -text "tabstop" -font optionfont
7113 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7114 grid x $top.tabstopl $top.tabstop -sticky w
7116 label $top.cdisp -text "Colors: press to choose"
7117 $top.cdisp configure -font $uifont
7118 grid $top.cdisp - -sticky w -pady 10
7119 label $top.bg -padx 40 -relief sunk -background $bgcolor
7120 button $top.bgbut -text "Background" -font optionfont \
7121 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7122 grid x $top.bgbut $top.bg -sticky w
7123 label $top.fg -padx 40 -relief sunk -background $fgcolor
7124 button $top.fgbut -text "Foreground" -font optionfont \
7125 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7126 grid x $top.fgbut $top.fg -sticky w
7127 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7128 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7129 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7130 [list $ctext tag conf d0 -foreground]]
7131 grid x $top.diffoldbut $top.diffold -sticky w
7132 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7133 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7134 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7135 [list $ctext tag conf d1 -foreground]]
7136 grid x $top.diffnewbut $top.diffnew -sticky w
7137 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7138 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7139 -command [list choosecolor diffcolors 2 $top.hunksep \
7140 "diff hunk header" \
7141 [list $ctext tag conf hunksep -foreground]]
7142 grid x $top.hunksepbut $top.hunksep -sticky w
7143 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7144 button $top.selbgbut -text "Select bg" -font optionfont \
7145 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7146 grid x $top.selbgbut $top.selbgsep -sticky w
7149 button $top.buts.ok -text "OK" -command prefsok -default active
7150 $top.buts.ok configure -font $uifont
7151 button $top.buts.can -text "Cancel" -command prefscan -default normal
7152 $top.buts.can configure -font $uifont
7153 grid $top.buts.ok $top.buts.can
7154 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7155 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7156 grid $top.buts - - -pady 10 -sticky ew
7157 bind $top <Visibility> "focus $top.buts.ok"
7160 proc choosecolor {v vi w x cmd} {
7163 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7164 -title "Gitk: choose color for $x"]
7165 if {$c eq {}} return
7166 $w conf -background $c
7172 global bglist cflist
7174 $w configure -selectbackground $c
7176 $cflist tag configure highlight \
7177 -background [$cflist cget -selectbackground]
7178 allcanvs itemconf secsel -fill $c
7185 $w conf -background $c
7193 $w conf -foreground $c
7195 allcanvs itemconf text -fill $c
7196 $canv itemconf circle -outline $c
7200 global maxwidth maxgraphpct diffopts
7201 global oldprefs prefstop showneartags showlocalchanges
7203 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7204 set $v $oldprefs($v)
7206 catch {destroy $prefstop}
7211 global maxwidth maxgraphpct
7212 global oldprefs prefstop showneartags showlocalchanges
7213 global charspc ctext tabstop
7215 catch {destroy $prefstop}
7217 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7218 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7219 if {$showlocalchanges} {
7225 if {$maxwidth != $oldprefs(maxwidth)
7226 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7228 } elseif {$showneartags != $oldprefs(showneartags)} {
7233 proc formatdate {d} {
7235 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7240 # This list of encoding names and aliases is distilled from
7241 # http://www.iana.org/assignments/character-sets.
7242 # Not all of them are supported by Tcl.
7243 set encoding_aliases {
7244 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7245 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7246 { ISO-10646-UTF-1 csISO10646UTF1 }
7247 { ISO_646.basic:1983 ref csISO646basic1983 }
7248 { INVARIANT csINVARIANT }
7249 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7250 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7251 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7252 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7253 { NATS-DANO iso-ir-9-1 csNATSDANO }
7254 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7255 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7256 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7257 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7258 { ISO-2022-KR csISO2022KR }
7260 { ISO-2022-JP csISO2022JP }
7261 { ISO-2022-JP-2 csISO2022JP2 }
7262 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7264 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7265 { IT iso-ir-15 ISO646-IT csISO15Italian }
7266 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7267 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7268 { greek7-old iso-ir-18 csISO18Greek7Old }
7269 { latin-greek iso-ir-19 csISO19LatinGreek }
7270 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7271 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7272 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7273 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7274 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7275 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7276 { INIS iso-ir-49 csISO49INIS }
7277 { INIS-8 iso-ir-50 csISO50INIS8 }
7278 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7279 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7280 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7281 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7282 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7283 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7285 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7286 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7287 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7288 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7289 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7290 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7291 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7292 { greek7 iso-ir-88 csISO88Greek7 }
7293 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7294 { iso-ir-90 csISO90 }
7295 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7296 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7297 csISO92JISC62991984b }
7298 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7299 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7300 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7301 csISO95JIS62291984handadd }
7302 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7303 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7304 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7305 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7307 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7308 { T.61-7bit iso-ir-102 csISO102T617bit }
7309 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7310 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7311 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7312 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7313 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7314 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7315 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7316 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7317 arabic csISOLatinArabic }
7318 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7319 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7320 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7321 greek greek8 csISOLatinGreek }
7322 { T.101-G2 iso-ir-128 csISO128T101G2 }
7323 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7325 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7326 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7327 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7328 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7329 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7330 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7331 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7332 csISOLatinCyrillic }
7333 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7334 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7335 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7336 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7337 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7338 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7339 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7340 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7341 { ISO_10367-box iso-ir-155 csISO10367Box }
7342 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7343 { latin-lap lap iso-ir-158 csISO158Lap }
7344 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7345 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7348 { JIS_X0201 X0201 csHalfWidthKatakana }
7349 { KSC5636 ISO646-KR csKSC5636 }
7350 { ISO-10646-UCS-2 csUnicode }
7351 { ISO-10646-UCS-4 csUCS4 }
7352 { DEC-MCS dec csDECMCS }
7353 { hp-roman8 roman8 r8 csHPRoman8 }
7354 { macintosh mac csMacintosh }
7355 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7357 { IBM038 EBCDIC-INT cp038 csIBM038 }
7358 { IBM273 CP273 csIBM273 }
7359 { IBM274 EBCDIC-BE CP274 csIBM274 }
7360 { IBM275 EBCDIC-BR cp275 csIBM275 }
7361 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7362 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7363 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7364 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7365 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7366 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7367 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7368 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7369 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7370 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7371 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7372 { IBM437 cp437 437 csPC8CodePage437 }
7373 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7374 { IBM775 cp775 csPC775Baltic }
7375 { IBM850 cp850 850 csPC850Multilingual }
7376 { IBM851 cp851 851 csIBM851 }
7377 { IBM852 cp852 852 csPCp852 }
7378 { IBM855 cp855 855 csIBM855 }
7379 { IBM857 cp857 857 csIBM857 }
7380 { IBM860 cp860 860 csIBM860 }
7381 { IBM861 cp861 861 cp-is csIBM861 }
7382 { IBM862 cp862 862 csPC862LatinHebrew }
7383 { IBM863 cp863 863 csIBM863 }
7384 { IBM864 cp864 csIBM864 }
7385 { IBM865 cp865 865 csIBM865 }
7386 { IBM866 cp866 866 csIBM866 }
7387 { IBM868 CP868 cp-ar csIBM868 }
7388 { IBM869 cp869 869 cp-gr csIBM869 }
7389 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7390 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7391 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7392 { IBM891 cp891 csIBM891 }
7393 { IBM903 cp903 csIBM903 }
7394 { IBM904 cp904 904 csIBBM904 }
7395 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7396 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7397 { IBM1026 CP1026 csIBM1026 }
7398 { EBCDIC-AT-DE csIBMEBCDICATDE }
7399 { EBCDIC-AT-DE-A csEBCDICATDEA }
7400 { EBCDIC-CA-FR csEBCDICCAFR }
7401 { EBCDIC-DK-NO csEBCDICDKNO }
7402 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7403 { EBCDIC-FI-SE csEBCDICFISE }
7404 { EBCDIC-FI-SE-A csEBCDICFISEA }
7405 { EBCDIC-FR csEBCDICFR }
7406 { EBCDIC-IT csEBCDICIT }
7407 { EBCDIC-PT csEBCDICPT }
7408 { EBCDIC-ES csEBCDICES }
7409 { EBCDIC-ES-A csEBCDICESA }
7410 { EBCDIC-ES-S csEBCDICESS }
7411 { EBCDIC-UK csEBCDICUK }
7412 { EBCDIC-US csEBCDICUS }
7413 { UNKNOWN-8BIT csUnknown8BiT }
7414 { MNEMONIC csMnemonic }
7419 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7420 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7421 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7422 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7423 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7424 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7425 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7426 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7427 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7428 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7429 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7430 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7431 { IBM1047 IBM-1047 }
7432 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7433 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7434 { UNICODE-1-1 csUnicode11 }
7437 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7438 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7440 { ISO-8859-15 ISO_8859-15 Latin-9 }
7441 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7442 { GBK CP936 MS936 windows-936 }
7443 { JIS_Encoding csJISEncoding }
7444 { Shift_JIS MS_Kanji csShiftJIS }
7445 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7447 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7448 { ISO-10646-UCS-Basic csUnicodeASCII }
7449 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7450 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7451 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7452 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7453 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7454 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7455 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7456 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7457 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7458 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7459 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7460 { Ventura-US csVenturaUS }
7461 { Ventura-International csVenturaInternational }
7462 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7463 { PC8-Turkish csPC8Turkish }
7464 { IBM-Symbols csIBMSymbols }
7465 { IBM-Thai csIBMThai }
7466 { HP-Legal csHPLegal }
7467 { HP-Pi-font csHPPiFont }
7468 { HP-Math8 csHPMath8 }
7469 { Adobe-Symbol-Encoding csHPPSMath }
7470 { HP-DeskTop csHPDesktop }
7471 { Ventura-Math csVenturaMath }
7472 { Microsoft-Publishing csMicrosoftPublishing }
7473 { Windows-31J csWindows31J }
7478 proc tcl_encoding {enc} {
7479 global encoding_aliases
7480 set names [encoding names]
7481 set lcnames [string tolower $names]
7482 set enc [string tolower $enc]
7483 set i [lsearch -exact $lcnames $enc]
7485 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7486 if {[regsub {^iso[-_]} $enc iso encx]} {
7487 set i [lsearch -exact $lcnames $encx]
7491 foreach l $encoding_aliases {
7492 set ll [string tolower $l]
7493 if {[lsearch -exact $ll $enc] < 0} continue
7494 # look through the aliases for one that tcl knows about
7496 set i [lsearch -exact $lcnames $e]
7498 if {[regsub {^iso[-_]} $e iso ex]} {
7499 set i [lsearch -exact $lcnames $ex]
7508 return [lindex $names $i]
7515 set diffopts "-U 5 -p"
7516 set wrcomcmd "git diff-tree --stdin -p --pretty"
7520 set gitencoding [exec git config --get i18n.commitencoding]
7522 if {$gitencoding == ""} {
7523 set gitencoding "utf-8"
7525 set tclencoding [tcl_encoding $gitencoding]
7526 if {$tclencoding == {}} {
7527 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7530 set mainfont {Helvetica 9}
7531 set textfont {Courier 9}
7532 set uifont {Helvetica 9 bold}
7534 set findmergefiles 0
7542 set cmitmode "patch"
7543 set wrapcomment "none"
7547 set showlocalchanges 1
7549 set colors {green red blue magenta darkgrey brown orange}
7552 set diffcolors {red "#00a000" blue}
7553 set selectbgcolor gray85
7555 catch {source ~/.gitk}
7557 font create optionfont -family sans-serif -size -12
7559 # check that we can find a .git directory somewhere...
7561 if {![file isdirectory $gitdir]} {
7562 show_error {} . "Cannot find the git directory \"$gitdir\"."
7567 set cmdline_files {}
7572 "-d" { set datemode 1 }
7574 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7578 lappend revtreeargs $arg
7584 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7585 # no -- on command line, but some arguments (other than -d)
7587 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7588 set cmdline_files [split $f "\n"]
7589 set n [llength $cmdline_files]
7590 set revtreeargs [lrange $revtreeargs 0 end-$n]
7591 # Unfortunately git rev-parse doesn't produce an error when
7592 # something is both a revision and a filename. To be consistent
7593 # with git log and git rev-list, check revtreeargs for filenames.
7594 foreach arg $revtreeargs {
7595 if {[file exists $arg]} {
7596 show_error {} . "Ambiguous argument '$arg': both revision\
7602 # unfortunately we get both stdout and stderr in $err,
7603 # so look for "fatal:".
7604 set i [string first "fatal:" $err]
7606 set err [string range $err [expr {$i + 6}] end]
7608 show_error {} . "Bad arguments to gitk:\n$err"
7613 set nullid "0000000000000000000000000000000000000000"
7614 set nullid2 "0000000000000000000000000000000000000001"
7622 set highlight_paths {}
7623 set searchdirn -forwards
7627 set markingmatches 0
7634 set selectedhlview None
7643 set lookingforhead 0
7649 wm title . "[file tail $argv0]: [file tail [pwd]]"
7652 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7653 # create a view for the files/dirs specified on the command line
7657 set viewname(1) "Command line"
7658 set viewfiles(1) $cmdline_files
7659 set viewargs(1) $revtreeargs
7662 .bar.view entryconf Edit* -state normal
7663 .bar.view entryconf Delete* -state normal
7666 if {[info exists permviews]} {
7667 foreach v $permviews {
7670 set viewname($n) [lindex $v 0]
7671 set viewfiles($n) [lindex $v 1]
7672 set viewargs($n) [lindex $v 2]