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
87 set startmsecs
[clock clicks
-milliseconds]
88 set commitidx
($view) 0
89 set args
$viewargs($view)
90 if {$viewfiles($view) ne
{}} {
91 set args
[concat
$args "--" $viewfiles($view)]
93 set order
"--topo-order"
95 set order
"--date-order"
98 set fd
[open
[concat | git rev-list
--header $order \
99 --parents --boundary --default HEAD
$args] r
]
101 puts stderr
"Error executing git rev-list: $err"
104 set commfd
($view) $fd
105 set leftover
($view) {}
106 fconfigure
$fd -blocking 0 -translation lf
107 if {$tclencoding != {}} {
108 fconfigure
$fd -encoding $tclencoding
110 filerun
$fd [list getcommitlines
$fd $view]
114 proc stop_rev_list
{} {
115 global commfd curview
117 if {![info exists commfd
($curview)]} return
118 set fd
$commfd($curview)
124 unset commfd
($curview)
128 global phase canv mainfont curview
132 start_rev_list
$curview
133 show_status
"Reading commits..."
136 proc getcommitlines
{fd view
} {
138 global leftover commfd
139 global displayorder commitidx commitrow commitdata
140 global parentlist childlist children curview hlview
141 global vparentlist vchildlist vdisporder vcmitlisted
143 set stuff
[read $fd 500000]
151 # set it blocking so we wait for the process to terminate
152 fconfigure
$fd -blocking 1
153 if {[catch
{close
$fd} err
]} {
155 if {$view != $curview} {
156 set fv
" for the \"$viewname($view)\" view"
158 if {[string range
$err 0 4] == "usage"} {
159 set err
"Gitk: error reading commits$fv:\
160 bad arguments to git rev-list."
161 if {$viewname($view) eq
"Command line"} {
163 " (Note: arguments to gitk are passed to git rev-list\
164 to allow selection of commits to be displayed.)"
167 set err
"Error reading commits$fv: $err"
171 if {$view == $curview} {
172 run chewcommits
$view
179 set i
[string first
"\0" $stuff $start]
181 append leftover
($view) [string range
$stuff $start end
]
185 set cmit
$leftover($view)
186 append cmit
[string range
$stuff 0 [expr {$i - 1}]]
187 set leftover
($view) {}
189 set cmit
[string range
$stuff $start [expr {$i - 1}]]
191 set start
[expr {$i + 1}]
192 set j
[string first
"\n" $cmit]
196 set ids
[string range
$cmit 0 [expr {$j - 1}]]
197 if {[string range
$ids 0 0] == "-"} {
199 set ids
[string range
$ids 1 end
]
203 if {[string length
$id] != 40} {
211 if {[string length
$shortcmit] > 80} {
212 set shortcmit
"[string range $shortcmit 0 80]..."
214 error_popup
"Can't parse git rev-list output: {$shortcmit}"
217 set id
[lindex
$ids 0]
219 set olds
[lrange
$ids 1 end
]
222 if {$i == 0 ||
[lsearch
-exact $olds $p] >= $i} {
223 lappend children
($view,$p) $id
230 if {![info exists children
($view,$id)]} {
231 set children
($view,$id) {}
233 set commitdata
($id) [string range
$cmit [expr {$j + 1}] end
]
234 set commitrow
($view,$id) $commitidx($view)
235 incr commitidx
($view)
236 if {$view == $curview} {
237 lappend parentlist
$olds
238 lappend childlist
$children($view,$id)
239 lappend displayorder
$id
240 lappend commitlisted
$listed
242 lappend vparentlist
($view) $olds
243 lappend vchildlist
($view) $children($view,$id)
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
[expr {[lindex
$displayorder 0] eq
$nullid}]
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 tagcontents
389 global otherrefids idotherrefs mainhead
391 foreach v
{tagids idtags headids idheads otherrefids idotherrefs
} {
394 set refd
[open
[list | git show-ref
] r
]
395 while {0 <= [set n
[gets
$refd line
]]} {
396 if {![regexp
{^
([0-9a-f]{40}) refs
/([^^
]*)$
} $line \
400 if {[regexp
{^remotes
/.
*/HEAD$
} $path match
]} {
403 if {![regexp
{^
(tags|heads
)/(.
*)$
} $path match
type name
]} {
407 if {[regexp
{^remotes
/} $path match
]} {
410 if {$type == "tags"} {
411 set tagids
($name) $id
412 lappend idtags
($id) $name
417 set commit
[exec git rev-parse
"$id^0"]
418 if {$commit != $id} {
419 set tagids
($name) $commit
420 lappend idtags
($commit) $name
424 set tagcontents
($name) [exec git cat-file tag
$id]
426 } elseif
{ $type == "heads" } {
427 set headids
($name) $id
428 lappend idheads
($id) $name
430 set otherrefids
($name) $id
431 lappend idotherrefs
($id) $name
437 set thehead
[exec git symbolic-ref HEAD
]
438 if {[string match
"refs/heads/*" $thehead]} {
439 set mainhead
[string range
$thehead 11 end
]
444 # update things for a head moved to a child of its previous location
445 proc movehead
{id name
} {
446 global headids idheads
448 removehead
$headids($name) $name
449 set headids
($name) $id
450 lappend idheads
($id) $name
453 # update things when a head has been removed
454 proc removehead
{id name
} {
455 global headids idheads
457 if {$idheads($id) eq
$name} {
460 set i
[lsearch
-exact $idheads($id) $name]
462 set idheads
($id) [lreplace
$idheads($id) $i $i]
468 proc show_error
{w top msg
} {
469 message
$w.m
-text $msg -justify center
-aspect 400
470 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
471 button
$w.ok
-text OK
-command "destroy $top"
472 pack
$w.ok
-side bottom
-fill x
473 bind $top <Visibility
> "grab $top; focus $top"
474 bind $top <Key-Return
> "destroy $top"
478 proc error_popup msg
{
482 show_error
$w $w $msg
485 proc confirm_popup msg
{
491 message
$w.m
-text $msg -justify center
-aspect 400
492 pack
$w.m
-side top
-fill x
-padx 20 -pady 20
493 button
$w.ok
-text OK
-command "set confirm_ok 1; destroy $w"
494 pack
$w.ok
-side left
-fill x
495 button
$w.cancel
-text Cancel
-command "destroy $w"
496 pack
$w.cancel
-side right
-fill x
497 bind $w <Visibility
> "grab $w; focus $w"
503 global canv canv2 canv3 linespc charspc ctext cflist
504 global textfont mainfont uifont tabstop
505 global findtype findtypemenu findloc findstring fstring geometry
506 global entries sha1entry sha1string sha1but
507 global maincursor textcursor curtextcursor
508 global rowctxmenu mergemax wrapcomment
509 global highlight_files gdttype
510 global searchstring sstring
511 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
515 .bar add cascade
-label "File" -menu .bar.
file
516 .bar configure
-font $uifont
518 .bar.
file add
command -label "Update" -command updatecommits
519 .bar.
file add
command -label "Reread references" -command rereadrefs
520 .bar.
file add
command -label "Quit" -command doquit
521 .bar.
file configure
-font $uifont
523 .bar add cascade
-label "Edit" -menu .bar.edit
524 .bar.edit add
command -label "Preferences" -command doprefs
525 .bar.edit configure
-font $uifont
527 menu .bar.view
-font $uifont
528 .bar add cascade
-label "View" -menu .bar.view
529 .bar.view add
command -label "New view..." -command {newview
0}
530 .bar.view add
command -label "Edit view..." -command editview \
532 .bar.view add
command -label "Delete view" -command delview
-state disabled
533 .bar.view add separator
534 .bar.view add radiobutton
-label "All files" -command {showview
0} \
535 -variable selectedview
-value 0
538 .bar add cascade
-label "Help" -menu .bar.
help
539 .bar.
help add
command -label "About gitk" -command about
540 .bar.
help add
command -label "Key bindings" -command keys
541 .bar.
help configure
-font $uifont
542 . configure
-menu .bar
544 # the gui has upper and lower half, parts of a paned window.
545 panedwindow .ctop
-orient vertical
547 # possibly use assumed geometry
548 if {![info exists geometry
(pwsash0
)]} {
549 set geometry
(topheight
) [expr {15 * $linespc}]
550 set geometry
(topwidth
) [expr {80 * $charspc}]
551 set geometry
(botheight
) [expr {15 * $linespc}]
552 set geometry
(botwidth
) [expr {50 * $charspc}]
553 set geometry
(pwsash0
) "[expr {40 * $charspc}] 2"
554 set geometry
(pwsash1
) "[expr {60 * $charspc}] 2"
557 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
558 frame .tf
-height $geometry(topheight
) -width $geometry(topwidth
)
560 panedwindow .tf.histframe.pwclist
-orient horizontal
-sashpad 0 -handlesize 4
562 # create three canvases
563 set cscroll .tf.histframe.csb
564 set canv .tf.histframe.pwclist.canv
566 -selectbackground $selectbgcolor \
567 -background $bgcolor -bd 0 \
568 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
569 .tf.histframe.pwclist add
$canv
570 set canv2 .tf.histframe.pwclist.canv2
572 -selectbackground $selectbgcolor \
573 -background $bgcolor -bd 0 -yscrollincr $linespc
574 .tf.histframe.pwclist add
$canv2
575 set canv3 .tf.histframe.pwclist.canv3
577 -selectbackground $selectbgcolor \
578 -background $bgcolor -bd 0 -yscrollincr $linespc
579 .tf.histframe.pwclist add
$canv3
580 eval .tf.histframe.pwclist sash place
0 $geometry(pwsash0
)
581 eval .tf.histframe.pwclist sash place
1 $geometry(pwsash1
)
583 # a scroll bar to rule them
584 scrollbar
$cscroll -command {allcanvs yview
} -highlightthickness 0
585 pack
$cscroll -side right
-fill y
586 bind .tf.histframe.pwclist
<Configure
> {resizeclistpanes
%W
%w
}
587 lappend bglist
$canv $canv2 $canv3
588 pack .tf.histframe.pwclist
-fill both
-expand 1 -side left
590 # we have two button bars at bottom of top frame. Bar 1
592 frame .tf.lbar
-height 15
594 set sha1entry .tf.bar.sha1
595 set entries
$sha1entry
596 set sha1but .tf.bar.sha1label
597 button
$sha1but -text "SHA1 ID: " -state disabled
-relief flat \
598 -command gotocommit
-width 8 -font $uifont
599 $sha1but conf
-disabledforeground [$sha1but cget
-foreground]
600 pack .tf.bar.sha1label
-side left
601 entry
$sha1entry -width 40 -font $textfont -textvariable sha1string
602 trace add variable sha1string
write sha1change
603 pack
$sha1entry -side left
-pady 2
605 image create bitmap bm-left
-data {
606 #define left_width 16
607 #define left_height 16
608 static unsigned char left_bits
[] = {
609 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
610 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
611 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
613 image create bitmap bm-right
-data {
614 #define right_width 16
615 #define right_height 16
616 static unsigned char right_bits
[] = {
617 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
618 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
619 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
621 button .tf.bar.leftbut
-image bm-left
-command goback \
622 -state disabled
-width 26
623 pack .tf.bar.leftbut
-side left
-fill y
624 button .tf.bar.rightbut
-image bm-right
-command goforw \
625 -state disabled
-width 26
626 pack .tf.bar.rightbut
-side left
-fill y
628 button .tf.bar.findbut
-text "Find" -command dofind
-font $uifont
629 pack .tf.bar.findbut
-side left
631 set fstring .tf.bar.findstring
632 lappend entries
$fstring
633 entry
$fstring -width 30 -font $textfont -textvariable findstring
634 trace add variable findstring
write find_change
635 pack
$fstring -side left
-expand 1 -fill x
-in .tf.bar
637 set findtypemenu
[tk_optionMenu .tf.bar.findtype \
638 findtype Exact IgnCase Regexp
]
639 trace add variable findtype
write find_change
640 .tf.bar.findtype configure
-font $uifont
641 .tf.bar.findtype.menu configure
-font $uifont
642 set findloc
"All fields"
643 tk_optionMenu .tf.bar.findloc findloc
"All fields" Headline \
644 Comments Author Committer
645 trace add variable findloc
write find_change
646 .tf.bar.findloc configure
-font $uifont
647 .tf.bar.findloc.menu configure
-font $uifont
648 pack .tf.bar.findloc
-side right
649 pack .tf.bar.findtype
-side right
651 # build up the bottom bar of upper window
652 label .tf.lbar.flabel
-text "Highlight: Commits " \
654 pack .tf.lbar.flabel
-side left
-fill y
655 set gdttype
"touching paths:"
656 set gm
[tk_optionMenu .tf.lbar.gdttype gdttype
"touching paths:" \
657 "adding/removing string:"]
658 trace add variable gdttype
write hfiles_change
659 $gm conf
-font $uifont
660 .tf.lbar.gdttype conf
-font $uifont
661 pack .tf.lbar.gdttype
-side left
-fill y
662 entry .tf.lbar.fent
-width 25 -font $textfont \
663 -textvariable highlight_files
664 trace add variable highlight_files
write hfiles_change
665 lappend entries .tf.lbar.fent
666 pack .tf.lbar.fent
-side left
-fill x
-expand 1
667 label .tf.lbar.vlabel
-text " OR in view" -font $uifont
668 pack .tf.lbar.vlabel
-side left
-fill y
669 global viewhlmenu selectedhlview
670 set viewhlmenu
[tk_optionMenu .tf.lbar.vhl selectedhlview None
]
671 $viewhlmenu entryconf None
-command delvhighlight
672 $viewhlmenu conf
-font $uifont
673 .tf.lbar.vhl conf
-font $uifont
674 pack .tf.lbar.vhl
-side left
-fill y
675 label .tf.lbar.rlabel
-text " OR " -font $uifont
676 pack .tf.lbar.rlabel
-side left
-fill y
677 global highlight_related
678 set m
[tk_optionMenu .tf.lbar.relm highlight_related None \
679 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
680 $m conf
-font $uifont
681 .tf.lbar.relm conf
-font $uifont
682 trace add variable highlight_related
write vrel_change
683 pack .tf.lbar.relm
-side left
-fill y
685 # Finish putting the upper half of the viewer together
686 pack .tf.lbar
-in .tf
-side bottom
-fill x
687 pack .tf.bar
-in .tf
-side bottom
-fill x
688 pack .tf.histframe
-fill both
-side top
-expand 1
690 .ctop paneconfigure .tf
-height $geometry(topheight
)
691 .ctop paneconfigure .tf
-width $geometry(topwidth
)
693 # now build up the bottom
694 panedwindow .pwbottom
-orient horizontal
696 # lower left, a text box over search bar, scroll bar to the right
697 # if we know window height, then that will set the lower text height, otherwise
698 # we set lower text height which will drive window height
699 if {[info exists geometry
(main
)]} {
700 frame .bleft
-width $geometry(botwidth
)
702 frame .bleft
-width $geometry(botwidth
) -height $geometry(botheight
)
707 button .bleft.top.search
-text "Search" -command dosearch \
709 pack .bleft.top.search
-side left
-padx 5
710 set sstring .bleft.top.sstring
711 entry
$sstring -width 20 -font $textfont -textvariable searchstring
712 lappend entries
$sstring
713 trace add variable searchstring
write incrsearch
714 pack
$sstring -side left
-expand 1 -fill x
715 radiobutton .bleft.mid.
diff -text "Diff" \
716 -command changediffdisp
-variable diffelide
-value {0 0}
717 radiobutton .bleft.mid.old
-text "Old version" \
718 -command changediffdisp
-variable diffelide
-value {0 1}
719 radiobutton .bleft.mid.new
-text "New version" \
720 -command changediffdisp
-variable diffelide
-value {1 0}
721 pack .bleft.mid.
diff .bleft.mid.old .bleft.mid.new
-side left
722 set ctext .bleft.ctext
723 text
$ctext -background $bgcolor -foreground $fgcolor \
724 -tabs "[expr {$tabstop * $charspc}]" \
725 -state disabled
-font $textfont \
726 -yscrollcommand scrolltext
-wrap none
727 scrollbar .bleft.sb
-command "$ctext yview"
728 pack .bleft.top
-side top
-fill x
729 pack .bleft.mid
-side top
-fill x
730 pack .bleft.sb
-side right
-fill y
731 pack
$ctext -side left
-fill both
-expand 1
732 lappend bglist
$ctext
733 lappend fglist
$ctext
735 $ctext tag conf comment
-wrap $wrapcomment
736 $ctext tag conf filesep
-font [concat
$textfont bold
] -back "#aaaaaa"
737 $ctext tag conf hunksep
-fore [lindex
$diffcolors 2]
738 $ctext tag conf d0
-fore [lindex
$diffcolors 0]
739 $ctext tag conf d1
-fore [lindex
$diffcolors 1]
740 $ctext tag conf m0
-fore red
741 $ctext tag conf m1
-fore blue
742 $ctext tag conf m2
-fore green
743 $ctext tag conf m3
-fore purple
744 $ctext tag conf
m4 -fore brown
745 $ctext tag conf m5
-fore "#009090"
746 $ctext tag conf m6
-fore magenta
747 $ctext tag conf m7
-fore "#808000"
748 $ctext tag conf m8
-fore "#009000"
749 $ctext tag conf m9
-fore "#ff0080"
750 $ctext tag conf m10
-fore cyan
751 $ctext tag conf m11
-fore "#b07070"
752 $ctext tag conf m12
-fore "#70b0f0"
753 $ctext tag conf m13
-fore "#70f0b0"
754 $ctext tag conf m14
-fore "#f0b070"
755 $ctext tag conf m15
-fore "#ff70b0"
756 $ctext tag conf mmax
-fore darkgrey
758 $ctext tag conf mresult
-font [concat
$textfont bold
]
759 $ctext tag conf msep
-font [concat
$textfont bold
]
760 $ctext tag conf found
-back yellow
763 .pwbottom paneconfigure .bleft
-width $geometry(botwidth
)
768 radiobutton .bright.mode.
patch -text "Patch" \
769 -command reselectline
-variable cmitmode
-value "patch"
770 .bright.mode.
patch configure
-font $uifont
771 radiobutton .bright.mode.tree
-text "Tree" \
772 -command reselectline
-variable cmitmode
-value "tree"
773 .bright.mode.tree configure
-font $uifont
774 grid .bright.mode.
patch .bright.mode.tree
-sticky ew
775 pack .bright.mode
-side top
-fill x
776 set cflist .bright.cfiles
777 set indent
[font measure
$mainfont "nn"]
779 -selectbackground $selectbgcolor \
780 -background $bgcolor -foreground $fgcolor \
782 -tabs [list
$indent [expr {2 * $indent}]] \
783 -yscrollcommand ".bright.sb set" \
784 -cursor [. cget
-cursor] \
785 -spacing1 1 -spacing3 1
786 lappend bglist
$cflist
787 lappend fglist
$cflist
788 scrollbar .bright.sb
-command "$cflist yview"
789 pack .bright.sb
-side right
-fill y
790 pack
$cflist -side left
-fill both
-expand 1
791 $cflist tag configure highlight \
792 -background [$cflist cget
-selectbackground]
793 $cflist tag configure bold
-font [concat
$mainfont bold
]
795 .pwbottom add .bright
798 # restore window position if known
799 if {[info exists geometry
(main
)]} {
800 wm geometry .
"$geometry(main)"
803 bind .pwbottom
<Configure
> {resizecdetpanes
%W
%w
}
804 pack .ctop
-fill both
-expand 1
805 bindall
<1> {selcanvline
%W
%x
%y
}
806 #bindall <B1-Motion> {selcanvline %W %x %y}
807 bindall
<ButtonRelease-4
> "allcanvs yview scroll -5 units"
808 bindall
<ButtonRelease-5
> "allcanvs yview scroll 5 units"
809 bindall
<2> "canvscan mark %W %x %y"
810 bindall
<B2-Motion
> "canvscan dragto %W %x %y"
811 bindkey
<Home
> selfirstline
812 bindkey
<End
> sellastline
813 bind .
<Key-Up
> "selnextline -1"
814 bind .
<Key-Down
> "selnextline 1"
815 bind .
<Shift-Key-Up
> "next_highlight -1"
816 bind .
<Shift-Key-Down
> "next_highlight 1"
817 bindkey
<Key-Right
> "goforw"
818 bindkey
<Key-Left
> "goback"
819 bind .
<Key-Prior
> "selnextpage -1"
820 bind .
<Key-Next
> "selnextpage 1"
821 bind .
<Control-Home
> "allcanvs yview moveto 0.0"
822 bind .
<Control-End
> "allcanvs yview moveto 1.0"
823 bind .
<Control-Key-Up
> "allcanvs yview scroll -1 units"
824 bind .
<Control-Key-Down
> "allcanvs yview scroll 1 units"
825 bind .
<Control-Key-Prior
> "allcanvs yview scroll -1 pages"
826 bind .
<Control-Key-Next
> "allcanvs yview scroll 1 pages"
827 bindkey
<Key-Delete
> "$ctext yview scroll -1 pages"
828 bindkey
<Key-BackSpace
> "$ctext yview scroll -1 pages"
829 bindkey
<Key-space
> "$ctext yview scroll 1 pages"
830 bindkey p
"selnextline -1"
831 bindkey n
"selnextline 1"
834 bindkey i
"selnextline -1"
835 bindkey k
"selnextline 1"
838 bindkey b
"$ctext yview scroll -1 pages"
839 bindkey d
"$ctext yview scroll 18 units"
840 bindkey u
"$ctext yview scroll -18 units"
841 bindkey
/ {findnext
1}
842 bindkey
<Key-Return
> {findnext
0}
845 bindkey
<F5
> updatecommits
846 bind .
<Control-q
> doquit
847 bind .
<Control-f
> dofind
848 bind .
<Control-g
> {findnext
0}
849 bind .
<Control-r
> dosearchback
850 bind .
<Control-s
> dosearch
851 bind .
<Control-equal
> {incrfont
1}
852 bind .
<Control-KP_Add
> {incrfont
1}
853 bind .
<Control-minus
> {incrfont
-1}
854 bind .
<Control-KP_Subtract
> {incrfont
-1}
855 wm protocol . WM_DELETE_WINDOW doquit
856 bind .
<Button-1
> "click %W"
857 bind $fstring <Key-Return
> dofind
858 bind $sha1entry <Key-Return
> gotocommit
859 bind $sha1entry <<PasteSelection>> clearsha1
860 bind $cflist <1> {sel_flist %W %x %y; break}
861 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
862 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
864 set maincursor [. cget -cursor]
865 set textcursor [$ctext cget -cursor]
866 set curtextcursor $textcursor
868 set rowctxmenu .rowctxmenu
869 menu $rowctxmenu -tearoff 0
870 $rowctxmenu add command -label "Diff this -> selected" \
871 -command {diffvssel 0}
872 $rowctxmenu add command -label "Diff selected -> this" \
873 -command {diffvssel 1}
874 $rowctxmenu add command -label "Make patch" -command mkpatch
875 $rowctxmenu add command -label "Create tag" -command mktag
876 $rowctxmenu add command -label "Write commit to file" -command writecommit
877 $rowctxmenu add command -label "Create new branch" -command mkbranch
878 $rowctxmenu add command -label "Cherry-pick this commit" \
881 set headctxmenu .headctxmenu
882 menu $headctxmenu -tearoff 0
883 $headctxmenu add command -label "Check out this branch" \
885 $headctxmenu add command -label "Remove this branch" \
889 # mouse-2 makes all windows scan vertically, but only the one
890 # the cursor is in scans horizontally
891 proc canvscan {op w x y} {
892 global canv canv2 canv3
893 foreach c [list $canv $canv2 $canv3] {
902 proc scrollcanv {cscroll f0 f1} {
908 # when we make a key binding for the toplevel, make sure
909 # it doesn't get triggered when that key is pressed in the
910 # find string entry widget.
911 proc bindkey {ev script} {
914 set escript [bind Entry $ev]
915 if {$escript == {}} {
916 set escript [bind Entry <Key>]
919 bind $e $ev "$escript; break"
923 # set the focus back to the toplevel for any click outside
934 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
935 global stuffsaved findmergefiles maxgraphpct
936 global maxwidth showneartags
937 global viewname viewfiles viewargs viewperm nextviewnum
938 global cmitmode wrapcomment
939 global colors bgcolor fgcolor diffcolors selectbgcolor
941 if {$stuffsaved} return
942 if {![winfo viewable .]} return
944 set f [open "~/.gitk-new" w]
945 puts $f [list set mainfont $mainfont]
946 puts $f [list set textfont $textfont]
947 puts $f [list set uifont $uifont]
948 puts $f [list set tabstop $tabstop]
949 puts $f [list set findmergefiles $findmergefiles]
950 puts $f [list set maxgraphpct $maxgraphpct]
951 puts $f [list set maxwidth $maxwidth]
952 puts $f [list set cmitmode $cmitmode]
953 puts $f [list set wrapcomment $wrapcomment]
954 puts $f [list set showneartags $showneartags]
955 puts $f [list set bgcolor $bgcolor]
956 puts $f [list set fgcolor $fgcolor]
957 puts $f [list set colors $colors]
958 puts $f [list set diffcolors $diffcolors]
959 puts $f [list set selectbgcolor $selectbgcolor]
961 puts $f "set geometry(main) [wm geometry .]"
962 puts $f "set geometry(topwidth) [winfo width .tf]"
963 puts $f "set geometry(topheight) [winfo height .tf]"
964 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
965 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
966 puts $f "set geometry(botwidth) [winfo width .bleft]"
967 puts $f "set geometry(botheight) [winfo height .bleft]"
969 puts -nonewline $f "set permviews {"
970 for {set v 0} {$v < $nextviewnum} {incr v} {
972 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
977 file rename -force "~/.gitk-new" "~/.gitk"
982 proc resizeclistpanes {win w} {
984 if {[info exists oldwidth($win)]} {
985 set s0 [$win sash coord 0]
986 set s1 [$win sash coord 1]
988 set sash0 [expr {int($w/2 - 2)}]
989 set sash1 [expr {int($w*5/6 - 2)}]
991 set factor [expr {1.0 * $w / $oldwidth($win)}]
992 set sash0 [expr {int($factor * [lindex $s0 0])}]
993 set sash1 [expr {int($factor * [lindex $s1 0])}]
997 if {$sash1 < $sash0 + 20} {
998 set sash1 [expr {$sash0 + 20}]
1000 if {$sash1 > $w - 10} {
1001 set sash1 [expr {$w - 10}]
1002 if {$sash0 > $sash1 - 20} {
1003 set sash0 [expr {$sash1 - 20}]
1007 $win sash place 0 $sash0 [lindex $s0 1]
1008 $win sash place 1 $sash1 [lindex $s1 1]
1010 set oldwidth($win) $w
1013 proc resizecdetpanes {win w} {
1015 if {[info exists oldwidth($win)]} {
1016 set s0 [$win sash coord 0]
1018 set sash0 [expr {int($w*3/4 - 2)}]
1020 set factor [expr {1.0 * $w / $oldwidth($win)}]
1021 set sash0 [expr {int($factor * [lindex $s0 0])}]
1025 if {$sash0 > $w - 15} {
1026 set sash0 [expr {$w - 15}]
1029 $win sash place 0 $sash0 [lindex $s0 1]
1031 set oldwidth($win) $w
1034 proc allcanvs args {
1035 global canv canv2 canv3
1041 proc bindall {event action} {
1042 global canv canv2 canv3
1043 bind $canv $event $action
1044 bind $canv2 $event $action
1045 bind $canv3 $event $action
1051 if {[winfo exists $w]} {
1056 wm title $w "About gitk"
1057 message $w.m -text {
1058 Gitk - a commit viewer for git
1060 Copyright © 2005-2006 Paul Mackerras
1062 Use and redistribute under the terms of the GNU General Public License} \
1063 -justify center -aspect 400 -border 2 -bg white -relief groove
1064 pack $w.m -side top -fill x -padx 2 -pady 2
1065 $w.m configure -font $uifont
1066 button $w.ok -text Close -command "destroy $w" -default active
1067 pack $w.ok -side bottom
1068 $w.ok configure -font $uifont
1069 bind $w <Visibility> "focus $w.ok"
1070 bind $w <Key-Escape> "destroy $w"
1071 bind $w <Key-Return> "destroy $w"
1077 if {[winfo exists $w]} {
1082 wm title $w "Gitk key bindings"
1083 message $w.m -text {
1087 <Home> Move to first commit
1088 <End> Move to last commit
1089 <Up>, p, i Move up one commit
1090 <Down>, n, k Move down one commit
1091 <Left>, z, j Go back in history list
1092 <Right>, x, l Go forward in history list
1093 <PageUp> Move up one page in commit list
1094 <PageDown> Move down one page in commit list
1095 <Ctrl-Home> Scroll to top of commit list
1096 <Ctrl-End> Scroll to bottom of commit list
1097 <Ctrl-Up> Scroll commit list up one line
1098 <Ctrl-Down> Scroll commit list down one line
1099 <Ctrl-PageUp> Scroll commit list up one page
1100 <Ctrl-PageDown> Scroll commit list down one page
1101 <Shift-Up> Move to previous highlighted line
1102 <Shift-Down> Move to next highlighted line
1103 <Delete>, b Scroll diff view up one page
1104 <Backspace> Scroll diff view up one page
1105 <Space> Scroll diff view down one page
1106 u Scroll diff view up 18 lines
1107 d Scroll diff view down 18 lines
1109 <Ctrl-G> Move to next find hit
1110 <Return> Move to next find hit
1111 / Move to next find hit, or redo find
1112 ? Move to previous find hit
1113 f Scroll diff view to next file
1114 <Ctrl-S> Search for next hit in diff view
1115 <Ctrl-R> Search for previous hit in diff view
1116 <Ctrl-KP+> Increase font size
1117 <Ctrl-plus> Increase font size
1118 <Ctrl-KP-> Decrease font size
1119 <Ctrl-minus> Decrease font size
1122 -justify left -bg white -border 2 -relief groove
1123 pack $w.m -side top -fill both -padx 2 -pady 2
1124 $w.m configure -font $uifont
1125 button $w.ok -text Close -command "destroy $w" -default active
1126 pack $w.ok -side bottom
1127 $w.ok configure -font $uifont
1128 bind $w <Visibility> "focus $w.ok"
1129 bind $w <Key-Escape> "destroy $w"
1130 bind $w <Key-Return> "destroy $w"
1133 # Procedures for manipulating the file list window at the
1134 # bottom right of the overall window.
1136 proc treeview {w l openlevs} {
1137 global treecontents treediropen treeheight treeparent treeindex
1147 set treecontents() {}
1148 $w conf -state normal
1150 while {[string range $f 0 $prefixend] ne $prefix} {
1151 if {$lev <= $openlevs} {
1152 $w mark set e:$treeindex($prefix) "end -1c"
1153 $w mark gravity e:$treeindex($prefix) left
1155 set treeheight($prefix) $ht
1156 incr ht [lindex $htstack end]
1157 set htstack [lreplace $htstack end end]
1158 set prefixend [lindex $prefendstack end]
1159 set prefendstack [lreplace $prefendstack end end]
1160 set prefix [string range $prefix 0 $prefixend]
1163 set tail [string range $f [expr {$prefixend+1}] end]
1164 while {[set slash [string first "/" $tail]] >= 0} {
1167 lappend prefendstack $prefixend
1168 incr prefixend [expr {$slash + 1}]
1169 set d [string range $tail 0 $slash]
1170 lappend treecontents($prefix) $d
1171 set oldprefix $prefix
1173 set treecontents($prefix) {}
1174 set treeindex($prefix) [incr ix]
1175 set treeparent($prefix) $oldprefix
1176 set tail [string range $tail [expr {$slash+1}] end]
1177 if {$lev <= $openlevs} {
1179 set treediropen($prefix) [expr {$lev < $openlevs}]
1180 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1181 $w mark set d:$ix "end -1c"
1182 $w mark gravity d:$ix left
1184 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1186 $w image create end -align center -image $bm -padx 1 \
1188 $w insert end $d [highlight_tag $prefix]
1189 $w mark set s:$ix "end -1c"
1190 $w mark gravity s:$ix left
1195 if {$lev <= $openlevs} {
1198 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1200 $w insert end $tail [highlight_tag $f]
1202 lappend treecontents($prefix) $tail
1205 while {$htstack ne {}} {
1206 set treeheight($prefix) $ht
1207 incr ht [lindex $htstack end]
1208 set htstack [lreplace $htstack end end]
1210 $w conf -state disabled
1213 proc linetoelt {l} {
1214 global treeheight treecontents
1219 foreach e $treecontents($prefix) {
1224 if {[string index $e end] eq "/"} {
1225 set n $treeheight($prefix$e)
1237 proc highlight_tree {y prefix} {
1238 global treeheight treecontents cflist
1240 foreach e $treecontents($prefix) {
1242 if {[highlight_tag $path] ne {}} {
1243 $cflist tag add bold $y.0 "$y.0 lineend"
1246 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1247 set y [highlight_tree $y $path]
1253 proc treeclosedir {w dir} {
1254 global treediropen treeheight treeparent treeindex
1256 set ix $treeindex($dir)
1257 $w conf -state normal
1258 $w delete s:$ix e:$ix
1259 set treediropen($dir) 0
1260 $w image configure a:$ix -image tri-rt
1261 $w conf -state disabled
1262 set n [expr {1 - $treeheight($dir)}]
1263 while {$dir ne {}} {
1264 incr treeheight($dir) $n
1265 set dir $treeparent($dir)
1269 proc treeopendir {w dir} {
1270 global treediropen treeheight treeparent treecontents treeindex
1272 set ix $treeindex($dir)
1273 $w conf -state normal
1274 $w image configure a:$ix -image tri-dn
1275 $w mark set e:$ix s:$ix
1276 $w mark gravity e:$ix right
1279 set n [llength $treecontents($dir)]
1280 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1283 incr treeheight($x) $n
1285 foreach e $treecontents($dir) {
1287 if {[string index $e end] eq "/"} {
1288 set iy $treeindex($de)
1289 $w mark set d:$iy e:$ix
1290 $w mark gravity d:$iy left
1291 $w insert e:$ix $str
1292 set treediropen($de) 0
1293 $w image create e:$ix -align center -image tri-rt -padx 1 \
1295 $w insert e:$ix $e [highlight_tag $de]
1296 $w mark set s:$iy e:$ix
1297 $w mark gravity s:$iy left
1298 set treeheight($de) 1
1300 $w insert e:$ix $str
1301 $w insert e:$ix $e [highlight_tag $de]
1304 $w mark gravity e:$ix left
1305 $w conf -state disabled
1306 set treediropen($dir) 1
1307 set top [lindex [split [$w index @0,0] .] 0]
1308 set ht [$w cget -height]
1309 set l [lindex [split [$w index s:$ix] .] 0]
1312 } elseif {$l + $n + 1 > $top + $ht} {
1313 set top [expr {$l + $n + 2 - $ht}]
1321 proc treeclick {w x y} {
1322 global treediropen cmitmode ctext cflist cflist_top
1324 if {$cmitmode ne "tree"} return
1325 if {![info exists cflist_top]} return
1326 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1327 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1328 $cflist tag add highlight $l.0 "$l.0 lineend"
1334 set e [linetoelt $l]
1335 if {[string index $e end] ne "/"} {
1337 } elseif {$treediropen($e)} {
1344 proc setfilelist {id} {
1345 global treefilelist cflist
1347 treeview $cflist $treefilelist($id) 0
1350 image create bitmap tri-rt -background black -foreground blue -data {
1351 #define tri-rt_width 13
1352 #define tri-rt_height 13
1353 static unsigned char tri-rt_bits[] = {
1354 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1355 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1358 #define tri-rt-mask_width 13
1359 #define tri-rt-mask_height 13
1360 static unsigned char tri-rt-mask_bits[] = {
1361 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1362 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1365 image create bitmap tri-dn -background black -foreground blue -data {
1366 #define tri-dn_width 13
1367 #define tri-dn_height 13
1368 static unsigned char tri-dn_bits[] = {
1369 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1370 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1373 #define tri-dn-mask_width 13
1374 #define tri-dn-mask_height 13
1375 static unsigned char tri-dn-mask_bits[] = {
1376 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1377 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1381 proc init_flist {first} {
1382 global cflist cflist_top selectedline difffilestart
1384 $cflist conf -state normal
1385 $cflist delete 0.0 end
1387 $cflist insert end $first
1389 $cflist tag add highlight 1.0 "1.0 lineend"
1391 catch {unset cflist_top}
1393 $cflist conf -state disabled
1394 set difffilestart {}
1397 proc highlight_tag {f} {
1398 global highlight_paths
1400 foreach p $highlight_paths {
1401 if {[string match $p $f]} {
1408 proc highlight_filelist {} {
1409 global cmitmode cflist
1411 $cflist conf -state normal
1412 if {$cmitmode ne "tree"} {
1413 set end [lindex [split [$cflist index end] .] 0]
1414 for {set l 2} {$l < $end} {incr l} {
1415 set line [$cflist get $l.0 "$l.0 lineend"]
1416 if {[highlight_tag $line] ne {}} {
1417 $cflist tag add bold $l.0 "$l.0 lineend"
1423 $cflist conf -state disabled
1426 proc unhighlight_filelist {} {
1429 $cflist conf -state normal
1430 $cflist tag remove bold 1.0 end
1431 $cflist conf -state disabled
1434 proc add_flist {fl} {
1437 $cflist conf -state normal
1439 $cflist insert end "\n"
1440 $cflist insert end $f [highlight_tag $f]
1442 $cflist conf -state disabled
1445 proc sel_flist {w x y} {
1446 global ctext difffilestart cflist cflist_top cmitmode
1448 if {$cmitmode eq "tree"} return
1449 if {![info exists cflist_top]} return
1450 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1451 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1452 $cflist tag add highlight $l.0 "$l.0 lineend"
1457 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1461 # Functions for adding and removing shell-type quoting
1463 proc shellquote {str} {
1464 if {![string match "*\['\"\\ \t]*" $str]} {
1467 if {![string match "*\['\"\\]*" $str]} {
1470 if {![string match "*'*" $str]} {
1473 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1476 proc shellarglist {l} {
1482 append str [shellquote $a]
1487 proc shelldequote {str} {
1492 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1493 append ret [string range $str $used end]
1494 set used [string length $str]
1497 set first [lindex $first 0]
1498 set ch [string index $str $first]
1499 if {$first > $used} {
1500 append ret [string range $str $used [expr {$first - 1}]]
1503 if {$ch eq " " || $ch eq "\t"} break
1506 set first [string first "'" $str $used]
1508 error "unmatched single-quote"
1510 append ret [string range $str $used [expr {$first - 1}]]
1515 if {$used >= [string length $str]} {
1516 error "trailing backslash"
1518 append ret [string index $str $used]
1523 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1524 error "unmatched double-quote"
1526 set first [lindex $first 0]
1527 set ch [string index $str $first]
1528 if {$first > $used} {
1529 append ret [string range $str $used [expr {$first - 1}]]
1532 if {$ch eq "\""} break
1534 append ret [string index $str $used]
1538 return [list $used $ret]
1541 proc shellsplit {str} {
1544 set str [string trimleft $str]
1545 if {$str eq {}} break
1546 set dq [shelldequote $str]
1547 set n [lindex $dq 0]
1548 set word [lindex $dq 1]
1549 set str [string range $str $n end]
1555 # Code to implement multiple views
1557 proc newview {ishighlight} {
1558 global nextviewnum newviewname newviewperm uifont newishighlight
1559 global newviewargs revtreeargs
1561 set newishighlight $ishighlight
1563 if {[winfo exists $top]} {
1567 set newviewname($nextviewnum) "View $nextviewnum"
1568 set newviewperm($nextviewnum) 0
1569 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1570 vieweditor $top $nextviewnum "Gitk view definition"
1575 global viewname viewperm newviewname newviewperm
1576 global viewargs newviewargs
1578 set top .gitkvedit-$curview
1579 if {[winfo exists $top]} {
1583 set newviewname($curview) $viewname($curview)
1584 set newviewperm($curview) $viewperm($curview)
1585 set newviewargs($curview) [shellarglist $viewargs($curview)]
1586 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1589 proc vieweditor {top n title} {
1590 global newviewname newviewperm viewfiles
1594 wm title $top $title
1595 label $top.nl -text "Name" -font $uifont
1596 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1597 grid $top.nl $top.name -sticky w -pady 5
1598 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1600 grid $top.perm - -pady 5 -sticky w
1601 message $top.al -aspect 1000 -font $uifont \
1602 -text "Commits to include (arguments to git rev-list):"
1603 grid $top.al - -sticky w -pady 5
1604 entry $top.args -width 50 -textvariable newviewargs($n) \
1605 -background white -font $uifont
1606 grid $top.args - -sticky ew -padx 5
1607 message $top.l -aspect 1000 -font $uifont \
1608 -text "Enter files and directories to include, one per line:"
1609 grid $top.l - -sticky w
1610 text $top.t -width 40 -height 10 -background white -font $uifont
1611 if {[info exists viewfiles($n)]} {
1612 foreach f $viewfiles($n) {
1613 $top.t insert end $f
1614 $top.t insert end "\n"
1616 $top.t delete {end - 1c} end
1617 $top.t mark set insert 0.0
1619 grid $top.t - -sticky ew -padx 5
1621 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1623 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1625 grid $top.buts.ok $top.buts.can
1626 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1627 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1628 grid $top.buts - -pady 10 -sticky ew
1632 proc doviewmenu {m first cmd op argv} {
1633 set nmenu [$m index end]
1634 for {set i $first} {$i <= $nmenu} {incr i} {
1635 if {[$m entrycget $i -command] eq $cmd} {
1636 eval $m $op $i $argv
1642 proc allviewmenus {n op args} {
1645 doviewmenu .bar.view 5 [list showview $n] $op $args
1646 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1649 proc newviewok {top n} {
1650 global nextviewnum newviewperm newviewname newishighlight
1651 global viewname viewfiles viewperm selectedview curview
1652 global viewargs newviewargs viewhlmenu
1655 set newargs [shellsplit $newviewargs($n)]
1657 error_popup "Error in commit selection arguments: $err"
1663 foreach f [split [$top.t get 0.0 end] "\n"] {
1664 set ft [string trim $f]
1669 if {![info exists viewfiles($n)]} {
1670 # creating a new view
1672 set viewname($n) $newviewname($n)
1673 set viewperm($n) $newviewperm($n)
1674 set viewfiles($n) $files
1675 set viewargs($n) $newargs
1677 if {!$newishighlight} {
1680 run addvhighlight $n
1683 # editing an existing view
1684 set viewperm($n) $newviewperm($n)
1685 if {$newviewname($n) ne $viewname($n)} {
1686 set viewname($n) $newviewname($n)
1687 doviewmenu .bar.view 5 [list showview $n] \
1688 entryconf [list -label $viewname($n)]
1689 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1690 entryconf [list -label $viewname($n) -value $viewname($n)]
1692 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1693 set viewfiles($n) $files
1694 set viewargs($n) $newargs
1695 if {$curview == $n} {
1700 catch {destroy $top}
1704 global curview viewdata viewperm hlview selectedhlview
1706 if {$curview == 0} return
1707 if {[info exists hlview] && $hlview == $curview} {
1708 set selectedhlview None
1711 allviewmenus $curview delete
1712 set viewdata($curview) {}
1713 set viewperm($curview) 0
1717 proc addviewmenu {n} {
1718 global viewname viewhlmenu
1720 .bar.view add radiobutton -label $viewname($n) \
1721 -command [list showview $n] -variable selectedview -value $n
1722 $viewhlmenu add radiobutton -label $viewname($n) \
1723 -command [list addvhighlight $n] -variable selectedhlview
1726 proc flatten {var} {
1730 foreach i [array names $var] {
1731 lappend ret $i [set $var\($i\)]
1736 proc unflatten {var l} {
1746 global curview viewdata viewfiles
1747 global displayorder parentlist childlist rowidlist rowoffsets
1748 global colormap rowtextx commitrow nextcolor canvxmax
1749 global numcommits rowrangelist commitlisted idrowranges
1750 global selectedline currentid canv canvy0
1751 global matchinglines treediffs
1752 global pending_select phase
1753 global commitidx rowlaidout rowoptim
1755 global selectedview selectfirst
1756 global vparentlist vchildlist vdisporder vcmitlisted
1757 global hlview selectedhlview
1759 if {$n == $curview} return
1761 if {[info exists selectedline]} {
1762 set selid $currentid
1763 set y [yc $selectedline]
1764 set ymax [lindex [$canv cget -scrollregion] 3]
1765 set span [$canv yview]
1766 set ytop [expr {[lindex $span 0] * $ymax}]
1767 set ybot [expr {[lindex $span 1] * $ymax}]
1768 if {$ytop < $y && $y < $ybot} {
1769 set yscreen [expr {$y - $ytop}]
1771 set yscreen [expr {($ybot - $ytop) / 2}]
1773 } elseif {[info exists pending_select]} {
1774 set selid $pending_select
1775 unset pending_select
1780 if {$curview >= 0} {
1781 set vparentlist($curview) $parentlist
1782 set vchildlist($curview) $childlist
1783 set vdisporder($curview) $displayorder
1784 set vcmitlisted($curview) $commitlisted
1786 set viewdata($curview) \
1787 [list $phase $rowidlist $rowoffsets $rowrangelist \
1788 [flatten idrowranges] [flatten idinlist] \
1789 $rowlaidout $rowoptim $numcommits]
1790 } elseif {![info exists viewdata($curview)]
1791 || [lindex $viewdata($curview) 0] ne {}} {
1792 set viewdata($curview) \
1793 [list {} $rowidlist $rowoffsets $rowrangelist]
1796 catch {unset matchinglines}
1797 catch {unset treediffs}
1799 if {[info exists hlview] && $hlview == $n} {
1801 set selectedhlview None
1806 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1807 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1809 if {![info exists viewdata($n)]} {
1811 set pending_select $selid
1818 set phase [lindex $v 0]
1819 set displayorder $vdisporder($n)
1820 set parentlist $vparentlist($n)
1821 set childlist $vchildlist($n)
1822 set commitlisted $vcmitlisted($n)
1823 set rowidlist [lindex $v 1]
1824 set rowoffsets [lindex $v 2]
1825 set rowrangelist [lindex $v 3]
1827 set numcommits [llength $displayorder]
1828 catch {unset idrowranges}
1830 unflatten idrowranges [lindex $v 4]
1831 unflatten idinlist [lindex $v 5]
1832 set rowlaidout [lindex $v 6]
1833 set rowoptim [lindex $v 7]
1834 set numcommits [lindex $v 8]
1837 catch {unset colormap}
1838 catch {unset rowtextx}
1840 set canvxmax [$canv cget -width]
1847 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1848 set row $commitrow($n,$selid)
1849 # try to get the selected row in the same position on the screen
1850 set ymax [lindex [$canv cget -scrollregion] 3]
1851 set ytop [expr {[yc $row] - $yscreen}]
1855 set yf [expr {$ytop * 1.0 / $ymax}]
1857 allcanvs yview moveto $yf
1861 } elseif {$selid ne {}} {
1862 set pending_select $selid
1864 if {$numcommits > 0} {
1871 if {$phase eq "getcommits"} {
1872 show_status "Reading commits..."
1875 } elseif {$numcommits == 0} {
1876 show_status "No commits selected"
1880 # Stuff relating to the highlighting facility
1882 proc ishighlighted {row} {
1883 global vhighlights fhighlights nhighlights rhighlights
1885 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1886 return $nhighlights($row)
1888 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1889 return $vhighlights($row)
1891 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1892 return $fhighlights($row)
1894 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1895 return $rhighlights($row)
1900 proc bolden {row font} {
1901 global canv linehtag selectedline boldrows
1903 lappend boldrows $row
1904 $canv itemconf $linehtag($row) -font $font
1905 if {[info exists selectedline] && $row == $selectedline} {
1907 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1908 -outline {{}} -tags secsel \
1909 -fill [$canv cget -selectbackground]]
1914 proc bolden_name {row font} {
1915 global canv2 linentag selectedline boldnamerows
1917 lappend boldnamerows $row
1918 $canv2 itemconf $linentag($row) -font $font
1919 if {[info exists selectedline] && $row == $selectedline} {
1920 $canv2 delete secsel
1921 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1922 -outline {{}} -tags secsel \
1923 -fill [$canv2 cget -selectbackground]]
1929 global mainfont boldrows
1932 foreach row $boldrows {
1933 if {![ishighlighted $row]} {
1934 bolden $row $mainfont
1936 lappend stillbold $row
1939 set boldrows $stillbold
1942 proc addvhighlight {n} {
1943 global hlview curview viewdata vhl_done vhighlights commitidx
1945 if {[info exists hlview]} {
1949 if {$n != $curview && ![info exists viewdata($n)]} {
1950 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1951 set vparentlist($n) {}
1952 set vchildlist($n) {}
1953 set vdisporder($n) {}
1954 set vcmitlisted($n) {}
1957 set vhl_done $commitidx($hlview)
1958 if {$vhl_done > 0} {
1963 proc delvhighlight {} {
1964 global hlview vhighlights
1966 if {![info exists hlview]} return
1968 catch {unset vhighlights}
1972 proc vhighlightmore {} {
1973 global hlview vhl_done commitidx vhighlights
1974 global displayorder vdisporder curview mainfont
1976 set font [concat $mainfont bold]
1977 set max $commitidx($hlview)
1978 if {$hlview == $curview} {
1979 set disp $displayorder
1981 set disp $vdisporder($hlview)
1983 set vr [visiblerows]
1984 set r0 [lindex $vr 0]
1985 set r1 [lindex $vr 1]
1986 for {set i $vhl_done} {$i < $max} {incr i} {
1987 set id [lindex $disp $i]
1988 if {[info exists commitrow($curview,$id)]} {
1989 set row $commitrow($curview,$id)
1990 if {$r0 <= $row && $row <= $r1} {
1991 if {![highlighted $row]} {
1994 set vhighlights($row) 1
2001 proc askvhighlight {row id} {
2002 global hlview vhighlights commitrow iddrawn mainfont
2004 if {[info exists commitrow($hlview,$id)]} {
2005 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2006 bolden $row [concat $mainfont bold]
2008 set vhighlights($row) 1
2010 set vhighlights($row) 0
2014 proc hfiles_change {name ix op} {
2015 global highlight_files filehighlight fhighlights fh_serial
2016 global mainfont highlight_paths
2018 if {[info exists filehighlight]} {
2019 # delete previous highlights
2020 catch {close $filehighlight}
2022 catch {unset fhighlights}
2024 unhighlight_filelist
2026 set highlight_paths {}
2027 after cancel do_file_hl $fh_serial
2029 if {$highlight_files ne {}} {
2030 after 300 do_file_hl $fh_serial
2034 proc makepatterns {l} {
2037 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2038 if {[string index $ee end] eq "/"} {
2048 proc do_file_hl {serial} {
2049 global highlight_files filehighlight highlight_paths gdttype fhl_list
2051 if {$gdttype eq "touching paths:"} {
2052 if {[catch {set paths [shellsplit $highlight_files]}]} return
2053 set highlight_paths [makepatterns $paths]
2055 set gdtargs [concat -- $paths]
2057 set gdtargs [list "-S$highlight_files"]
2059 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2060 set filehighlight [open $cmd r+]
2061 fconfigure $filehighlight -blocking 0
2062 filerun $filehighlight readfhighlight
2068 proc flushhighlights {} {
2069 global filehighlight fhl_list
2071 if {[info exists filehighlight]} {
2073 puts $filehighlight ""
2074 flush $filehighlight
2078 proc askfilehighlight {row id} {
2079 global filehighlight fhighlights fhl_list
2081 lappend fhl_list $id
2082 set fhighlights($row) -1
2083 puts $filehighlight $id
2086 proc readfhighlight {} {
2087 global filehighlight fhighlights commitrow curview mainfont iddrawn
2090 if {![info exists filehighlight]} {
2094 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2095 set line [string trim $line]
2096 set i [lsearch -exact $fhl_list $line]
2097 if {$i < 0} continue
2098 for {set j 0} {$j < $i} {incr j} {
2099 set id [lindex $fhl_list $j]
2100 if {[info exists commitrow($curview,$id)]} {
2101 set fhighlights($commitrow($curview,$id)) 0
2104 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2105 if {$line eq {}} continue
2106 if {![info exists commitrow($curview,$line)]} continue
2107 set row $commitrow($curview,$line)
2108 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2109 bolden $row [concat $mainfont bold]
2111 set fhighlights($row) 1
2113 if {[eof $filehighlight]} {
2115 puts "oops, git diff-tree died"
2116 catch {close $filehighlight}
2124 proc find_change {name ix op} {
2125 global nhighlights mainfont boldnamerows
2126 global findstring findpattern findtype
2128 # delete previous highlights, if any
2129 foreach row $boldnamerows {
2130 bolden_name $row $mainfont
2133 catch {unset nhighlights}
2135 if {$findtype ne "Regexp"} {
2136 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2138 set findpattern "*$e*"
2143 proc askfindhighlight {row id} {
2144 global nhighlights commitinfo iddrawn mainfont
2145 global findstring findtype findloc findpattern
2147 if {![info exists commitinfo($id)]} {
2150 set info $commitinfo($id)
2152 set fldtypes {Headline Author Date Committer CDate Comments}
2153 foreach f $info ty $fldtypes {
2154 if {$findloc ne "All fields" && $findloc ne $ty} {
2157 if {$findtype eq "Regexp"} {
2158 set doesmatch [regexp $findstring $f]
2159 } elseif {$findtype eq "IgnCase"} {
2160 set doesmatch [string match -nocase $findpattern $f]
2162 set doesmatch [string match $findpattern $f]
2165 if {$ty eq "Author"} {
2172 if {[info exists iddrawn($id)]} {
2173 if {$isbold && ![ishighlighted $row]} {
2174 bolden $row [concat $mainfont bold]
2177 bolden_name $row [concat $mainfont bold]
2180 set nhighlights($row) $isbold
2183 proc vrel_change {name ix op} {
2184 global highlight_related
2187 if {$highlight_related ne "None"} {
2192 # prepare for testing whether commits are descendents or ancestors of a
2193 proc rhighlight_sel {a} {
2194 global descendent desc_todo ancestor anc_todo
2195 global highlight_related rhighlights
2197 catch {unset descendent}
2198 set desc_todo [list $a]
2199 catch {unset ancestor}
2200 set anc_todo [list $a]
2201 if {$highlight_related ne "None"} {
2207 proc rhighlight_none {} {
2210 catch {unset rhighlights}
2214 proc is_descendent {a} {
2215 global curview children commitrow descendent desc_todo
2218 set la $commitrow($v,$a)
2222 for {set i 0} {$i < [llength $todo]} {incr i} {
2223 set do [lindex $todo $i]
2224 if {$commitrow($v,$do) < $la} {
2225 lappend leftover $do
2228 foreach nk $children($v,$do) {
2229 if {![info exists descendent($nk)]} {
2230 set descendent($nk) 1
2238 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2242 set descendent($a) 0
2243 set desc_todo $leftover
2246 proc is_ancestor {a} {
2247 global curview parentlist commitrow ancestor anc_todo
2250 set la $commitrow($v,$a)
2254 for {set i 0} {$i < [llength $todo]} {incr i} {
2255 set do [lindex $todo $i]
2256 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2257 lappend leftover $do
2260 foreach np [lindex $parentlist $commitrow($v,$do)] {
2261 if {![info exists ancestor($np)]} {
2270 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2275 set anc_todo $leftover
2278 proc askrelhighlight {row id} {
2279 global descendent highlight_related iddrawn mainfont rhighlights
2280 global selectedline ancestor
2282 if {![info exists selectedline]} return
2284 if {$highlight_related eq "Descendent" ||
2285 $highlight_related eq "Not descendent"} {
2286 if {![info exists descendent($id)]} {
2289 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2292 } elseif {$highlight_related eq "Ancestor" ||
2293 $highlight_related eq "Not ancestor"} {
2294 if {![info exists ancestor($id)]} {
2297 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2301 if {[info exists iddrawn($id)]} {
2302 if {$isbold && ![ishighlighted $row]} {
2303 bolden $row [concat $mainfont bold]
2306 set rhighlights($row) $isbold
2309 proc next_hlcont {} {
2310 global fhl_row fhl_dirn displayorder numcommits
2311 global vhighlights fhighlights nhighlights rhighlights
2312 global hlview filehighlight findstring highlight_related
2314 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2317 if {$row < 0 || $row >= $numcommits} {
2322 set id [lindex $displayorder $row]
2323 if {[info exists hlview]} {
2324 if {![info exists vhighlights($row)]} {
2325 askvhighlight $row $id
2327 if {$vhighlights($row) > 0} break
2329 if {$findstring ne {}} {
2330 if {![info exists nhighlights($row)]} {
2331 askfindhighlight $row $id
2333 if {$nhighlights($row) > 0} break
2335 if {$highlight_related ne "None"} {
2336 if {![info exists rhighlights($row)]} {
2337 askrelhighlight $row $id
2339 if {$rhighlights($row) > 0} break
2341 if {[info exists filehighlight]} {
2342 if {![info exists fhighlights($row)]} {
2343 # ask for a few more while we're at it...
2345 for {set n 0} {$n < 100} {incr n} {
2346 if {![info exists fhighlights($r)]} {
2347 askfilehighlight $r [lindex $displayorder $r]
2350 if {$r < 0 || $r >= $numcommits} break
2354 if {$fhighlights($row) < 0} {
2358 if {$fhighlights($row) > 0} break
2366 proc next_highlight {dirn} {
2367 global selectedline fhl_row fhl_dirn
2368 global hlview filehighlight findstring highlight_related
2370 if {![info exists selectedline]} return
2371 if {!([info exists hlview] || $findstring ne {} ||
2372 $highlight_related ne "None" || [info exists filehighlight])} return
2373 set fhl_row [expr {$selectedline + $dirn}]
2378 proc cancel_next_highlight {} {
2384 # Graph layout functions
2386 proc shortids {ids} {
2389 if {[llength $id] > 1} {
2390 lappend res [shortids $id]
2391 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2392 lappend res [string range $id 0 7]
2400 proc incrange {l x o} {
2403 set e [lindex $l $x]
2405 lset l $x [expr {$e + $o}]
2414 for {} {$n > 0} {incr n -1} {
2420 proc usedinrange {id l1 l2} {
2421 global children commitrow childlist curview
2423 if {[info exists commitrow($curview,$id)]} {
2424 set r $commitrow($curview,$id)
2425 if {$l1 <= $r && $r <= $l2} {
2426 return [expr {$r - $l1 + 1}]
2428 set kids [lindex $childlist $r]
2430 set kids $children($curview,$id)
2433 set r $commitrow($curview,$c)
2434 if {$l1 <= $r && $r <= $l2} {
2435 return [expr {$r - $l1 + 1}]
2441 proc sanity {row {full 0}} {
2442 global rowidlist rowoffsets
2445 set ids [lindex $rowidlist $row]
2448 if {$id eq {}} continue
2449 if {$col < [llength $ids] - 1 &&
2450 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2451 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2453 set o [lindex $rowoffsets $row $col]
2459 if {[lindex $rowidlist $y $x] != $id} {
2460 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2461 puts " id=[shortids $id] check started at row $row"
2462 for {set i $row} {$i >= $y} {incr i -1} {
2463 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2468 set o [lindex $rowoffsets $y $x]
2473 proc makeuparrow {oid x y z} {
2474 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2476 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2479 set off0 [lindex $rowoffsets $y]
2480 for {set x0 $x} {1} {incr x0} {
2481 if {$x0 >= [llength $off0]} {
2482 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2485 set z [lindex $off0 $x0]
2491 set z [expr {$x0 - $x}]
2492 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2493 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2495 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2496 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2497 lappend idrowranges($oid) [lindex $displayorder $y]
2500 proc initlayout {} {
2501 global rowidlist rowoffsets displayorder commitlisted
2502 global rowlaidout rowoptim
2503 global idinlist rowchk rowrangelist idrowranges
2504 global numcommits canvxmax canv
2506 global parentlist childlist children
2507 global colormap rowtextx
2519 catch {unset idinlist}
2520 catch {unset rowchk}
2523 set canvxmax [$canv cget -width]
2524 catch {unset colormap}
2525 catch {unset rowtextx}
2526 catch {unset idrowranges}
2530 proc setcanvscroll {} {
2531 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2533 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2534 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2535 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2536 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2539 proc visiblerows {} {
2540 global canv numcommits linespc
2542 set ymax [lindex [$canv cget -scrollregion] 3]
2543 if {$ymax eq {} || $ymax == 0} return
2545 set y0 [expr {int([lindex $f 0] * $ymax)}]
2546 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2550 set y1 [expr {int([lindex $f 1] * $ymax)}]
2551 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2552 if {$r1 >= $numcommits} {
2553 set r1 [expr {$numcommits - 1}]
2555 return [list $r0 $r1]
2558 proc layoutmore {tmax allread} {
2559 global rowlaidout rowoptim commitidx numcommits optim_delay
2560 global uparrowlen curview rowidlist idinlist
2562 set showdelay $optim_delay
2563 set optdelay [expr {$uparrowlen + 1}]
2565 if {$rowoptim - $showdelay > $numcommits} {
2566 showstuff [expr {$rowoptim - $showdelay}]
2567 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2568 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2572 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2574 } elseif {$commitidx($curview) > $rowlaidout} {
2575 set nr [expr {$commitidx($curview) - $rowlaidout}]
2576 # may need to increase this threshold if uparrowlen or
2577 # mingaplen are increased...
2582 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2583 if {$rowlaidout == $row} {
2586 } elseif {$allread} {
2588 set nrows $commitidx($curview)
2589 if {[lindex $rowidlist $nrows] ne {} ||
2590 [array names idinlist] ne {}} {
2592 set rowlaidout $commitidx($curview)
2593 } elseif {$rowoptim == $nrows} {
2595 if {$numcommits == $nrows} {
2602 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2608 proc showstuff {canshow} {
2609 global numcommits commitrow pending_select selectedline curview
2610 global displayorder selectfirst
2612 if {$numcommits == 0} {
2614 set phase "incrdraw"
2618 set numcommits $canshow
2620 set rows [visiblerows]
2621 set r1 [lindex $rows 1]
2622 if {$r1 >= $canshow} {
2623 set r1 [expr {$canshow - 1}]
2628 if {[info exists pending_select] &&
2629 [info exists commitrow($curview,$pending_select)] &&
2630 $commitrow($curview,$pending_select) < $numcommits} {
2631 selectline $commitrow($curview,$pending_select) 1
2634 if {[info exists selectedline] || [info exists pending_select]} {
2643 proc layoutrows {row endrow last} {
2644 global rowidlist rowoffsets displayorder
2645 global uparrowlen downarrowlen maxwidth mingaplen
2646 global childlist parentlist
2648 global commitidx curview
2649 global idinlist rowchk rowrangelist
2651 set idlist [lindex $rowidlist $row]
2652 set offs [lindex $rowoffsets $row]
2653 while {$row < $endrow} {
2654 set id [lindex $displayorder $row]
2657 foreach p [lindex $parentlist $row] {
2658 if {![info exists idinlist($p)]} {
2660 } elseif {!$idinlist($p)} {
2664 set nev [expr {[llength $idlist] + [llength $newolds]
2665 + [llength $oldolds] - $maxwidth + 1}]
2668 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2669 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2670 set i [lindex $idlist $x]
2671 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2672 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2673 [expr {$row + $uparrowlen + $mingaplen}]]
2675 set idlist [lreplace $idlist $x $x]
2676 set offs [lreplace $offs $x $x]
2677 set offs [incrange $offs $x 1]
2679 set rm1 [expr {$row - 1}]
2680 lappend idrowranges($i) [lindex $displayorder $rm1]
2681 if {[incr nev -1] <= 0} break
2684 set rowchk($id) [expr {$row + $r}]
2687 lset rowidlist $row $idlist
2688 lset rowoffsets $row $offs
2690 set col [lsearch -exact $idlist $id]
2692 set col [llength $idlist]
2694 lset rowidlist $row $idlist
2696 if {[lindex $childlist $row] ne {}} {
2697 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2701 lset rowoffsets $row $offs
2703 makeuparrow $id $col $row $z
2709 if {[info exists idrowranges($id)]} {
2710 set ranges $idrowranges($id)
2712 unset idrowranges($id)
2714 lappend rowrangelist $ranges
2716 set offs [ntimes [llength $idlist] 0]
2717 set l [llength $newolds]
2718 set idlist [eval lreplace \$idlist $col $col $newolds]
2721 set offs [lrange $offs 0 [expr {$col - 1}]]
2722 foreach x $newolds {
2727 set tmp [expr {[llength $idlist] - [llength $offs]}]
2729 set offs [concat $offs [ntimes $tmp $o]]
2734 foreach i $newolds {
2736 set idrowranges($i) $id
2739 foreach oid $oldolds {
2740 set idinlist($oid) 1
2741 set idlist [linsert $idlist $col $oid]
2742 set offs [linsert $offs $col $o]
2743 makeuparrow $oid $col $row $o
2746 lappend rowidlist $idlist
2747 lappend rowoffsets $offs
2752 proc addextraid {id row} {
2753 global displayorder commitrow commitinfo
2754 global commitidx commitlisted
2755 global parentlist childlist children curview
2757 incr commitidx($curview)
2758 lappend displayorder $id
2759 lappend commitlisted 0
2760 lappend parentlist {}
2761 set commitrow($curview,$id) $row
2763 if {![info exists commitinfo($id)]} {
2764 set commitinfo($id) {"No commit information available"}
2766 if {![info exists children($curview,$id)]} {
2767 set children($curview,$id) {}
2769 lappend childlist $children($curview,$id)
2772 proc layouttail {} {
2773 global rowidlist rowoffsets idinlist commitidx curview
2774 global idrowranges rowrangelist
2776 set row $commitidx($curview)
2777 set idlist [lindex $rowidlist $row]
2778 while {$idlist ne {}} {
2779 set col [expr {[llength $idlist] - 1}]
2780 set id [lindex $idlist $col]
2783 lappend idrowranges($id) $row
2784 lappend rowrangelist $idrowranges($id)
2785 unset idrowranges($id)
2787 set offs [ntimes $col 0]
2788 set idlist [lreplace $idlist $col $col]
2789 lappend rowidlist $idlist
2790 lappend rowoffsets $offs
2793 foreach id [array names idinlist] {
2796 lset rowidlist $row [list $id]
2797 lset rowoffsets $row 0
2798 makeuparrow $id 0 $row 0
2799 lappend idrowranges($id) $row
2800 lappend rowrangelist $idrowranges($id)
2801 unset idrowranges($id)
2803 lappend rowidlist {}
2804 lappend rowoffsets {}
2808 proc insert_pad {row col npad} {
2809 global rowidlist rowoffsets
2811 set pad [ntimes $npad {}]
2812 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2813 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2814 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2817 proc optimize_rows {row col endrow} {
2818 global rowidlist rowoffsets idrowranges displayorder
2820 for {} {$row < $endrow} {incr row} {
2821 set idlist [lindex $rowidlist $row]
2822 set offs [lindex $rowoffsets $row]
2824 for {} {$col < [llength $offs]} {incr col} {
2825 if {[lindex $idlist $col] eq {}} {
2829 set z [lindex $offs $col]
2830 if {$z eq {}} continue
2832 set x0 [expr {$col + $z}]
2833 set y0 [expr {$row - 1}]
2834 set z0 [lindex $rowoffsets $y0 $x0]
2836 set id [lindex $idlist $col]
2837 set ranges [rowranges $id]
2838 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2842 # Looking at lines from this row to the previous row,
2843 # make them go straight up if they end in an arrow on
2844 # the previous row; otherwise make them go straight up
2846 if {$z < -1 || ($z < 0 && $isarrow)} {
2847 # Line currently goes left too much;
2848 # insert pads in the previous row, then optimize it
2849 set npad [expr {-1 - $z + $isarrow}]
2850 set offs [incrange $offs $col $npad]
2851 insert_pad $y0 $x0 $npad
2853 optimize_rows $y0 $x0 $row
2855 set z [lindex $offs $col]
2856 set x0 [expr {$col + $z}]
2857 set z0 [lindex $rowoffsets $y0 $x0]
2858 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2859 # Line currently goes right too much;
2860 # insert pads in this line and adjust the next's rowoffsets
2861 set npad [expr {$z - 1 + $isarrow}]
2862 set y1 [expr {$row + 1}]
2863 set offs2 [lindex $rowoffsets $y1]
2867 if {$z eq {} || $x1 + $z < $col} continue
2868 if {$x1 + $z > $col} {
2871 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2874 set pad [ntimes $npad {}]
2875 set idlist [eval linsert \$idlist $col $pad]
2876 set tmp [eval linsert \$offs $col $pad]
2878 set offs [incrange $tmp $col [expr {-$npad}]]
2879 set z [lindex $offs $col]
2882 if {$z0 eq {} && !$isarrow} {
2883 # this line links to its first child on row $row-2
2884 set rm2 [expr {$row - 2}]
2885 set id [lindex $displayorder $rm2]
2886 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2888 set z0 [expr {$xc - $x0}]
2891 # avoid lines jigging left then immediately right
2892 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2893 insert_pad $y0 $x0 1
2894 set offs [incrange $offs $col 1]
2895 optimize_rows $y0 [expr {$x0 + 1}] $row
2900 # Find the first column that doesn't have a line going right
2901 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
2902 set o [lindex $offs $col]
2904 # check if this is the link to the first child
2905 set id [lindex $idlist $col]
2906 set ranges [rowranges $id]
2907 if {$ranges ne {} && $row == [lindex $ranges 0]} {
2908 # it is, work out offset to child
2909 set y0 [expr {$row - 1}]
2910 set id [lindex $displayorder $y0]
2911 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
2913 set o [expr {$x0 - $col}]
2917 if {$o eq {} || $o <= 0} break
2919 # Insert a pad at that column as long as it has a line and
2920 # isn't the last column, and adjust the next row' offsets
2921 if {$o ne {} && [incr col] < [llength $idlist]} {
2922 set y1 [expr {$row + 1}]
2923 set offs2 [lindex $rowoffsets $y1]
2927 if {$z eq {} || $x1 + $z < $col} continue
2928 lset rowoffsets $y1 [incrange $offs2 $x1 1]
2931 set idlist [linsert $idlist $col {}]
2932 set tmp [linsert $offs $col {}]
2934 set offs [incrange $tmp $col -1]
2937 lset rowidlist $row $idlist
2938 lset rowoffsets $row $offs
2944 global canvx0 linespc
2945 return [expr {$canvx0 + $col * $linespc}]
2949 global canvy0 linespc
2950 return [expr {$canvy0 + $row * $linespc}]
2953 proc linewidth {id} {
2954 global thickerline lthickness
2957 if {[info exists thickerline] && $id eq $thickerline} {
2958 set wid [expr {2 * $lthickness}]
2963 proc rowranges {id} {
2964 global phase idrowranges commitrow rowlaidout rowrangelist curview
2968 ([info exists commitrow($curview,$id)]
2969 && $commitrow($curview,$id) < $rowlaidout)} {
2970 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
2971 } elseif {[info exists idrowranges($id)]} {
2972 set ranges $idrowranges($id)
2975 foreach rid $ranges {
2976 lappend linenos $commitrow($curview,$rid)
2978 if {$linenos ne {}} {
2979 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
2984 # work around tk8.4 refusal to draw arrows on diagonal segments
2985 proc adjarrowhigh {coords} {
2988 set x0 [lindex $coords 0]
2989 set x1 [lindex $coords 2]
2991 set y0 [lindex $coords 1]
2992 set y1 [lindex $coords 3]
2993 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
2994 # we have a nearby vertical segment, just trim off the diag bit
2995 set coords [lrange $coords 2 end]
2997 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
2998 set xi [expr {$x0 - $slope * $linespc / 2}]
2999 set yi [expr {$y0 - $linespc / 2}]
3000 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3006 proc drawlineseg {id row endrow arrowlow} {
3007 global rowidlist displayorder iddrawn linesegs
3008 global canv colormap linespc curview maxlinelen
3010 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3011 set le [expr {$row + 1}]
3014 set c [lsearch -exact [lindex $rowidlist $le] $id]
3020 set x [lindex $displayorder $le]
3025 if {[info exists iddrawn($x)] || $le == $endrow} {
3026 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3042 if {[info exists linesegs($id)]} {
3043 set lines $linesegs($id)
3045 set r0 [lindex $li 0]
3047 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3057 set li [lindex $lines [expr {$i-1}]]
3058 set r1 [lindex $li 1]
3059 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3064 set x [lindex $cols [expr {$le - $row}]]
3065 set xp [lindex $cols [expr {$le - 1 - $row}]]
3066 set dir [expr {$xp - $x}]
3068 set ith [lindex $lines $i 2]
3069 set coords [$canv coords $ith]
3070 set ah [$canv itemcget $ith -arrow]
3071 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3072 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3073 if {$x2 ne {} && $x - $x2 == $dir} {
3074 set coords [lrange $coords 0 end-2]
3077 set coords [list [xc $le $x] [yc $le]]
3080 set itl [lindex $lines [expr {$i-1}] 2]
3081 set al [$canv itemcget $itl -arrow]
3082 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3083 } elseif {$arrowlow &&
3084 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3087 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3088 for {set y $le} {[incr y -1] > $row} {} {
3090 set xp [lindex $cols [expr {$y - 1 - $row}]]
3091 set ndir [expr {$xp - $x}]
3092 if {$dir != $ndir || $xp < 0} {
3093 lappend coords [xc $y $x] [yc $y]
3099 # join parent line to first child
3100 set ch [lindex $displayorder $row]
3101 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3103 puts "oops: drawlineseg: child $ch not on row $row"
3106 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3107 } elseif {$xc > $x + 1} {
3108 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3112 lappend coords [xc $row $x] [yc $row]
3114 set xn [xc $row $xp]
3116 # work around tk8.4 refusal to draw arrows on diagonal segments
3117 if {$arrowlow && $xn != [lindex $coords end-1]} {
3118 if {[llength $coords] < 4 ||
3119 [lindex $coords end-3] != [lindex $coords end-1] ||
3120 [lindex $coords end] - $yn > 2 * $linespc} {
3121 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3122 set yo [yc [expr {$row + 0.5}]]
3123 lappend coords $xn $yo $xn $yn
3126 lappend coords $xn $yn
3131 set coords [adjarrowhigh $coords]
3134 set t [$canv create line $coords -width [linewidth $id] \
3135 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3138 set lines [linsert $lines $i [list $row $le $t]]
3140 $canv coords $ith $coords
3141 if {$arrow ne $ah} {
3142 $canv itemconf $ith -arrow $arrow
3144 lset lines $i 0 $row
3147 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3148 set ndir [expr {$xo - $xp}]
3149 set clow [$canv coords $itl]
3150 if {$dir == $ndir} {
3151 set clow [lrange $clow 2 end]
3153 set coords [concat $coords $clow]
3155 lset lines [expr {$i-1}] 1 $le
3157 set coords [adjarrowhigh $coords]
3160 # coalesce two pieces
3162 set b [lindex $lines [expr {$i-1}] 0]
3163 set e [lindex $lines $i 1]
3164 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3166 $canv coords $itl $coords
3167 if {$arrow ne $al} {
3168 $canv itemconf $itl -arrow $arrow
3172 set linesegs($id) $lines
3176 proc drawparentlinks {id row} {
3177 global rowidlist canv colormap curview parentlist
3180 set rowids [lindex $rowidlist $row]
3181 set col [lsearch -exact $rowids $id]
3182 if {$col < 0} return
3183 set olds [lindex $parentlist $row]
3184 set row2 [expr {$row + 1}]
3185 set x [xc $row $col]
3188 set ids [lindex $rowidlist $row2]
3189 # rmx = right-most X coord used
3192 set i [lsearch -exact $ids $p]
3194 puts "oops, parent $p of $id not in list"
3197 set x2 [xc $row2 $i]
3201 if {[lsearch -exact $rowids $p] < 0} {
3202 # drawlineseg will do this one for us
3206 # should handle duplicated parents here...
3207 set coords [list $x $y]
3208 if {$i < $col - 1} {
3209 lappend coords [xc $row [expr {$i + 1}]] $y
3210 } elseif {$i > $col + 1} {
3211 lappend coords [xc $row [expr {$i - 1}]] $y
3213 lappend coords $x2 $y2
3214 set t [$canv create line $coords -width [linewidth $p] \
3215 -fill $colormap($p) -tags lines.$p]
3219 if {$rmx > [lindex $idpos($id) 1]} {
3220 lset idpos($id) 1 $rmx
3225 proc drawlines {id} {
3228 $canv itemconf lines.$id -width [linewidth $id]
3231 proc drawcmittext {id row col} {
3232 global linespc canv canv2 canv3 canvy0 fgcolor
3233 global commitlisted commitinfo rowidlist parentlist
3234 global rowtextx idpos idtags idheads idotherrefs
3235 global linehtag linentag linedtag
3236 global mainfont canvxmax boldrows boldnamerows fgcolor
3238 set ofill [expr {[lindex $commitlisted $row]? "blue": "white"}]
3239 set x [xc $row $col]
3241 set orad [expr {$linespc / 3}]
3242 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3243 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3244 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3246 $canv bind $t <1> {selcanvline {} %x %y}
3247 set rmx [llength [lindex $rowidlist $row]]
3248 set olds [lindex $parentlist $row]
3250 set nextids [lindex $rowidlist [expr {$row + 1}]]
3252 set i [lsearch -exact $nextids $p]
3258 set xt [xc $row $rmx]
3259 set rowtextx($row) $xt
3260 set idpos($id) [list $x $xt $y]
3261 if {[info exists idtags($id)] || [info exists idheads($id)]
3262 || [info exists idotherrefs($id)]} {
3263 set xt [drawtags $id $x $xt $y]
3265 set headline [lindex $commitinfo($id) 0]
3266 set name [lindex $commitinfo($id) 1]
3267 set date [lindex $commitinfo($id) 2]
3268 set date [formatdate $date]
3271 set isbold [ishighlighted $row]
3273 lappend boldrows $row
3276 lappend boldnamerows $row
3280 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3281 -text $headline -font $font -tags text]
3282 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3283 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3284 -text $name -font $nfont -tags text]
3285 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3286 -text $date -font $mainfont -tags text]
3287 set xr [expr {$xt + [font measure $mainfont $headline]}]
3288 if {$xr > $canvxmax} {
3294 proc drawcmitrow {row} {
3295 global displayorder rowidlist
3297 global commitinfo parentlist numcommits
3298 global filehighlight fhighlights findstring nhighlights
3299 global hlview vhighlights
3300 global highlight_related rhighlights
3302 if {$row >= $numcommits} return
3304 set id [lindex $displayorder $row]
3305 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3306 askvhighlight $row $id
3308 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3309 askfilehighlight $row $id
3311 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3312 askfindhighlight $row $id
3314 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3315 askrelhighlight $row $id
3317 if {[info exists iddrawn($id)]} return
3318 set col [lsearch -exact [lindex $rowidlist $row] $id]
3320 puts "oops, row $row id $id not in list"
3323 if {![info exists commitinfo($id)]} {
3327 drawcmittext $id $row $col
3331 proc drawcommits {row {endrow {}}} {
3332 global numcommits iddrawn displayorder curview
3333 global parentlist rowidlist
3338 if {$endrow eq {}} {
3341 if {$endrow >= $numcommits} {
3342 set endrow [expr {$numcommits - 1}]
3345 # make the lines join to already-drawn rows either side
3346 set r [expr {$row - 1}]
3347 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3350 set er [expr {$endrow + 1}]
3351 if {$er >= $numcommits ||
3352 ![info exists iddrawn([lindex $displayorder $er])]} {
3355 for {} {$r <= $er} {incr r} {
3356 set id [lindex $displayorder $r]
3357 set wasdrawn [info exists iddrawn($id)]
3361 if {$r == $er} break
3362 set nextid [lindex $displayorder [expr {$r + 1}]]
3363 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3364 catch {unset prevlines}
3367 drawparentlinks $id $r
3369 if {[info exists lineends($r)]} {
3370 foreach lid $lineends($r) {
3371 unset prevlines($lid)
3374 set rowids [lindex $rowidlist $r]
3375 foreach lid $rowids {
3376 if {$lid eq {}} continue
3378 # see if this is the first child of any of its parents
3379 foreach p [lindex $parentlist $r] {
3380 if {[lsearch -exact $rowids $p] < 0} {
3381 # make this line extend up to the child
3382 set le [drawlineseg $p $r $er 0]
3383 lappend lineends($le) $p
3387 } elseif {![info exists prevlines($lid)]} {
3388 set le [drawlineseg $lid $r $er 1]
3389 lappend lineends($le) $lid
3390 set prevlines($lid) 1
3396 proc drawfrac {f0 f1} {
3399 set ymax [lindex [$canv cget -scrollregion] 3]
3400 if {$ymax eq {} || $ymax == 0} return
3401 set y0 [expr {int($f0 * $ymax)}]
3402 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3403 set y1 [expr {int($f1 * $ymax)}]
3404 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3405 drawcommits $row $endrow
3408 proc drawvisible {} {
3410 eval drawfrac [$canv yview]
3413 proc clear_display {} {
3414 global iddrawn linesegs
3415 global vhighlights fhighlights nhighlights rhighlights
3418 catch {unset iddrawn}
3419 catch {unset linesegs}
3420 catch {unset vhighlights}
3421 catch {unset fhighlights}
3422 catch {unset nhighlights}
3423 catch {unset rhighlights}
3426 proc findcrossings {id} {
3427 global rowidlist parentlist numcommits rowoffsets displayorder
3431 foreach {s e} [rowranges $id] {
3432 if {$e >= $numcommits} {
3433 set e [expr {$numcommits - 1}]
3435 if {$e <= $s} continue
3436 set x [lsearch -exact [lindex $rowidlist $e] $id]
3438 puts "findcrossings: oops, no [shortids $id] in row $e"
3441 for {set row $e} {[incr row -1] >= $s} {} {
3442 set olds [lindex $parentlist $row]
3443 set kid [lindex $displayorder $row]
3444 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3445 if {$kidx < 0} continue
3446 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3448 set px [lsearch -exact $nextrow $p]
3449 if {$px < 0} continue
3450 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3451 if {[lsearch -exact $ccross $p] >= 0} continue
3452 if {$x == $px + ($kidx < $px? -1: 1)} {
3454 } elseif {[lsearch -exact $cross $p] < 0} {
3459 set inc [lindex $rowoffsets $row $x]
3460 if {$inc eq {}} break
3464 return [concat $ccross {{}} $cross]
3467 proc assigncolor {id} {
3468 global colormap colors nextcolor
3469 global commitrow parentlist children children curview
3471 if {[info exists colormap($id)]} return
3472 set ncolors [llength $colors]
3473 if {[info exists children($curview,$id)]} {
3474 set kids $children($curview,$id)
3478 if {[llength $kids] == 1} {
3479 set child [lindex $kids 0]
3480 if {[info exists colormap($child)]
3481 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3482 set colormap($id) $colormap($child)
3488 foreach x [findcrossings $id] {
3490 # delimiter between corner crossings and other crossings
3491 if {[llength $badcolors] >= $ncolors - 1} break
3492 set origbad $badcolors
3494 if {[info exists colormap($x)]
3495 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3496 lappend badcolors $colormap($x)
3499 if {[llength $badcolors] >= $ncolors} {
3500 set badcolors $origbad
3502 set origbad $badcolors
3503 if {[llength $badcolors] < $ncolors - 1} {
3504 foreach child $kids {
3505 if {[info exists colormap($child)]
3506 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3507 lappend badcolors $colormap($child)
3509 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3510 if {[info exists colormap($p)]
3511 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3512 lappend badcolors $colormap($p)
3516 if {[llength $badcolors] >= $ncolors} {
3517 set badcolors $origbad
3520 for {set i 0} {$i <= $ncolors} {incr i} {
3521 set c [lindex $colors $nextcolor]
3522 if {[incr nextcolor] >= $ncolors} {
3525 if {[lsearch -exact $badcolors $c]} break
3527 set colormap($id) $c
3530 proc bindline {t id} {
3533 $canv bind $t <Enter> "lineenter %x %y $id"
3534 $canv bind $t <Motion> "linemotion %x %y $id"
3535 $canv bind $t <Leave> "lineleave $id"
3536 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3539 proc drawtags {id x xt y1} {
3540 global idtags idheads idotherrefs mainhead
3541 global linespc lthickness
3542 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3547 if {[info exists idtags($id)]} {
3548 set marks $idtags($id)
3549 set ntags [llength $marks]
3551 if {[info exists idheads($id)]} {
3552 set marks [concat $marks $idheads($id)]
3553 set nheads [llength $idheads($id)]
3555 if {[info exists idotherrefs($id)]} {
3556 set marks [concat $marks $idotherrefs($id)]
3562 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3563 set yt [expr {$y1 - 0.5 * $linespc}]
3564 set yb [expr {$yt + $linespc - 1}]
3568 foreach tag $marks {
3570 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3571 set wid [font measure [concat $mainfont bold] $tag]
3573 set wid [font measure $mainfont $tag]
3577 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3579 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3580 -width $lthickness -fill black -tags tag.$id]
3582 foreach tag $marks x $xvals wid $wvals {
3583 set xl [expr {$x + $delta}]
3584 set xr [expr {$x + $delta + $wid + $lthickness}]
3586 if {[incr ntags -1] >= 0} {
3588 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3589 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3590 -width 1 -outline black -fill yellow -tags tag.$id]
3591 $canv bind $t <1> [list showtag $tag 1]
3592 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3594 # draw a head or other ref
3595 if {[incr nheads -1] >= 0} {
3597 if {$tag eq $mainhead} {
3603 set xl [expr {$xl - $delta/2}]
3604 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3605 -width 1 -outline black -fill $col -tags tag.$id
3606 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3607 set rwid [font measure $mainfont $remoteprefix]
3608 set xi [expr {$x + 1}]
3609 set yti [expr {$yt + 1}]
3610 set xri [expr {$x + $rwid}]
3611 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3612 -width 0 -fill "#ffddaa" -tags tag.$id
3615 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3616 -font $font -tags [list tag.$id text]]
3618 $canv bind $t <1> [list showtag $tag 1]
3619 } elseif {$nheads >= 0} {
3620 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3626 proc xcoord {i level ln} {
3627 global canvx0 xspc1 xspc2
3629 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3630 if {$i > 0 && $i == $level} {
3631 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3632 } elseif {$i > $level} {
3633 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3638 proc show_status {msg} {
3639 global canv mainfont fgcolor
3642 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3643 -tags text -fill $fgcolor
3646 # Insert a new commit as the child of the commit on row $row.
3647 # The new commit will be displayed on row $row and the commits
3648 # on that row and below will move down one row.
3649 proc insertrow {row newcmit} {
3650 global displayorder parentlist childlist commitlisted
3651 global commitrow curview rowidlist rowoffsets numcommits
3652 global rowrangelist rowlaidout rowoptim numcommits
3655 if {$row >= $numcommits} {
3656 puts "oops, inserting new row $row but only have $numcommits rows"
3659 set p [lindex $displayorder $row]
3660 set displayorder [linsert $displayorder $row $newcmit]
3661 set parentlist [linsert $parentlist $row $p]
3662 set kids [lindex $childlist $row]
3663 lappend kids $newcmit
3664 lset childlist $row $kids
3665 set childlist [linsert $childlist $row {}]
3666 set commitlisted [linsert $commitlisted $row 1]
3667 set l [llength $displayorder]
3668 for {set r $row} {$r < $l} {incr r} {
3669 set id [lindex $displayorder $r]
3670 set commitrow($curview,$id) $r
3673 set idlist [lindex $rowidlist $row]
3674 set offs [lindex $rowoffsets $row]
3677 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3683 if {[llength $kids] == 1} {
3684 set col [lsearch -exact $idlist $p]
3685 lset idlist $col $newcmit
3687 set col [llength $idlist]
3688 lappend idlist $newcmit
3690 lset rowoffsets $row $offs
3692 set rowidlist [linsert $rowidlist $row $idlist]
3693 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3695 set rowrangelist [linsert $rowrangelist $row {}]
3696 if {[llength $kids] > 1} {
3697 set rp1 [expr {$row + 1}]
3698 set ranges [lindex $rowrangelist $rp1]
3699 if {$ranges eq {}} {
3700 set ranges [list $newcmit $p]
3701 } elseif {[lindex $ranges end-1] eq $p} {
3702 lset ranges end-1 $newcmit
3704 lset rowrangelist $rp1 $ranges
3711 if {[info exists selectedline] && $selectedline >= $row} {
3717 # Don't change the text pane cursor if it is currently the hand cursor,
3718 # showing that we are over a sha1 ID link.
3719 proc settextcursor {c} {
3720 global ctext curtextcursor
3722 if {[$ctext cget -cursor] == $curtextcursor} {
3723 $ctext config -cursor $c
3725 set curtextcursor $c
3728 proc nowbusy {what} {
3731 if {[array names isbusy] eq {}} {
3732 . config -cursor watch
3738 proc notbusy {what} {
3739 global isbusy maincursor textcursor
3741 catch {unset isbusy($what)}
3742 if {[array names isbusy] eq {}} {
3743 . config -cursor $maincursor
3744 settextcursor $textcursor
3748 proc findmatches {f} {
3749 global findtype foundstring foundstrlen
3750 if {$findtype == "Regexp"} {
3751 set matches [regexp -indices -all -inline $foundstring $f]
3753 if {$findtype == "IgnCase"} {
3754 set str [string tolower $f]
3760 while {[set j [string first $foundstring $str $i]] >= 0} {
3761 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
3762 set i [expr {$j + $foundstrlen}]
3769 global findtype findloc findstring markedmatches commitinfo
3770 global numcommits displayorder linehtag linentag linedtag
3771 global mainfont canv canv2 canv3 selectedline
3772 global matchinglines foundstring foundstrlen matchstring
3777 cancel_next_highlight
3779 set matchinglines {}
3780 if {$findtype == "IgnCase"} {
3781 set foundstring [string tolower $findstring]
3783 set foundstring $findstring
3785 set foundstrlen [string length $findstring]
3786 if {$foundstrlen == 0} return
3787 regsub -all {[*?\[\\]} $foundstring {\\&} matchstring
3788 set matchstring "*$matchstring*"
3789 if {![info exists selectedline]} {
3792 set oldsel $selectedline
3795 set fldtypes {Headline Author Date Committer CDate Comments}
3797 foreach id $displayorder {
3798 set d $commitdata($id)
3800 if {$findtype == "Regexp"} {
3801 set doesmatch [regexp $foundstring $d]
3802 } elseif {$findtype == "IgnCase"} {
3803 set doesmatch [string match -nocase $matchstring $d]
3805 set doesmatch [string match $matchstring $d]
3807 if {!$doesmatch} continue
3808 if {![info exists commitinfo($id)]} {
3811 set info $commitinfo($id)
3813 foreach f $info ty $fldtypes {
3814 if {$findloc != "All fields" && $findloc != $ty} {
3817 set matches [findmatches $f]
3818 if {$matches == {}} continue
3820 if {$ty == "Headline"} {
3822 markmatches $canv $l $f $linehtag($l) $matches $mainfont
3823 } elseif {$ty == "Author"} {
3825 markmatches $canv2 $l $f $linentag($l) $matches $mainfont
3826 } elseif {$ty == "Date"} {
3828 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
3832 lappend matchinglines $l
3833 if {!$didsel && $l > $oldsel} {
3839 if {$matchinglines == {}} {
3841 } elseif {!$didsel} {
3842 findselectline [lindex $matchinglines 0]
3846 proc findselectline {l} {
3847 global findloc commentend ctext
3849 if {$findloc == "All fields" || $findloc == "Comments"} {
3850 # highlight the matches in the comments
3851 set f [$ctext get 1.0 $commentend]
3852 set matches [findmatches $f]
3853 foreach match $matches {
3854 set start [lindex $match 0]
3855 set end [expr {[lindex $match 1] + 1}]
3856 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
3861 proc findnext {restart} {
3862 global matchinglines selectedline
3863 if {![info exists matchinglines]} {
3869 if {![info exists selectedline]} return
3870 foreach l $matchinglines {
3871 if {$l > $selectedline} {
3880 global matchinglines selectedline
3881 if {![info exists matchinglines]} {
3885 if {![info exists selectedline]} return
3887 foreach l $matchinglines {
3888 if {$l >= $selectedline} break
3892 findselectline $prev
3898 proc stopfindproc {{done 0}} {
3899 global findprocpid findprocfile findids
3900 global ctext findoldcursor phase maincursor textcursor
3901 global findinprogress
3903 catch {unset findids}
3904 if {[info exists findprocpid]} {
3906 catch {exec kill $findprocpid}
3908 catch {close $findprocfile}
3911 catch {unset findinprogress}
3915 # mark a commit as matching by putting a yellow background
3916 # behind the headline
3917 proc markheadline {l id} {
3918 global canv mainfont linehtag
3921 set bbox [$canv bbox $linehtag($l)]
3922 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
3926 # mark the bits of a headline, author or date that match a find string
3927 proc markmatches {canv l str tag matches font} {
3928 set bbox [$canv bbox $tag]
3929 set x0 [lindex $bbox 0]
3930 set y0 [lindex $bbox 1]
3931 set y1 [lindex $bbox 3]
3932 foreach match $matches {
3933 set start [lindex $match 0]
3934 set end [lindex $match 1]
3935 if {$start > $end} continue
3936 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
3937 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
3938 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
3939 [expr {$x0+$xlen+2}] $y1 \
3940 -outline {} -tags matches -fill yellow]
3945 proc unmarkmatches {} {
3946 global matchinglines findids
3947 allcanvs delete matches
3948 catch {unset matchinglines}
3949 catch {unset findids}
3952 proc selcanvline {w x y} {
3953 global canv canvy0 ctext linespc
3955 set ymax [lindex [$canv cget -scrollregion] 3]
3956 if {$ymax == {}} return
3957 set yfrac [lindex [$canv yview] 0]
3958 set y [expr {$y + $yfrac * $ymax}]
3959 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
3964 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
3970 proc commit_descriptor {p} {
3972 if {![info exists commitinfo($p)]} {
3976 if {[llength $commitinfo($p)] > 1} {
3977 set l [lindex $commitinfo($p) 0]
3982 # append some text to the ctext widget, and make any SHA1 ID
3983 # that we know about be a clickable link.
3984 proc appendwithlinks {text tags} {
3985 global ctext commitrow linknum curview
3987 set start [$ctext index "end - 1c"]
3988 $ctext insert end $text $tags
3989 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
3993 set linkid [string range $text $s $e]
3994 if {![info exists commitrow($curview,$linkid)]} continue
3996 $ctext tag add link "$start + $s c" "$start + $e c"
3997 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
3998 $ctext tag bind link$linknum <1> \
3999 [list selectline $commitrow($curview,$linkid) 1]
4002 $ctext tag conf link -foreground blue -underline 1
4003 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4004 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4007 proc viewnextline {dir} {
4011 set ymax [lindex [$canv cget -scrollregion] 3]
4012 set wnow [$canv yview]
4013 set wtop [expr {[lindex $wnow 0] * $ymax}]
4014 set newtop [expr {$wtop + $dir * $linespc}]
4017 } elseif {$newtop > $ymax} {
4020 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4023 # add a list of tag or branch names at position pos
4024 # returns the number of names inserted
4025 proc appendrefs {pos ids var} {
4026 global ctext commitrow linknum curview $var maxrefs
4028 if {[catch {$ctext index $pos}]} {
4031 $ctext conf -state normal
4032 $ctext delete $pos "$pos lineend"
4035 foreach tag [set $var\($id\)] {
4036 lappend tags [list $tag $id]
4039 if {[llength $tags] > $maxrefs} {
4040 $ctext insert $pos "many ([llength $tags])"
4042 set tags [lsort -index 0 -decreasing $tags]
4045 set id [lindex $ti 1]
4048 $ctext tag delete $lk
4049 $ctext insert $pos $sep
4050 $ctext insert $pos [lindex $ti 0] $lk
4051 if {[info exists commitrow($curview,$id)]} {
4052 $ctext tag conf $lk -foreground blue
4053 $ctext tag bind $lk <1> \
4054 [list selectline $commitrow($curview,$id) 1]
4055 $ctext tag conf $lk -underline 1
4056 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4057 $ctext tag bind $lk <Leave> \
4058 { %W configure -cursor $curtextcursor }
4063 $ctext conf -state disabled
4064 return [llength $tags]
4067 # called when we have finished computing the nearby tags
4068 proc dispneartags {delay} {
4069 global selectedline currentid showneartags tagphase
4071 if {![info exists selectedline] || !$showneartags} return
4072 after cancel dispnexttag
4074 after 200 dispnexttag
4077 after idle dispnexttag
4082 proc dispnexttag {} {
4083 global selectedline currentid showneartags tagphase ctext
4085 if {![info exists selectedline] || !$showneartags} return
4086 switch -- $tagphase {
4088 set dtags [desctags $currentid]
4090 appendrefs precedes $dtags idtags
4094 set atags [anctags $currentid]
4096 appendrefs follows $atags idtags
4100 set dheads [descheads $currentid]
4101 if {$dheads ne {}} {
4102 if {[appendrefs branch $dheads idheads] > 1
4103 && [$ctext get "branch -3c"] eq "h"} {
4104 # turn "Branch" into "Branches"
4105 $ctext conf -state normal
4106 $ctext insert "branch -2c" "es"
4107 $ctext conf -state disabled
4112 if {[incr tagphase] <= 2} {
4113 after idle dispnexttag
4117 proc selectline {l isnew} {
4118 global canv canv2 canv3 ctext commitinfo selectedline
4119 global displayorder linehtag linentag linedtag
4120 global canvy0 linespc parentlist childlist
4121 global currentid sha1entry
4122 global commentend idtags linknum
4123 global mergemax numcommits pending_select
4124 global cmitmode showneartags allcommits
4126 catch {unset pending_select}
4129 cancel_next_highlight
4130 if {$l < 0 || $l >= $numcommits} return
4131 set y [expr {$canvy0 + $l * $linespc}]
4132 set ymax [lindex [$canv cget -scrollregion] 3]
4133 set ytop [expr {$y - $linespc - 1}]
4134 set ybot [expr {$y + $linespc + 1}]
4135 set wnow [$canv yview]
4136 set wtop [expr {[lindex $wnow 0] * $ymax}]
4137 set wbot [expr {[lindex $wnow 1] * $ymax}]
4138 set wh [expr {$wbot - $wtop}]
4140 if {$ytop < $wtop} {
4141 if {$ybot < $wtop} {
4142 set newtop [expr {$y - $wh / 2.0}]
4145 if {$newtop > $wtop - $linespc} {
4146 set newtop [expr {$wtop - $linespc}]
4149 } elseif {$ybot > $wbot} {
4150 if {$ytop > $wbot} {
4151 set newtop [expr {$y - $wh / 2.0}]
4153 set newtop [expr {$ybot - $wh}]
4154 if {$newtop < $wtop + $linespc} {
4155 set newtop [expr {$wtop + $linespc}]
4159 if {$newtop != $wtop} {
4163 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4167 if {![info exists linehtag($l)]} return
4169 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4170 -tags secsel -fill [$canv cget -selectbackground]]
4172 $canv2 delete secsel
4173 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4174 -tags secsel -fill [$canv2 cget -selectbackground]]
4176 $canv3 delete secsel
4177 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4178 -tags secsel -fill [$canv3 cget -selectbackground]]
4182 addtohistory [list selectline $l 0]
4187 set id [lindex $displayorder $l]
4189 $sha1entry delete 0 end
4190 $sha1entry insert 0 $id
4191 $sha1entry selection from 0
4192 $sha1entry selection to end
4195 $ctext conf -state normal
4198 set info $commitinfo($id)
4199 set date [formatdate [lindex $info 2]]
4200 $ctext insert end "Author: [lindex $info 1] $date\n"
4201 set date [formatdate [lindex $info 4]]
4202 $ctext insert end "Committer: [lindex $info 3] $date\n"
4203 if {[info exists idtags($id)]} {
4204 $ctext insert end "Tags:"
4205 foreach tag $idtags($id) {
4206 $ctext insert end " $tag"
4208 $ctext insert end "\n"
4212 set olds [lindex $parentlist $l]
4213 if {[llength $olds] > 1} {
4216 if {$np >= $mergemax} {
4221 $ctext insert end "Parent: " $tag
4222 appendwithlinks [commit_descriptor $p] {}
4227 append headers "Parent: [commit_descriptor $p]"
4231 foreach c [lindex $childlist $l] {
4232 append headers "Child: [commit_descriptor $c]"
4235 # make anything that looks like a SHA1 ID be a clickable link
4236 appendwithlinks $headers {}
4237 if {$showneartags} {
4238 if {![info exists allcommits]} {
4241 $ctext insert end "Branch: "
4242 $ctext mark set branch "end -1c"
4243 $ctext mark gravity branch left
4244 $ctext insert end "\nFollows: "
4245 $ctext mark set follows "end -1c"
4246 $ctext mark gravity follows left
4247 $ctext insert end "\nPrecedes: "
4248 $ctext mark set precedes "end -1c"
4249 $ctext mark gravity precedes left
4250 $ctext insert end "\n"
4253 $ctext insert end "\n"
4254 set comment [lindex $info 5]
4255 if {[string first "\r" $comment] >= 0} {
4256 set comment [string map {"\r" "\n "} $comment]
4258 appendwithlinks $comment {comment}
4260 $ctext tag delete Comments
4261 $ctext tag remove found 1.0 end
4262 $ctext conf -state disabled
4263 set commentend [$ctext index "end - 1c"]
4265 init_flist "Comments"
4266 if {$cmitmode eq "tree"} {
4268 } elseif {[llength $olds] <= 1} {
4275 proc selfirstline {} {
4280 proc sellastline {} {
4283 set l [expr {$numcommits - 1}]
4287 proc selnextline {dir} {
4289 if {![info exists selectedline]} return
4290 set l [expr {$selectedline + $dir}]
4295 proc selnextpage {dir} {
4296 global canv linespc selectedline numcommits
4298 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4302 allcanvs yview scroll [expr {$dir * $lpp}] units
4304 if {![info exists selectedline]} return
4305 set l [expr {$selectedline + $dir * $lpp}]
4308 } elseif {$l >= $numcommits} {
4309 set l [expr $numcommits - 1]
4315 proc unselectline {} {
4316 global selectedline currentid
4318 catch {unset selectedline}
4319 catch {unset currentid}
4320 allcanvs delete secsel
4322 cancel_next_highlight
4325 proc reselectline {} {
4328 if {[info exists selectedline]} {
4329 selectline $selectedline 0
4333 proc addtohistory {cmd} {
4334 global history historyindex curview
4336 set elt [list $curview $cmd]
4337 if {$historyindex > 0
4338 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4342 if {$historyindex < [llength $history]} {
4343 set history [lreplace $history $historyindex end $elt]
4345 lappend history $elt
4348 if {$historyindex > 1} {
4349 .tf.bar.leftbut conf -state normal
4351 .tf.bar.leftbut conf -state disabled
4353 .tf.bar.rightbut conf -state disabled
4359 set view [lindex $elt 0]
4360 set cmd [lindex $elt 1]
4361 if {$curview != $view} {
4368 global history historyindex
4370 if {$historyindex > 1} {
4371 incr historyindex -1
4372 godo [lindex $history [expr {$historyindex - 1}]]
4373 .tf.bar.rightbut conf -state normal
4375 if {$historyindex <= 1} {
4376 .tf.bar.leftbut conf -state disabled
4381 global history historyindex
4383 if {$historyindex < [llength $history]} {
4384 set cmd [lindex $history $historyindex]
4387 .tf.bar.leftbut conf -state normal
4389 if {$historyindex >= [llength $history]} {
4390 .tf.bar.rightbut conf -state disabled
4395 global treefilelist treeidlist diffids diffmergeid treepending
4398 catch {unset diffmergeid}
4399 if {![info exists treefilelist($id)]} {
4400 if {![info exists treepending]} {
4401 if {[catch {set gtf [open [concat | git ls-tree -r $id] r]}]} {
4405 set treefilelist($id) {}
4406 set treeidlist($id) {}
4407 fconfigure $gtf -blocking 0
4408 filerun $gtf [list gettreeline $gtf $id]
4415 proc gettreeline {gtf id} {
4416 global treefilelist treeidlist treepending cmitmode diffids
4419 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4420 set tl [split $line "\t"]
4421 if {[lindex $tl 0 1] ne "blob"} continue
4422 set sha1 [lindex $tl 0 2]
4423 set fname [lindex $tl 1]
4424 if {[string index $fname 0] eq "\""} {
4425 set fname [lindex $fname 0]
4427 lappend treeidlist($id) $sha1
4428 lappend treefilelist($id) $fname
4431 return [expr {$nl >= 1000? 2: 1}]
4435 if {$cmitmode ne "tree"} {
4436 if {![info exists diffmergeid]} {
4437 gettreediffs $diffids
4439 } elseif {$id ne $diffids} {
4448 global treefilelist treeidlist diffids
4449 global ctext commentend
4451 set i [lsearch -exact $treefilelist($diffids) $f]
4453 puts "oops, $f not in list for id $diffids"
4456 set blob [lindex $treeidlist($diffids) $i]
4457 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4458 puts "oops, error reading blob $blob: $err"
4461 fconfigure $bf -blocking 0
4462 filerun $bf [list getblobline $bf $diffids]
4463 $ctext config -state normal
4464 clear_ctext $commentend
4465 $ctext insert end "\n"
4466 $ctext insert end "$f\n" filesep
4467 $ctext config -state disabled
4468 $ctext yview $commentend
4471 proc getblobline {bf id} {
4472 global diffids cmitmode ctext
4474 if {$id ne $diffids || $cmitmode ne "tree"} {
4478 $ctext config -state normal
4480 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4481 $ctext insert end "$line\n"
4484 # delete last newline
4485 $ctext delete "end - 2c" "end - 1c"
4489 $ctext config -state disabled
4490 return [expr {$nl >= 1000? 2: 1}]
4493 proc mergediff {id l} {
4494 global diffmergeid diffopts mdifffd
4500 # this doesn't seem to actually affect anything...
4501 set env(GIT_DIFF_OPTS) $diffopts
4502 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4503 if {[catch {set mdf [open $cmd r]} err]} {
4504 error_popup "Error getting merge diffs: $err"
4507 fconfigure $mdf -blocking 0
4508 set mdifffd($id) $mdf
4509 set np [llength [lindex $parentlist $l]]
4510 filerun $mdf [list getmergediffline $mdf $id $np]
4513 proc getmergediffline {mdf id np} {
4514 global diffmergeid ctext cflist mergemax
4515 global difffilestart mdifffd
4517 $ctext conf -state normal
4519 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4520 if {![info exists diffmergeid] || $id != $diffmergeid
4521 || $mdf != $mdifffd($id)} {
4525 if {[regexp {^diff --cc (.*)} $line match fname]} {
4526 # start of a new file
4527 $ctext insert end "\n"
4528 set here [$ctext index "end - 1c"]
4529 lappend difffilestart $here
4530 add_flist [list $fname]
4531 set l [expr {(78 - [string length $fname]) / 2}]
4532 set pad [string range "----------------------------------------" 1 $l]
4533 $ctext insert end "$pad $fname $pad\n" filesep
4534 } elseif {[regexp {^@@} $line]} {
4535 $ctext insert end "$line\n" hunksep
4536 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4539 # parse the prefix - one ' ', '-' or '+' for each parent
4544 for {set j 0} {$j < $np} {incr j} {
4545 set c [string range $line $j $j]
4548 } elseif {$c == "-"} {
4550 } elseif {$c == "+"} {
4559 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4560 # line doesn't appear in result, parents in $minuses have the line
4561 set num [lindex $minuses 0]
4562 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4563 # line appears in result, parents in $pluses don't have the line
4564 lappend tags mresult
4565 set num [lindex $spaces 0]
4568 if {$num >= $mergemax} {
4573 $ctext insert end "$line\n" $tags
4576 $ctext conf -state disabled
4581 return [expr {$nr >= 1000? 2: 1}]
4584 proc startdiff {ids} {
4585 global treediffs diffids treepending diffmergeid
4588 catch {unset diffmergeid}
4589 if {![info exists treediffs($ids)]} {
4590 if {![info exists treepending]} {
4598 proc addtocflist {ids} {
4599 global treediffs cflist
4600 add_flist $treediffs($ids)
4604 proc gettreediffs {ids} {
4605 global treediff treepending
4606 set treepending $ids
4609 {set gdtf [open [concat | git diff-tree --no-commit-id -r $ids] r]} \
4611 fconfigure $gdtf -blocking 0
4612 filerun $gdtf [list gettreediffline $gdtf $ids]
4615 proc gettreediffline {gdtf ids} {
4616 global treediff treediffs treepending diffids diffmergeid
4620 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4621 set file [lindex $line 5]
4622 lappend treediff $file
4625 return [expr {$nr >= 1000? 2: 1}]
4628 set treediffs($ids) $treediff
4630 if {$cmitmode eq "tree"} {
4632 } elseif {$ids != $diffids} {
4633 if {![info exists diffmergeid]} {
4634 gettreediffs $diffids
4642 proc getblobdiffs {ids} {
4643 global diffopts blobdifffd diffids env curdifftag curtagstart
4644 global diffinhdr treediffs
4646 set env(GIT_DIFF_OPTS) $diffopts
4647 set cmd [concat | git diff-tree --no-commit-id -r -p -C $ids]
4648 if {[catch {set bdf [open $cmd r]} err]} {
4649 puts "error getting diffs: $err"
4653 fconfigure $bdf -blocking 0
4654 set blobdifffd($ids) $bdf
4655 set curdifftag Comments
4657 filerun $bdf [list getblobdiffline $bdf $diffids]
4660 proc setinlist {var i val} {
4663 while {[llength [set $var]] < $i} {
4666 if {[llength [set $var]] == $i} {
4673 proc getblobdiffline {bdf ids} {
4674 global diffids blobdifffd ctext curdifftag curtagstart
4675 global diffnexthead diffnextnote difffilestart
4676 global diffinhdr treediffs
4679 $ctext conf -state normal
4680 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
4681 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4685 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
4686 # start of a new file
4687 $ctext insert end "\n"
4688 $ctext tag add $curdifftag $curtagstart end
4689 set here [$ctext index "end - 1c"]
4690 set curtagstart $here
4692 set i [lsearch -exact $treediffs($ids) $fname]
4694 setinlist difffilestart $i $here
4696 if {$newname ne $fname} {
4697 set i [lsearch -exact $treediffs($ids) $newname]
4699 setinlist difffilestart $i $here
4702 set curdifftag "f:$fname"
4703 $ctext tag delete $curdifftag
4704 set l [expr {(78 - [string length $header]) / 2}]
4705 set pad [string range "----------------------------------------" \
4707 $ctext insert end "$pad $header $pad\n" filesep
4709 } elseif {$diffinhdr && [string compare -length 3 $line "---"] == 0} {
4711 } elseif {$diffinhdr && [string compare -length 3 $line "+++"] == 0} {
4713 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
4714 $line match f1l f1c f2l f2c rest]} {
4715 $ctext insert end "$line\n" hunksep
4718 set x [string range $line 0 0]
4719 if {$x == "-" || $x == "+"} {
4720 set tag [expr {$x == "+"}]
4721 $ctext insert end "$line\n" d$tag
4722 } elseif {$x == " "} {
4723 $ctext insert end "$line\n"
4724 } elseif {$diffinhdr || $x == "\\"} {
4725 # e.g. "\ No newline at end of file"
4726 $ctext insert end "$line\n" filesep
4728 # Something else we don't recognize
4729 if {$curdifftag != "Comments"} {
4730 $ctext insert end "\n"
4731 $ctext tag add $curdifftag $curtagstart end
4732 set curtagstart [$ctext index "end - 1c"]
4733 set curdifftag Comments
4735 $ctext insert end "$line\n" filesep
4739 $ctext conf -state disabled
4742 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
4743 $ctext tag add $curdifftag $curtagstart end
4747 return [expr {$nr >= 1000? 2: 1}]
4750 proc changediffdisp {} {
4751 global ctext diffelide
4753 $ctext tag conf d0 -elide [lindex $diffelide 0]
4754 $ctext tag conf d1 -elide [lindex $diffelide 1]
4758 global difffilestart ctext
4759 set prev [lindex $difffilestart 0]
4760 set here [$ctext index @0,0]
4761 foreach loc $difffilestart {
4762 if {[$ctext compare $loc >= $here]} {
4772 global difffilestart ctext
4773 set here [$ctext index @0,0]
4774 foreach loc $difffilestart {
4775 if {[$ctext compare $loc > $here]} {
4782 proc clear_ctext {{first 1.0}} {
4783 global ctext smarktop smarkbot
4785 set l [lindex [split $first .] 0]
4786 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
4789 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
4792 $ctext delete $first end
4795 proc incrsearch {name ix op} {
4796 global ctext searchstring searchdirn
4798 $ctext tag remove found 1.0 end
4799 if {[catch {$ctext index anchor}]} {
4800 # no anchor set, use start of selection, or of visible area
4801 set sel [$ctext tag ranges sel]
4803 $ctext mark set anchor [lindex $sel 0]
4804 } elseif {$searchdirn eq "-forwards"} {
4805 $ctext mark set anchor @0,0
4807 $ctext mark set anchor @0,[winfo height $ctext]
4810 if {$searchstring ne {}} {
4811 set here [$ctext search $searchdirn -- $searchstring anchor]
4820 global sstring ctext searchstring searchdirn
4823 $sstring icursor end
4824 set searchdirn -forwards
4825 if {$searchstring ne {}} {
4826 set sel [$ctext tag ranges sel]
4828 set start "[lindex $sel 0] + 1c"
4829 } elseif {[catch {set start [$ctext index anchor]}]} {
4832 set match [$ctext search -count mlen -- $searchstring $start]
4833 $ctext tag remove sel 1.0 end
4839 set mend "$match + $mlen c"
4840 $ctext tag add sel $match $mend
4841 $ctext mark unset anchor
4845 proc dosearchback {} {
4846 global sstring ctext searchstring searchdirn
4849 $sstring icursor end
4850 set searchdirn -backwards
4851 if {$searchstring ne {}} {
4852 set sel [$ctext tag ranges sel]
4854 set start [lindex $sel 0]
4855 } elseif {[catch {set start [$ctext index anchor]}]} {
4856 set start @0,[winfo height $ctext]
4858 set match [$ctext search -backwards -count ml -- $searchstring $start]
4859 $ctext tag remove sel 1.0 end
4865 set mend "$match + $ml c"
4866 $ctext tag add sel $match $mend
4867 $ctext mark unset anchor
4871 proc searchmark {first last} {
4872 global ctext searchstring
4876 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
4877 if {$match eq {}} break
4878 set mend "$match + $mlen c"
4879 $ctext tag add found $match $mend
4883 proc searchmarkvisible {doall} {
4884 global ctext smarktop smarkbot
4886 set topline [lindex [split [$ctext index @0,0] .] 0]
4887 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
4888 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
4889 # no overlap with previous
4890 searchmark $topline $botline
4891 set smarktop $topline
4892 set smarkbot $botline
4894 if {$topline < $smarktop} {
4895 searchmark $topline [expr {$smarktop-1}]
4896 set smarktop $topline
4898 if {$botline > $smarkbot} {
4899 searchmark [expr {$smarkbot+1}] $botline
4900 set smarkbot $botline
4905 proc scrolltext {f0 f1} {
4908 .bleft.sb set $f0 $f1
4909 if {$searchstring ne {}} {
4915 global linespc charspc canvx0 canvy0 mainfont
4916 global xspc1 xspc2 lthickness
4918 set linespc [font metrics $mainfont -linespace]
4919 set charspc [font measure $mainfont "m"]
4920 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
4921 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
4922 set lthickness [expr {int($linespc / 9) + 1}]
4923 set xspc1(0) $linespc
4931 set ymax [lindex [$canv cget -scrollregion] 3]
4932 if {$ymax eq {} || $ymax == 0} return
4933 set span [$canv yview]
4936 allcanvs yview moveto [lindex $span 0]
4938 if {[info exists selectedline]} {
4939 selectline $selectedline 0
4940 allcanvs yview moveto [lindex $span 0]
4944 proc incrfont {inc} {
4945 global mainfont textfont ctext canv phase cflist
4946 global charspc tabstop
4947 global stopped entries
4949 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
4950 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
4952 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
4953 $cflist conf -font $textfont
4954 $ctext tag conf filesep -font [concat $textfont bold]
4955 foreach e $entries {
4956 $e conf -font $mainfont
4958 if {$phase eq "getcommits"} {
4959 $canv itemconf textitems -font $mainfont
4965 global sha1entry sha1string
4966 if {[string length $sha1string] == 40} {
4967 $sha1entry delete 0 end
4971 proc sha1change {n1 n2 op} {
4972 global sha1string currentid sha1but
4973 if {$sha1string == {}
4974 || ([info exists currentid] && $sha1string == $currentid)} {
4979 if {[$sha1but cget -state] == $state} return
4980 if {$state == "normal"} {
4981 $sha1but conf -state normal -relief raised -text "Goto: "
4983 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
4987 proc gotocommit {} {
4988 global sha1string currentid commitrow tagids headids
4989 global displayorder numcommits curview
4991 if {$sha1string == {}
4992 || ([info exists currentid] && $sha1string == $currentid)} return
4993 if {[info exists tagids($sha1string)]} {
4994 set id $tagids($sha1string)
4995 } elseif {[info exists headids($sha1string)]} {
4996 set id $headids($sha1string)
4998 set id [string tolower $sha1string]
4999 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5001 foreach i $displayorder {
5002 if {[string match $id* $i]} {
5006 if {$matches ne {}} {
5007 if {[llength $matches] > 1} {
5008 error_popup "Short SHA1 id $id is ambiguous"
5011 set id [lindex $matches 0]
5015 if {[info exists commitrow($curview,$id)]} {
5016 selectline $commitrow($curview,$id) 1
5019 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5024 error_popup "$type $sha1string is not known"
5027 proc lineenter {x y id} {
5028 global hoverx hovery hoverid hovertimer
5029 global commitinfo canv
5031 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5035 if {[info exists hovertimer]} {
5036 after cancel $hovertimer
5038 set hovertimer [after 500 linehover]
5042 proc linemotion {x y id} {
5043 global hoverx hovery hoverid hovertimer
5045 if {[info exists hoverid] && $id == $hoverid} {
5048 if {[info exists hovertimer]} {
5049 after cancel $hovertimer
5051 set hovertimer [after 500 linehover]
5055 proc lineleave {id} {
5056 global hoverid hovertimer canv
5058 if {[info exists hoverid] && $id == $hoverid} {
5060 if {[info exists hovertimer]} {
5061 after cancel $hovertimer
5069 global hoverx hovery hoverid hovertimer
5070 global canv linespc lthickness
5071 global commitinfo mainfont
5073 set text [lindex $commitinfo($hoverid) 0]
5074 set ymax [lindex [$canv cget -scrollregion] 3]
5075 if {$ymax == {}} return
5076 set yfrac [lindex [$canv yview] 0]
5077 set x [expr {$hoverx + 2 * $linespc}]
5078 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5079 set x0 [expr {$x - 2 * $lthickness}]
5080 set y0 [expr {$y - 2 * $lthickness}]
5081 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5082 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5083 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5084 -fill \#ffff80 -outline black -width 1 -tags hover]
5086 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5091 proc clickisonarrow {id y} {
5094 set ranges [rowranges $id]
5095 set thresh [expr {2 * $lthickness + 6}]
5096 set n [expr {[llength $ranges] - 1}]
5097 for {set i 1} {$i < $n} {incr i} {
5098 set row [lindex $ranges $i]
5099 if {abs([yc $row] - $y) < $thresh} {
5106 proc arrowjump {id n y} {
5109 # 1 <-> 2, 3 <-> 4, etc...
5110 set n [expr {(($n - 1) ^ 1) + 1}]
5111 set row [lindex [rowranges $id] $n]
5113 set ymax [lindex [$canv cget -scrollregion] 3]
5114 if {$ymax eq {} || $ymax <= 0} return
5115 set view [$canv yview]
5116 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5117 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5121 allcanvs yview moveto $yfrac
5124 proc lineclick {x y id isnew} {
5125 global ctext commitinfo children canv thickerline curview
5127 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5132 # draw this line thicker than normal
5136 set ymax [lindex [$canv cget -scrollregion] 3]
5137 if {$ymax eq {}} return
5138 set yfrac [lindex [$canv yview] 0]
5139 set y [expr {$y + $yfrac * $ymax}]
5141 set dirn [clickisonarrow $id $y]
5143 arrowjump $id $dirn $y
5148 addtohistory [list lineclick $x $y $id 0]
5150 # fill the details pane with info about this line
5151 $ctext conf -state normal
5153 $ctext tag conf link -foreground blue -underline 1
5154 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5155 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5156 $ctext insert end "Parent:\t"
5157 $ctext insert end $id [list link link0]
5158 $ctext tag bind link0 <1> [list selbyid $id]
5159 set info $commitinfo($id)
5160 $ctext insert end "\n\t[lindex $info 0]\n"
5161 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5162 set date [formatdate [lindex $info 2]]
5163 $ctext insert end "\tDate:\t$date\n"
5164 set kids $children($curview,$id)
5166 $ctext insert end "\nChildren:"
5168 foreach child $kids {
5170 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5171 set info $commitinfo($child)
5172 $ctext insert end "\n\t"
5173 $ctext insert end $child [list link link$i]
5174 $ctext tag bind link$i <1> [list selbyid $child]
5175 $ctext insert end "\n\t[lindex $info 0]"
5176 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5177 set date [formatdate [lindex $info 2]]
5178 $ctext insert end "\n\tDate:\t$date\n"
5181 $ctext conf -state disabled
5185 proc normalline {} {
5187 if {[info exists thickerline]} {
5195 global commitrow curview
5196 if {[info exists commitrow($curview,$id)]} {
5197 selectline $commitrow($curview,$id) 1
5203 if {![info exists startmstime]} {
5204 set startmstime [clock clicks -milliseconds]
5206 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5209 proc rowmenu {x y id} {
5210 global rowctxmenu commitrow selectedline rowmenuid curview
5212 if {![info exists selectedline]
5213 || $commitrow($curview,$id) eq $selectedline} {
5218 $rowctxmenu entryconfigure "Diff this*" -state $state
5219 $rowctxmenu entryconfigure "Diff selected*" -state $state
5220 $rowctxmenu entryconfigure "Make patch" -state $state
5222 tk_popup $rowctxmenu $x $y
5225 proc diffvssel {dirn} {
5226 global rowmenuid selectedline displayorder
5228 if {![info exists selectedline]} return
5230 set oldid [lindex $displayorder $selectedline]
5231 set newid $rowmenuid
5233 set oldid $rowmenuid
5234 set newid [lindex $displayorder $selectedline]
5236 addtohistory [list doseldiff $oldid $newid]
5237 doseldiff $oldid $newid
5240 proc doseldiff {oldid newid} {
5244 $ctext conf -state normal
5247 $ctext insert end "From "
5248 $ctext tag conf link -foreground blue -underline 1
5249 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5250 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5251 $ctext tag bind link0 <1> [list selbyid $oldid]
5252 $ctext insert end $oldid [list link link0]
5253 $ctext insert end "\n "
5254 $ctext insert end [lindex $commitinfo($oldid) 0]
5255 $ctext insert end "\n\nTo "
5256 $ctext tag bind link1 <1> [list selbyid $newid]
5257 $ctext insert end $newid [list link link1]
5258 $ctext insert end "\n "
5259 $ctext insert end [lindex $commitinfo($newid) 0]
5260 $ctext insert end "\n"
5261 $ctext conf -state disabled
5262 $ctext tag delete Comments
5263 $ctext tag remove found 1.0 end
5264 startdiff [list $oldid $newid]
5268 global rowmenuid currentid commitinfo patchtop patchnum
5270 if {![info exists currentid]} return
5271 set oldid $currentid
5272 set oldhead [lindex $commitinfo($oldid) 0]
5273 set newid $rowmenuid
5274 set newhead [lindex $commitinfo($newid) 0]
5277 catch {destroy $top}
5279 label $top.title -text "Generate patch"
5280 grid $top.title - -pady 10
5281 label $top.from -text "From:"
5282 entry $top.fromsha1 -width 40 -relief flat
5283 $top.fromsha1 insert 0 $oldid
5284 $top.fromsha1 conf -state readonly
5285 grid $top.from $top.fromsha1 -sticky w
5286 entry $top.fromhead -width 60 -relief flat
5287 $top.fromhead insert 0 $oldhead
5288 $top.fromhead conf -state readonly
5289 grid x $top.fromhead -sticky w
5290 label $top.to -text "To:"
5291 entry $top.tosha1 -width 40 -relief flat
5292 $top.tosha1 insert 0 $newid
5293 $top.tosha1 conf -state readonly
5294 grid $top.to $top.tosha1 -sticky w
5295 entry $top.tohead -width 60 -relief flat
5296 $top.tohead insert 0 $newhead
5297 $top.tohead conf -state readonly
5298 grid x $top.tohead -sticky w
5299 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5300 grid $top.rev x -pady 10
5301 label $top.flab -text "Output file:"
5302 entry $top.fname -width 60
5303 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5305 grid $top.flab $top.fname -sticky w
5307 button $top.buts.gen -text "Generate" -command mkpatchgo
5308 button $top.buts.can -text "Cancel" -command mkpatchcan
5309 grid $top.buts.gen $top.buts.can
5310 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5311 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5312 grid $top.buts - -pady 10 -sticky ew
5316 proc mkpatchrev {} {
5319 set oldid [$patchtop.fromsha1 get]
5320 set oldhead [$patchtop.fromhead get]
5321 set newid [$patchtop.tosha1 get]
5322 set newhead [$patchtop.tohead get]
5323 foreach e [list fromsha1 fromhead tosha1 tohead] \
5324 v [list $newid $newhead $oldid $oldhead] {
5325 $patchtop.$e conf -state normal
5326 $patchtop.$e delete 0 end
5327 $patchtop.$e insert 0 $v
5328 $patchtop.$e conf -state readonly
5335 set oldid [$patchtop.fromsha1 get]
5336 set newid [$patchtop.tosha1 get]
5337 set fname [$patchtop.fname get]
5338 if {[catch {exec git diff-tree -p $oldid $newid >$fname &} err]} {
5339 error_popup "Error creating patch: $err"
5341 catch {destroy $patchtop}
5345 proc mkpatchcan {} {
5348 catch {destroy $patchtop}
5353 global rowmenuid mktagtop commitinfo
5357 catch {destroy $top}
5359 label $top.title -text "Create tag"
5360 grid $top.title - -pady 10
5361 label $top.id -text "ID:"
5362 entry $top.sha1 -width 40 -relief flat
5363 $top.sha1 insert 0 $rowmenuid
5364 $top.sha1 conf -state readonly
5365 grid $top.id $top.sha1 -sticky w
5366 entry $top.head -width 60 -relief flat
5367 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5368 $top.head conf -state readonly
5369 grid x $top.head -sticky w
5370 label $top.tlab -text "Tag name:"
5371 entry $top.tag -width 60
5372 grid $top.tlab $top.tag -sticky w
5374 button $top.buts.gen -text "Create" -command mktaggo
5375 button $top.buts.can -text "Cancel" -command mktagcan
5376 grid $top.buts.gen $top.buts.can
5377 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5378 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5379 grid $top.buts - -pady 10 -sticky ew
5384 global mktagtop env tagids idtags
5386 set id [$mktagtop.sha1 get]
5387 set tag [$mktagtop.tag get]
5389 error_popup "No tag name specified"
5392 if {[info exists tagids($tag)]} {
5393 error_popup "Tag \"$tag\" already exists"
5398 set fname [file join $dir "refs/tags" $tag]
5399 set f [open $fname w]
5403 error_popup "Error creating tag: $err"
5407 set tagids($tag) $id
5408 lappend idtags($id) $tag
5413 proc redrawtags {id} {
5414 global canv linehtag commitrow idpos selectedline curview
5415 global mainfont canvxmax iddrawn
5417 if {![info exists commitrow($curview,$id)]} return
5418 if {![info exists iddrawn($id)]} return
5419 drawcommits $commitrow($curview,$id)
5420 $canv delete tag.$id
5421 set xt [eval drawtags $id $idpos($id)]
5422 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5423 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5424 set xr [expr {$xt + [font measure $mainfont $text]}]
5425 if {$xr > $canvxmax} {
5429 if {[info exists selectedline]
5430 && $selectedline == $commitrow($curview,$id)} {
5431 selectline $selectedline 0
5438 catch {destroy $mktagtop}
5447 proc writecommit {} {
5448 global rowmenuid wrcomtop commitinfo wrcomcmd
5450 set top .writecommit
5452 catch {destroy $top}
5454 label $top.title -text "Write commit to file"
5455 grid $top.title - -pady 10
5456 label $top.id -text "ID:"
5457 entry $top.sha1 -width 40 -relief flat
5458 $top.sha1 insert 0 $rowmenuid
5459 $top.sha1 conf -state readonly
5460 grid $top.id $top.sha1 -sticky w
5461 entry $top.head -width 60 -relief flat
5462 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5463 $top.head conf -state readonly
5464 grid x $top.head -sticky w
5465 label $top.clab -text "Command:"
5466 entry $top.cmd -width 60 -textvariable wrcomcmd
5467 grid $top.clab $top.cmd -sticky w -pady 10
5468 label $top.flab -text "Output file:"
5469 entry $top.fname -width 60
5470 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5471 grid $top.flab $top.fname -sticky w
5473 button $top.buts.gen -text "Write" -command wrcomgo
5474 button $top.buts.can -text "Cancel" -command wrcomcan
5475 grid $top.buts.gen $top.buts.can
5476 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5477 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5478 grid $top.buts - -pady 10 -sticky ew
5485 set id [$wrcomtop.sha1 get]
5486 set cmd "echo $id | [$wrcomtop.cmd get]"
5487 set fname [$wrcomtop.fname get]
5488 if {[catch {exec sh -c $cmd >$fname &} err]} {
5489 error_popup "Error writing commit: $err"
5491 catch {destroy $wrcomtop}
5498 catch {destroy $wrcomtop}
5503 global rowmenuid mkbrtop
5506 catch {destroy $top}
5508 label $top.title -text "Create new branch"
5509 grid $top.title - -pady 10
5510 label $top.id -text "ID:"
5511 entry $top.sha1 -width 40 -relief flat
5512 $top.sha1 insert 0 $rowmenuid
5513 $top.sha1 conf -state readonly
5514 grid $top.id $top.sha1 -sticky w
5515 label $top.nlab -text "Name:"
5516 entry $top.name -width 40
5517 grid $top.nlab $top.name -sticky w
5519 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5520 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5521 grid $top.buts.go $top.buts.can
5522 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5523 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5524 grid $top.buts - -pady 10 -sticky ew
5529 global headids idheads
5531 set name [$top.name get]
5532 set id [$top.sha1 get]
5534 error_popup "Please specify a name for the new branch"
5537 catch {destroy $top}
5541 exec git branch $name $id
5546 set headids($name) $id
5547 lappend idheads($id) $name
5555 proc cherrypick {} {
5556 global rowmenuid curview commitrow
5559 set oldhead [exec git rev-parse HEAD]
5560 set dheads [descheads $rowmenuid]
5561 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5562 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5563 included in branch $mainhead -- really re-apply it?"]
5568 # Unfortunately git-cherry-pick writes stuff to stderr even when
5569 # no error occurs, and exec takes that as an indication of error...
5570 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5575 set newhead [exec git rev-parse HEAD]
5576 if {$newhead eq $oldhead} {
5578 error_popup "No changes committed"
5581 addnewchild $newhead $oldhead
5582 if {[info exists commitrow($curview,$oldhead)]} {
5583 insertrow $commitrow($curview,$oldhead) $newhead
5584 if {$mainhead ne {}} {
5585 movehead $newhead $mainhead
5586 movedhead $newhead $mainhead
5594 # context menu for a head
5595 proc headmenu {x y id head} {
5596 global headmenuid headmenuhead headctxmenu mainhead
5599 set headmenuhead $head
5601 if {$head eq $mainhead} {
5604 $headctxmenu entryconfigure 0 -state $state
5605 $headctxmenu entryconfigure 1 -state $state
5606 tk_popup $headctxmenu $x $y
5610 global headmenuid headmenuhead mainhead headids
5612 # check the tree is clean first??
5613 set oldmainhead $mainhead
5617 exec git checkout -q $headmenuhead
5623 set mainhead $headmenuhead
5624 if {[info exists headids($oldmainhead)]} {
5625 redrawtags $headids($oldmainhead)
5627 redrawtags $headmenuid
5632 global headmenuid headmenuhead mainhead
5633 global headids idheads
5635 set head $headmenuhead
5637 # this check shouldn't be needed any more...
5638 if {$head eq $mainhead} {
5639 error_popup "Cannot delete the currently checked-out branch"
5642 set dheads [descheads $id]
5643 if {$dheads eq $headids($head)} {
5644 # the stuff on this branch isn't on any other branch
5645 if {![confirm_popup "The commits on branch $head aren't on any other\
5646 branch.\nReally delete branch $head?"]} return
5650 if {[catch {exec git branch -D $head} err]} {
5655 removehead $id $head
5656 removedhead $id $head
5662 # Stuff for finding nearby tags
5663 proc getallcommits {} {
5664 global allcommits allids nbmp nextarc seeds
5674 # Called when the graph might have changed
5675 proc regetallcommits {} {
5676 global allcommits seeds
5678 set cmd [concat | git rev-list --all --parents]
5682 set fd [open $cmd r]
5683 fconfigure $fd -blocking 0
5686 filerun $fd [list getallclines $fd]
5689 # Since most commits have 1 parent and 1 child, we group strings of
5690 # such commits into "arcs" joining branch/merge points (BMPs), which
5691 # are commits that either don't have 1 parent or don't have 1 child.
5693 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
5694 # arcout(id) - outgoing arcs for BMP
5695 # arcids(a) - list of IDs on arc including end but not start
5696 # arcstart(a) - BMP ID at start of arc
5697 # arcend(a) - BMP ID at end of arc
5698 # growing(a) - arc a is still growing
5699 # arctags(a) - IDs out of arcids (excluding end) that have tags
5700 # archeads(a) - IDs out of arcids (excluding end) that have heads
5701 # The start of an arc is at the descendent end, so "incoming" means
5702 # coming from descendents, and "outgoing" means going towards ancestors.
5704 proc getallclines {fd} {
5705 global allids allparents allchildren idtags nextarc nbmp
5706 global arcnos arcids arctags arcout arcend arcstart archeads growing
5707 global seeds allcommits
5710 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
5711 set id [lindex $line 0]
5712 if {[info exists allparents($id)]} {
5717 set olds [lrange $line 1 end]
5718 set allparents($id) $olds
5719 if {![info exists allchildren($id)]} {
5720 set allchildren($id) {}
5725 if {[llength $olds] == 1 && [llength $a] == 1} {
5726 lappend arcids($a) $id
5727 if {[info exists idtags($id)]} {
5728 lappend arctags($a) $id
5730 if {[info exists idheads($id)]} {
5731 lappend archeads($a) $id
5733 if {[info exists allparents($olds)]} {
5734 # seen parent already
5735 if {![info exists arcout($olds)]} {
5738 lappend arcids($a) $olds
5739 set arcend($a) $olds
5742 lappend allchildren($olds) $id
5743 lappend arcnos($olds) $a
5748 foreach a $arcnos($id) {
5749 lappend arcids($a) $id
5756 lappend allchildren($p) $id
5757 set a [incr nextarc]
5758 set arcstart($a) $id
5765 if {[info exists allparents($p)]} {
5766 # seen it already, may need to make a new branch
5767 if {![info exists arcout($p)]} {
5770 lappend arcids($a) $p
5774 lappend arcnos($p) $a
5779 return [expr {$nid >= 1000? 2: 1}]
5782 if {[incr allcommits -1] == 0} {
5789 proc recalcarc {a} {
5790 global arctags archeads arcids idtags idheads
5794 foreach id [lrange $arcids($a) 0 end-1] {
5795 if {[info exists idtags($id)]} {
5798 if {[info exists idheads($id)]} {
5803 set archeads($a) $ah
5807 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
5808 global arcstart arcend arcout allparents growing
5811 if {[llength $a] != 1} {
5812 puts "oops splitarc called but [llength $a] arcs already"
5816 set i [lsearch -exact $arcids($a) $p]
5818 puts "oops splitarc $p not in arc $a"
5821 set na [incr nextarc]
5822 if {[info exists arcend($a)]} {
5823 set arcend($na) $arcend($a)
5825 set l [lindex $allparents([lindex $arcids($a) end]) 0]
5826 set j [lsearch -exact $arcnos($l) $a]
5827 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
5829 set tail [lrange $arcids($a) [expr {$i+1}] end]
5830 set arcids($a) [lrange $arcids($a) 0 $i]
5832 set arcstart($na) $p
5834 set arcids($na) $tail
5835 if {[info exists growing($a)]} {
5842 if {[llength $arcnos($id)] == 1} {
5845 set j [lsearch -exact $arcnos($id) $a]
5846 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
5850 # reconstruct tags and heads lists
5851 if {$arctags($a) ne {} || $archeads($a) ne {}} {
5856 set archeads($na) {}
5860 # Update things for a new commit added that is a child of one
5861 # existing commit. Used when cherry-picking.
5862 proc addnewchild {id p} {
5863 global allids allparents allchildren idtags nextarc nbmp
5864 global arcnos arcids arctags arcout arcend arcstart archeads growing
5868 set allparents($id) [list $p]
5869 set allchildren($id) {}
5873 lappend allchildren($p) $id
5874 set a [incr nextarc]
5875 set arcstart($a) $id
5878 set arcids($a) [list $p]
5880 if {![info exists arcout($p)]} {
5883 lappend arcnos($p) $a
5884 set arcout($id) [list $a]
5887 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
5888 # or 0 if neither is true.
5889 proc anc_or_desc {a b} {
5890 global arcout arcstart arcend arcnos cached_isanc
5892 if {$arcnos($a) eq $arcnos($b)} {
5893 # Both are on the same arc(s); either both are the same BMP,
5894 # or if one is not a BMP, the other is also not a BMP or is
5895 # the BMP at end of the arc (and it only has 1 incoming arc).
5899 # assert {[llength $arcnos($a)] == 1}
5900 set arc [lindex $arcnos($a) 0]
5901 set i [lsearch -exact $arcids($arc) $a]
5902 set j [lsearch -exact $arcids($arc) $b]
5903 if {$i < 0 || $i > $j} {
5910 if {![info exists arcout($a)]} {
5911 set arc [lindex $arcnos($a) 0]
5912 if {[info exists arcend($arc)]} {
5913 set aend $arcend($arc)
5917 set a $arcstart($arc)
5921 if {![info exists arcout($b)]} {
5922 set arc [lindex $arcnos($b) 0]
5923 if {[info exists arcend($arc)]} {
5924 set bend $arcend($arc)
5928 set b $arcstart($arc)
5938 if {[info exists cached_isanc($a,$bend)]} {
5939 if {$cached_isanc($a,$bend)} {
5943 if {[info exists cached_isanc($b,$aend)]} {
5944 if {$cached_isanc($b,$aend)} {
5947 if {[info exists cached_isanc($a,$bend)]} {
5952 set todo [list $a $b]
5955 for {set i 0} {$i < [llength $todo]} {incr i} {
5956 set x [lindex $todo $i]
5957 if {$anc($x) eq {}} {
5960 foreach arc $arcnos($x) {
5961 set xd $arcstart($arc)
5963 set cached_isanc($a,$bend) 1
5964 set cached_isanc($b,$aend) 0
5966 } elseif {$xd eq $aend} {
5967 set cached_isanc($b,$aend) 1
5968 set cached_isanc($a,$bend) 0
5971 if {![info exists anc($xd)]} {
5972 set anc($xd) $anc($x)
5974 } elseif {$anc($xd) ne $anc($x)} {
5979 set cached_isanc($a,$bend) 0
5980 set cached_isanc($b,$aend) 0
5984 # This identifies whether $desc has an ancestor that is
5985 # a growing tip of the graph and which is not an ancestor of $anc
5986 # and returns 0 if so and 1 if not.
5987 # If we subsequently discover a tag on such a growing tip, and that
5988 # turns out to be a descendent of $anc (which it could, since we
5989 # don't necessarily see children before parents), then $desc
5990 # isn't a good choice to display as a descendent tag of
5991 # $anc (since it is the descendent of another tag which is
5992 # a descendent of $anc). Similarly, $anc isn't a good choice to
5993 # display as a ancestor tag of $desc.
5995 proc is_certain {desc anc} {
5996 global arcnos arcout arcstart arcend growing problems
5999 if {[llength $arcnos($anc)] == 1} {
6000 # tags on the same arc are certain
6001 if {$arcnos($desc) eq $arcnos($anc)} {
6004 if {![info exists arcout($anc)]} {
6005 # if $anc is partway along an arc, use the start of the arc instead
6006 set a [lindex $arcnos($anc) 0]
6007 set anc $arcstart($a)
6010 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6013 set a [lindex $arcnos($desc) 0]
6019 set anclist [list $x]
6023 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6024 set x [lindex $anclist $i]
6029 foreach a $arcout($x) {
6030 if {[info exists growing($a)]} {
6031 if {![info exists growanc($x)] && $dl($x)} {
6037 if {[info exists dl($y)]} {
6041 if {![info exists done($y)]} {
6044 if {[info exists growanc($x)]} {
6048 for {set k 0} {$k < [llength $xl]} {incr k} {
6049 set z [lindex $xl $k]
6050 foreach c $arcout($z) {
6051 if {[info exists arcend($c)]} {
6053 if {[info exists dl($v)] && $dl($v)} {
6055 if {![info exists done($v)]} {
6058 if {[info exists growanc($v)]} {
6068 } elseif {$y eq $anc || !$dl($x)} {
6079 foreach x [array names growanc] {
6088 proc validate_arctags {a} {
6089 global arctags idtags
6093 foreach id $arctags($a) {
6095 if {![info exists idtags($id)]} {
6096 set na [lreplace $na $i $i]
6103 proc validate_archeads {a} {
6104 global archeads idheads
6107 set na $archeads($a)
6108 foreach id $archeads($a) {
6110 if {![info exists idheads($id)]} {
6111 set na [lreplace $na $i $i]
6115 set archeads($a) $na
6118 # Return the list of IDs that have tags that are descendents of id,
6119 # ignoring IDs that are descendents of IDs already reported.
6120 proc desctags {id} {
6121 global arcnos arcstart arcids arctags idtags allparents
6122 global growing cached_dtags
6124 if {![info exists allparents($id)]} {
6127 set t1 [clock clicks -milliseconds]
6129 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6130 # part-way along an arc; check that arc first
6131 set a [lindex $arcnos($id) 0]
6132 if {$arctags($a) ne {}} {
6134 set i [lsearch -exact $arcids($a) $id]
6136 foreach t $arctags($a) {
6137 set j [lsearch -exact $arcids($a) $t]
6145 set id $arcstart($a)
6146 if {[info exists idtags($id)]} {
6150 if {[info exists cached_dtags($id)]} {
6151 return $cached_dtags($id)
6158 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6159 set id [lindex $todo $i]
6161 set ta [info exists hastaggedancestor($id)]
6165 # ignore tags on starting node
6166 if {!$ta && $i > 0} {
6167 if {[info exists idtags($id)]} {
6170 } elseif {[info exists cached_dtags($id)]} {
6171 set tagloc($id) $cached_dtags($id)
6175 foreach a $arcnos($id) {
6177 if {!$ta && $arctags($a) ne {}} {
6179 if {$arctags($a) ne {}} {
6180 lappend tagloc($id) [lindex $arctags($a) end]
6183 if {$ta || $arctags($a) ne {}} {
6184 set tomark [list $d]
6185 for {set j 0} {$j < [llength $tomark]} {incr j} {
6186 set dd [lindex $tomark $j]
6187 if {![info exists hastaggedancestor($dd)]} {
6188 if {[info exists done($dd)]} {
6189 foreach b $arcnos($dd) {
6190 lappend tomark $arcstart($b)
6192 if {[info exists tagloc($dd)]} {
6195 } elseif {[info exists queued($dd)]} {
6198 set hastaggedancestor($dd) 1
6202 if {![info exists queued($d)]} {
6205 if {![info exists hastaggedancestor($d)]} {
6212 foreach id [array names tagloc] {
6213 if {![info exists hastaggedancestor($id)]} {
6214 foreach t $tagloc($id) {
6215 if {[lsearch -exact $tags $t] < 0} {
6221 set t2 [clock clicks -milliseconds]
6224 # remove tags that are descendents of other tags
6225 for {set i 0} {$i < [llength $tags]} {incr i} {
6226 set a [lindex $tags $i]
6227 for {set j 0} {$j < $i} {incr j} {
6228 set b [lindex $tags $j]
6229 set r [anc_or_desc $a $b]
6231 set tags [lreplace $tags $j $j]
6234 } elseif {$r == -1} {
6235 set tags [lreplace $tags $i $i]
6242 if {[array names growing] ne {}} {
6243 # graph isn't finished, need to check if any tag could get
6244 # eclipsed by another tag coming later. Simply ignore any
6245 # tags that could later get eclipsed.
6248 if {[is_certain $t $origid]} {
6252 if {$tags eq $ctags} {
6253 set cached_dtags($origid) $tags
6258 set cached_dtags($origid) $tags
6260 set t3 [clock clicks -milliseconds]
6261 if {0 && $t3 - $t1 >= 100} {
6262 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6263 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6269 global arcnos arcids arcout arcend arctags idtags allparents
6270 global growing cached_atags
6272 if {![info exists allparents($id)]} {
6275 set t1 [clock clicks -milliseconds]
6277 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6278 # part-way along an arc; check that arc first
6279 set a [lindex $arcnos($id) 0]
6280 if {$arctags($a) ne {}} {
6282 set i [lsearch -exact $arcids($a) $id]
6283 foreach t $arctags($a) {
6284 set j [lsearch -exact $arcids($a) $t]
6290 if {![info exists arcend($a)]} {
6294 if {[info exists idtags($id)]} {
6298 if {[info exists cached_atags($id)]} {
6299 return $cached_atags($id)
6307 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6308 set id [lindex $todo $i]
6310 set td [info exists hastaggeddescendent($id)]
6314 # ignore tags on starting node
6315 if {!$td && $i > 0} {
6316 if {[info exists idtags($id)]} {
6319 } elseif {[info exists cached_atags($id)]} {
6320 set tagloc($id) $cached_atags($id)
6324 foreach a $arcout($id) {
6325 if {!$td && $arctags($a) ne {}} {
6327 if {$arctags($a) ne {}} {
6328 lappend tagloc($id) [lindex $arctags($a) 0]
6331 if {![info exists arcend($a)]} continue
6333 if {$td || $arctags($a) ne {}} {
6334 set tomark [list $d]
6335 for {set j 0} {$j < [llength $tomark]} {incr j} {
6336 set dd [lindex $tomark $j]
6337 if {![info exists hastaggeddescendent($dd)]} {
6338 if {[info exists done($dd)]} {
6339 foreach b $arcout($dd) {
6340 if {[info exists arcend($b)]} {
6341 lappend tomark $arcend($b)
6344 if {[info exists tagloc($dd)]} {
6347 } elseif {[info exists queued($dd)]} {
6350 set hastaggeddescendent($dd) 1
6354 if {![info exists queued($d)]} {
6357 if {![info exists hastaggeddescendent($d)]} {
6363 set t2 [clock clicks -milliseconds]
6366 foreach id [array names tagloc] {
6367 if {![info exists hastaggeddescendent($id)]} {
6368 foreach t $tagloc($id) {
6369 if {[lsearch -exact $tags $t] < 0} {
6376 # remove tags that are ancestors of other tags
6377 for {set i 0} {$i < [llength $tags]} {incr i} {
6378 set a [lindex $tags $i]
6379 for {set j 0} {$j < $i} {incr j} {
6380 set b [lindex $tags $j]
6381 set r [anc_or_desc $a $b]
6383 set tags [lreplace $tags $j $j]
6386 } elseif {$r == 1} {
6387 set tags [lreplace $tags $i $i]
6394 if {[array names growing] ne {}} {
6395 # graph isn't finished, need to check if any tag could get
6396 # eclipsed by another tag coming later. Simply ignore any
6397 # tags that could later get eclipsed.
6400 if {[is_certain $origid $t]} {
6404 if {$tags eq $ctags} {
6405 set cached_atags($origid) $tags
6410 set cached_atags($origid) $tags
6412 set t3 [clock clicks -milliseconds]
6413 if {0 && $t3 - $t1 >= 100} {
6414 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6415 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6420 # Return the list of IDs that have heads that are descendents of id,
6421 # including id itself if it has a head.
6422 proc descheads {id} {
6423 global arcnos arcstart arcids archeads idheads cached_dheads
6426 if {![info exists allparents($id)]} {
6430 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6431 # part-way along an arc; check it first
6432 set a [lindex $arcnos($id) 0]
6433 if {$archeads($a) ne {}} {
6434 validate_archeads $a
6435 set i [lsearch -exact $arcids($a) $id]
6436 foreach t $archeads($a) {
6437 set j [lsearch -exact $arcids($a) $t]
6442 set id $arcstart($a)
6447 for {set i 0} {$i < [llength $todo]} {incr i} {
6448 set id [lindex $todo $i]
6449 if {[info exists cached_dheads($id)]} {
6450 set ret [concat $ret $cached_dheads($id)]
6452 if {[info exists idheads($id)]} {
6455 foreach a $arcnos($id) {
6456 if {$archeads($a) ne {}} {
6457 set ret [concat $ret $archeads($a)]
6460 if {![info exists seen($d)]} {
6467 set ret [lsort -unique $ret]
6468 set cached_dheads($origid) $ret
6471 proc addedtag {id} {
6472 global arcnos arcout cached_dtags cached_atags
6474 if {![info exists arcnos($id)]} return
6475 if {![info exists arcout($id)]} {
6476 recalcarc [lindex $arcnos($id) 0]
6478 catch {unset cached_dtags}
6479 catch {unset cached_atags}
6482 proc addedhead {hid head} {
6483 global arcnos arcout cached_dheads
6485 if {![info exists arcnos($hid)]} return
6486 if {![info exists arcout($hid)]} {
6487 recalcarc [lindex $arcnos($hid) 0]
6489 catch {unset cached_dheads}
6492 proc removedhead {hid head} {
6493 global cached_dheads
6495 catch {unset cached_dheads}
6498 proc movedhead {hid head} {
6499 global arcnos arcout cached_dheads
6501 if {![info exists arcnos($hid)]} return
6502 if {![info exists arcout($hid)]} {
6503 recalcarc [lindex $arcnos($hid) 0]
6505 catch {unset cached_dheads}
6508 proc changedrefs {} {
6509 global cached_dheads cached_dtags cached_atags
6510 global arctags archeads arcnos arcout idheads idtags
6512 foreach id [concat [array names idheads] [array names idtags]] {
6513 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6514 set a [lindex $arcnos($id) 0]
6515 if {![info exists donearc($a)]} {
6521 catch {unset cached_dtags}
6522 catch {unset cached_atags}
6523 catch {unset cached_dheads}
6526 proc rereadrefs {} {
6527 global idtags idheads idotherrefs mainhead
6529 set refids [concat [array names idtags] \
6530 [array names idheads] [array names idotherrefs]]
6531 foreach id $refids {
6532 if {![info exists ref($id)]} {
6533 set ref($id) [listrefs $id]
6536 set oldmainhead $mainhead
6539 set refids [lsort -unique [concat $refids [array names idtags] \
6540 [array names idheads] [array names idotherrefs]]]
6541 foreach id $refids {
6542 set v [listrefs $id]
6543 if {![info exists ref($id)] || $ref($id) != $v ||
6544 ($id eq $oldmainhead && $id ne $mainhead) ||
6545 ($id eq $mainhead && $id ne $oldmainhead)} {
6551 proc listrefs {id} {
6552 global idtags idheads idotherrefs
6555 if {[info exists idtags($id)]} {
6559 if {[info exists idheads($id)]} {
6563 if {[info exists idotherrefs($id)]} {
6564 set z $idotherrefs($id)
6566 return [list $x $y $z]
6569 proc showtag {tag isnew} {
6570 global ctext tagcontents tagids linknum
6573 addtohistory [list showtag $tag 0]
6575 $ctext conf -state normal
6578 if {[info exists tagcontents($tag)]} {
6579 set text $tagcontents($tag)
6581 set text "Tag: $tag\nId: $tagids($tag)"
6583 appendwithlinks $text {}
6584 $ctext conf -state disabled
6596 global maxwidth maxgraphpct diffopts
6597 global oldprefs prefstop showneartags
6598 global bgcolor fgcolor ctext diffcolors selectbgcolor
6599 global uifont tabstop
6603 if {[winfo exists $top]} {
6607 foreach v {maxwidth maxgraphpct diffopts showneartags} {
6608 set oldprefs($v) [set $v]
6611 wm title $top "Gitk preferences"
6612 label $top.ldisp -text "Commit list display options"
6613 $top.ldisp configure -font $uifont
6614 grid $top.ldisp - -sticky w -pady 10
6615 label $top.spacer -text " "
6616 label $top.maxwidthl -text "Maximum graph width (lines)" \
6618 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
6619 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
6620 label $top.maxpctl -text "Maximum graph width (% of pane)" \
6622 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
6623 grid x $top.maxpctl $top.maxpct -sticky w
6625 label $top.ddisp -text "Diff display options"
6626 $top.ddisp configure -font $uifont
6627 grid $top.ddisp - -sticky w -pady 10
6628 label $top.diffoptl -text "Options for diff program" \
6630 entry $top.diffopt -width 20 -textvariable diffopts
6631 grid x $top.diffoptl $top.diffopt -sticky w
6633 label $top.ntag.l -text "Display nearby tags" -font optionfont
6634 checkbutton $top.ntag.b -variable showneartags
6635 pack $top.ntag.b $top.ntag.l -side left
6636 grid x $top.ntag -sticky w
6637 label $top.tabstopl -text "tabstop" -font optionfont
6638 entry $top.tabstop -width 10 -textvariable tabstop
6639 grid x $top.tabstopl $top.tabstop -sticky w
6641 label $top.cdisp -text "Colors: press to choose"
6642 $top.cdisp configure -font $uifont
6643 grid $top.cdisp - -sticky w -pady 10
6644 label $top.bg -padx 40 -relief sunk -background $bgcolor
6645 button $top.bgbut -text "Background" -font optionfont \
6646 -command [list choosecolor bgcolor 0 $top.bg background setbg]
6647 grid x $top.bgbut $top.bg -sticky w
6648 label $top.fg -padx 40 -relief sunk -background $fgcolor
6649 button $top.fgbut -text "Foreground" -font optionfont \
6650 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
6651 grid x $top.fgbut $top.fg -sticky w
6652 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
6653 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
6654 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
6655 [list $ctext tag conf d0 -foreground]]
6656 grid x $top.diffoldbut $top.diffold -sticky w
6657 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
6658 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
6659 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
6660 [list $ctext tag conf d1 -foreground]]
6661 grid x $top.diffnewbut $top.diffnew -sticky w
6662 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
6663 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
6664 -command [list choosecolor diffcolors 2 $top.hunksep \
6665 "diff hunk header" \
6666 [list $ctext tag conf hunksep -foreground]]
6667 grid x $top.hunksepbut $top.hunksep -sticky w
6668 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
6669 button $top.selbgbut -text "Select bg" -font optionfont \
6670 -command [list choosecolor selectbgcolor 0 $top.bg background setselbg]
6671 grid x $top.selbgbut $top.selbgsep -sticky w
6674 button $top.buts.ok -text "OK" -command prefsok -default active
6675 $top.buts.ok configure -font $uifont
6676 button $top.buts.can -text "Cancel" -command prefscan -default normal
6677 $top.buts.can configure -font $uifont
6678 grid $top.buts.ok $top.buts.can
6679 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6680 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6681 grid $top.buts - - -pady 10 -sticky ew
6682 bind $top <Visibility> "focus $top.buts.ok"
6685 proc choosecolor {v vi w x cmd} {
6688 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
6689 -title "Gitk: choose color for $x"]
6690 if {$c eq {}} return
6691 $w conf -background $c
6697 global bglist cflist
6699 $w configure -selectbackground $c
6701 $cflist tag configure highlight \
6702 -background [$cflist cget -selectbackground]
6703 allcanvs itemconf secsel -fill $c
6710 $w conf -background $c
6718 $w conf -foreground $c
6720 allcanvs itemconf text -fill $c
6721 $canv itemconf circle -outline $c
6725 global maxwidth maxgraphpct diffopts
6726 global oldprefs prefstop showneartags
6728 foreach v {maxwidth maxgraphpct diffopts showneartags} {
6729 set $v $oldprefs($v)
6731 catch {destroy $prefstop}
6736 global maxwidth maxgraphpct
6737 global oldprefs prefstop showneartags
6738 global charspc ctext tabstop
6740 catch {destroy $prefstop}
6742 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
6743 if {$maxwidth != $oldprefs(maxwidth)
6744 || $maxgraphpct != $oldprefs(maxgraphpct)} {
6746 } elseif {$showneartags != $oldprefs(showneartags)} {
6751 proc formatdate {d} {
6752 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
6755 # This list of encoding names and aliases is distilled from
6756 # http://www.iana.org/assignments/character-sets.
6757 # Not all of them are supported by Tcl.
6758 set encoding_aliases {
6759 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
6760 ISO646-US US-ASCII us IBM367 cp367 csASCII }
6761 { ISO-10646-UTF-1 csISO10646UTF1 }
6762 { ISO_646.basic:1983 ref csISO646basic1983 }
6763 { INVARIANT csINVARIANT }
6764 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
6765 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
6766 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
6767 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
6768 { NATS-DANO iso-ir-9-1 csNATSDANO }
6769 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
6770 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
6771 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
6772 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
6773 { ISO-2022-KR csISO2022KR }
6775 { ISO-2022-JP csISO2022JP }
6776 { ISO-2022-JP-2 csISO2022JP2 }
6777 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
6779 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
6780 { IT iso-ir-15 ISO646-IT csISO15Italian }
6781 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
6782 { ES iso-ir-17 ISO646-ES csISO17Spanish }
6783 { greek7-old iso-ir-18 csISO18Greek7Old }
6784 { latin-greek iso-ir-19 csISO19LatinGreek }
6785 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
6786 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
6787 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
6788 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
6789 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
6790 { BS_viewdata iso-ir-47 csISO47BSViewdata }
6791 { INIS iso-ir-49 csISO49INIS }
6792 { INIS-8 iso-ir-50 csISO50INIS8 }
6793 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
6794 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
6795 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
6796 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
6797 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
6798 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
6800 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
6801 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
6802 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
6803 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
6804 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
6805 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
6806 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
6807 { greek7 iso-ir-88 csISO88Greek7 }
6808 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
6809 { iso-ir-90 csISO90 }
6810 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
6811 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
6812 csISO92JISC62991984b }
6813 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
6814 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
6815 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
6816 csISO95JIS62291984handadd }
6817 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
6818 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
6819 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
6820 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
6822 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
6823 { T.61-7bit iso-ir-102 csISO102T617bit }
6824 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
6825 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
6826 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
6827 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
6828 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
6829 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
6830 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
6831 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
6832 arabic csISOLatinArabic }
6833 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
6834 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
6835 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
6836 greek greek8 csISOLatinGreek }
6837 { T.101-G2 iso-ir-128 csISO128T101G2 }
6838 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
6840 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
6841 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
6842 { CSN_369103 iso-ir-139 csISO139CSN369103 }
6843 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
6844 { ISO_6937-2-add iso-ir-142 csISOTextComm }
6845 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
6846 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
6847 csISOLatinCyrillic }
6848 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
6849 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
6850 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
6851 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
6852 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
6853 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
6854 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
6855 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
6856 { ISO_10367-box iso-ir-155 csISO10367Box }
6857 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
6858 { latin-lap lap iso-ir-158 csISO158Lap }
6859 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
6860 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
6863 { JIS_X0201 X0201 csHalfWidthKatakana }
6864 { KSC5636 ISO646-KR csKSC5636 }
6865 { ISO-10646-UCS-2 csUnicode }
6866 { ISO-10646-UCS-4 csUCS4 }
6867 { DEC-MCS dec csDECMCS }
6868 { hp-roman8 roman8 r8 csHPRoman8 }
6869 { macintosh mac csMacintosh }
6870 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
6872 { IBM038 EBCDIC-INT cp038 csIBM038 }
6873 { IBM273 CP273 csIBM273 }
6874 { IBM274 EBCDIC-BE CP274 csIBM274 }
6875 { IBM275 EBCDIC-BR cp275 csIBM275 }
6876 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
6877 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
6878 { IBM280 CP280 ebcdic-cp-it csIBM280 }
6879 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
6880 { IBM284 CP284 ebcdic-cp-es csIBM284 }
6881 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
6882 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
6883 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
6884 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
6885 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
6886 { IBM424 cp424 ebcdic-cp-he csIBM424 }
6887 { IBM437 cp437 437 csPC8CodePage437 }
6888 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
6889 { IBM775 cp775 csPC775Baltic }
6890 { IBM850 cp850 850 csPC850Multilingual }
6891 { IBM851 cp851 851 csIBM851 }
6892 { IBM852 cp852 852 csPCp852 }
6893 { IBM855 cp855 855 csIBM855 }
6894 { IBM857 cp857 857 csIBM857 }
6895 { IBM860 cp860 860 csIBM860 }
6896 { IBM861 cp861 861 cp-is csIBM861 }
6897 { IBM862 cp862 862 csPC862LatinHebrew }
6898 { IBM863 cp863 863 csIBM863 }
6899 { IBM864 cp864 csIBM864 }
6900 { IBM865 cp865 865 csIBM865 }
6901 { IBM866 cp866 866 csIBM866 }
6902 { IBM868 CP868 cp-ar csIBM868 }
6903 { IBM869 cp869 869 cp-gr csIBM869 }
6904 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
6905 { IBM871 CP871 ebcdic-cp-is csIBM871 }
6906 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
6907 { IBM891 cp891 csIBM891 }
6908 { IBM903 cp903 csIBM903 }
6909 { IBM904 cp904 904 csIBBM904 }
6910 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
6911 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
6912 { IBM1026 CP1026 csIBM1026 }
6913 { EBCDIC-AT-DE csIBMEBCDICATDE }
6914 { EBCDIC-AT-DE-A csEBCDICATDEA }
6915 { EBCDIC-CA-FR csEBCDICCAFR }
6916 { EBCDIC-DK-NO csEBCDICDKNO }
6917 { EBCDIC-DK-NO-A csEBCDICDKNOA }
6918 { EBCDIC-FI-SE csEBCDICFISE }
6919 { EBCDIC-FI-SE-A csEBCDICFISEA }
6920 { EBCDIC-FR csEBCDICFR }
6921 { EBCDIC-IT csEBCDICIT }
6922 { EBCDIC-PT csEBCDICPT }
6923 { EBCDIC-ES csEBCDICES }
6924 { EBCDIC-ES-A csEBCDICESA }
6925 { EBCDIC-ES-S csEBCDICESS }
6926 { EBCDIC-UK csEBCDICUK }
6927 { EBCDIC-US csEBCDICUS }
6928 { UNKNOWN-8BIT csUnknown8BiT }
6929 { MNEMONIC csMnemonic }
6934 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
6935 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
6936 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
6937 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
6938 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
6939 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
6940 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
6941 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
6942 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
6943 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
6944 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
6945 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
6946 { IBM1047 IBM-1047 }
6947 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
6948 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
6949 { UNICODE-1-1 csUnicode11 }
6952 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
6953 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
6955 { ISO-8859-15 ISO_8859-15 Latin-9 }
6956 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
6957 { GBK CP936 MS936 windows-936 }
6958 { JIS_Encoding csJISEncoding }
6959 { Shift_JIS MS_Kanji csShiftJIS }
6960 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
6962 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
6963 { ISO-10646-UCS-Basic csUnicodeASCII }
6964 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
6965 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
6966 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
6967 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
6968 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
6969 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
6970 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
6971 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
6972 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
6973 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
6974 { Adobe-Standard-Encoding csAdobeStandardEncoding }
6975 { Ventura-US csVenturaUS }
6976 { Ventura-International csVenturaInternational }
6977 { PC8-Danish-Norwegian csPC8DanishNorwegian }
6978 { PC8-Turkish csPC8Turkish }
6979 { IBM-Symbols csIBMSymbols }
6980 { IBM-Thai csIBMThai }
6981 { HP-Legal csHPLegal }
6982 { HP-Pi-font csHPPiFont }
6983 { HP-Math8 csHPMath8 }
6984 { Adobe-Symbol-Encoding csHPPSMath }
6985 { HP-DeskTop csHPDesktop }
6986 { Ventura-Math csVenturaMath }
6987 { Microsoft-Publishing csMicrosoftPublishing }
6988 { Windows-31J csWindows31J }
6993 proc tcl_encoding {enc} {
6994 global encoding_aliases
6995 set names [encoding names]
6996 set lcnames [string tolower $names]
6997 set enc [string tolower $enc]
6998 set i [lsearch -exact $lcnames $enc]
7000 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7001 if {[regsub {^iso[-_]} $enc iso encx]} {
7002 set i [lsearch -exact $lcnames $encx]
7006 foreach l $encoding_aliases {
7007 set ll [string tolower $l]
7008 if {[lsearch -exact $ll $enc] < 0} continue
7009 # look through the aliases for one that tcl knows about
7011 set i [lsearch -exact $lcnames $e]
7013 if {[regsub {^iso[-_]} $e iso ex]} {
7014 set i [lsearch -exact $lcnames $ex]
7023 return [lindex $names $i]
7030 set diffopts "-U 5 -p"
7031 set wrcomcmd "git diff-tree --stdin -p --pretty"
7035 set gitencoding [exec git config --get i18n.commitencoding]
7037 if {$gitencoding == ""} {
7038 set gitencoding "utf-8"
7040 set tclencoding [tcl_encoding $gitencoding]
7041 if {$tclencoding == {}} {
7042 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7045 set mainfont {Helvetica 9}
7046 set textfont {Courier 9}
7047 set uifont {Helvetica 9 bold}
7049 set findmergefiles 0
7057 set cmitmode "patch"
7058 set wrapcomment "none"
7063 set colors {green red blue magenta darkgrey brown orange}
7066 set diffcolors {red "#00a000" blue}
7067 set selectbgcolor gray85
7069 catch {source ~/.gitk}
7071 font create optionfont -family sans-serif -size -12
7075 switch -regexp -- $arg {
7077 "^-d" { set datemode 1 }
7079 lappend revtreeargs $arg
7084 # check that we can find a .git directory somewhere...
7086 if {![file isdirectory $gitdir]} {
7087 show_error {} . "Cannot find the git directory \"$gitdir\"."
7091 set cmdline_files {}
7092 set i [lsearch -exact $revtreeargs "--"]
7094 set cmdline_files [lrange $revtreeargs [expr {$i + 1}] end]
7095 set revtreeargs [lrange $revtreeargs 0 [expr {$i - 1}]]
7096 } elseif {$revtreeargs ne {}} {
7098 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7099 set cmdline_files [split $f "\n"]
7100 set n [llength $cmdline_files]
7101 set revtreeargs [lrange $revtreeargs 0 end-$n]
7103 # unfortunately we get both stdout and stderr in $err,
7104 # so look for "fatal:".
7105 set i [string first "fatal:" $err]
7107 set err [string range $err [expr {$i + 6}] end]
7109 show_error {} . "Bad arguments to gitk:\n$err"
7119 set highlight_paths {}
7120 set searchdirn -forwards
7130 set selectedhlview None
7141 wm title . "[file tail $argv0]: [file tail [pwd]]"
7144 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7145 # create a view for the files/dirs specified on the command line
7149 set viewname(1) "Command line"
7150 set viewfiles(1) $cmdline_files
7151 set viewargs(1) $revtreeargs
7154 .bar.view entryconf Edit* -state normal
7155 .bar.view entryconf Delete* -state normal
7158 if {[info exists permviews]} {
7159 foreach v $permviews {
7162 set viewname($n) [lindex $v 0]
7163 set viewfiles($n) [lindex $v 1]
7164 set viewargs($n) [lindex $v 2]