2 # Tcl ignores the next line -*- tcl -*- \
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
12 if {[info exists env(GIT_DIR)]} {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
28 if {[info exists isonrunq($script)]} return
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
43 fileevent $fd readable {}
47 lappend runq [list $fd $script]
53 set tstart [clock clicks -milliseconds]
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
74 if {$t1 - $tstart >= 80} break
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set order "--topo-order"
92 set order "--date-order"
95 set fd [open [concat | git log -z --pretty=raw $order --parents \
96 --boundary $viewargs($view) "--" $viewfiles($view)] r]
98 error_popup "Error executing git rev-list: $err"
101 set commfd($view) $fd
102 set leftover($view) {}
103 set lookingforhead $showlocalchanges
104 fconfigure $fd -blocking 0 -translation lf -eofchar {}
105 if {$tclencoding != {}} {
106 fconfigure $fd -encoding $tclencoding
108 filerun $fd [list getcommitlines $fd $view]
112 proc stop_rev_list {} {
113 global commfd curview
115 if {![info exists commfd($curview)]} return
116 set fd $commfd($curview)
122 unset commfd($curview)
126 global phase canv mainfont curview
130 start_rev_list $curview
131 show_status "Reading commits..."
134 proc getcommitlines {fd view} {
136 global leftover commfd
137 global displayorder commitidx commitrow commitdata
138 global parentlist children curview hlview
139 global vparentlist vdisporder vcmitlisted
141 set stuff [read $fd 500000]
142 # git log doesn't terminate the last commit with a null...
143 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
153 # set it blocking so we wait for the process to terminate
154 fconfigure $fd -blocking 1
155 if {[catch {close $fd} err]} {
157 if {$view != $curview} {
158 set fv " for the \"$viewname($view)\" view"
160 if {[string range $err 0 4] == "usage"} {
161 set err "Gitk: error reading commits$fv:\
162 bad arguments to git rev-list."
163 if {$viewname($view) eq "Command line"} {
165 " (Note: arguments to gitk are passed to git rev-list\
166 to allow selection of commits to be displayed.)"
169 set err "Error reading commits$fv: $err"
173 if {$view == $curview} {
174 run chewcommits $view
181 set i [string first "\0" $stuff $start]
183 append leftover($view) [string range $stuff $start end]
187 set cmit $leftover($view)
188 append cmit [string range $stuff 0 [expr {$i - 1}]]
189 set leftover($view) {}
191 set cmit [string range $stuff $start [expr {$i - 1}]]
193 set start [expr {$i + 1}]
194 set j [string first "\n" $cmit]
197 if {$j >= 0 && [string match "commit *" $cmit]} {
198 set ids [string range $cmit 7 [expr {$j - 1}]]
199 if {[string match {[-<>]*} $ids]} {
200 switch -- [string index $ids 0] {
205 set ids [string range $ids 1 end]
209 if {[string length $id] != 40} {
217 if {[string length $shortcmit] > 80} {
218 set shortcmit "[string range $shortcmit 0 80]..."
220 error_popup "Can't parse git log output: {$shortcmit}"
223 set id [lindex $ids 0]
225 set olds [lrange $ids 1 end]
228 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
229 lappend children($view,$p) $id
236 if {![info exists children($view,$id)]} {
237 set children($view,$id) {}
239 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
240 set commitrow($view,$id) $commitidx($view)
241 incr commitidx($view)
242 if {$view == $curview} {
243 lappend parentlist $olds
244 lappend displayorder $id
245 lappend commitlisted $listed
247 lappend vparentlist($view) $olds
248 lappend vdisporder($view) $id
249 lappend vcmitlisted($view) $listed
254 run chewcommits $view
259 proc chewcommits {view} {
260 global curview hlview commfd
261 global selectedline pending_select
264 if {$view == $curview} {
265 set allread [expr {![info exists commfd($view)]}]
266 set tlimit [expr {[clock clicks -milliseconds] + 50}]
267 set more [layoutmore $tlimit $allread]
268 if {$allread && !$more} {
269 global displayorder commitidx phase
270 global numcommits startmsecs
272 if {[info exists pending_select]} {
273 set row [first_real_row]
276 if {$commitidx($curview) > 0} {
277 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
278 #puts "overall $ms ms for $numcommits commits"
280 show_status "No commits selected"
286 if {[info exists hlview] && $view == $hlview} {
292 proc readcommit {id} {
293 if {[catch {set contents [exec git cat-file commit $id]}]} return
294 parsecommit $id $contents 0
297 proc updatecommits {} {
298 global viewdata curview phase displayorder
299 global children commitrow selectedline thickerline
306 foreach id $displayorder {
307 catch {unset children($n,$id)}
308 catch {unset commitrow($n,$id)}
311 catch {unset selectedline}
312 catch {unset thickerline}
313 catch {unset viewdata($n)}
320 proc parsecommit {id contents listed} {
321 global commitinfo cdate
330 set hdrend [string first "\n\n" $contents]
332 # should never happen...
333 set hdrend [string length $contents]
335 set header [string range $contents 0 [expr {$hdrend - 1}]]
336 set comment [string range $contents [expr {$hdrend + 2}] end]
337 foreach line [split $header "\n"] {
338 set tag [lindex $line 0]
339 if {$tag == "author"} {
340 set audate [lindex $line end-1]
341 set auname [lrange $line 1 end-2]
342 } elseif {$tag == "committer"} {
343 set comdate [lindex $line end-1]
344 set comname [lrange $line 1 end-2]
348 # take the first non-blank line of the comment as the headline
349 set headline [string trimleft $comment]
350 set i [string first "\n" $headline]
352 set headline [string range $headline 0 $i]
354 set headline [string trimright $headline]
355 set i [string first "\r" $headline]
357 set headline [string trimright [string range $headline 0 $i]]
360 # git rev-list indents the comment by 4 spaces;
361 # if we got this via git cat-file, add the indentation
363 foreach line [split $comment "\n"] {
364 append newcomment " "
365 append newcomment $line
366 append newcomment "\n"
368 set comment $newcomment
370 if {$comdate != {}} {
371 set cdate($id) $comdate
373 set commitinfo($id) [list $headline $auname $audate \
374 $comname $comdate $comment]
377 proc getcommit {id} {
378 global commitdata commitinfo
380 if {[info exists commitdata($id)]} {
381 parsecommit $id $commitdata($id) 1
384 if {![info exists commitinfo($id)]} {
385 set commitinfo($id) {"No commit information available"}
392 global tagids idtags headids idheads tagobjid
393 global otherrefids idotherrefs mainhead mainheadid
395 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
398 set refd [open [list | git show-ref -d] r]
399 while {[gets $refd line] >= 0} {
400 if {[string index $line 40] ne " "} continue
401 set id [string range $line 0 39]
402 set ref [string range $line 41 end]
403 if {![string match "refs/*" $ref]} continue
404 set name [string range $ref 5 end]
405 if {[string match "remotes/*" $name]} {
406 if {![string match "*/HEAD" $name]} {
407 set headids($name) $id
408 lappend idheads($id) $name
410 } elseif {[string match "heads/*" $name]} {
411 set name [string range $name 6 end]
412 set headids($name) $id
413 lappend idheads($id) $name
414 } elseif {[string match "tags/*" $name]} {
415 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
416 # which is what we want since the former is the commit ID
417 set name [string range $name 5 end]
418 if {[string match "*^{}" $name]} {
419 set name [string range $name 0 end-3]
421 set tagobjid($name) $id
423 set tagids($name) $id
424 lappend idtags($id) $name
426 set otherrefids($name) $id
427 lappend idotherrefs($id) $name
434 set thehead [exec git symbolic-ref HEAD]
435 if {[string match "refs/heads/*" $thehead]} {
436 set mainhead [string range $thehead 11 end]
437 if {[info exists headids($mainhead)]} {
438 set mainheadid $headids($mainhead)
444 # skip over fake commits
445 proc first_real_row {} {
446 global nullid nullid2 displayorder numcommits
448 for {set row 0} {$row < $numcommits} {incr row} {
449 set id [lindex $displayorder $row]
450 if {$id ne $nullid && $id ne $nullid2} {
457 # update things for a head moved to a child of its previous location
458 proc movehead {id name} {
459 global headids idheads
461 removehead $headids($name) $name
462 set headids($name) $id
463 lappend idheads($id) $name
466 # update things when a head has been removed
467 proc removehead {id name} {
468 global headids idheads
470 if {$idheads($id) eq $name} {
473 set i [lsearch -exact $idheads($id) $name]
475 set idheads($id) [lreplace $idheads($id) $i $i]
481 proc show_error {w top msg} {
482 message $w.m -text $msg -justify center -aspect 400
483 pack $w.m -side top -fill x -padx 20 -pady 20
484 button $w.ok -text OK -command "destroy $top"
485 pack $w.ok -side bottom -fill x
486 bind $top <Visibility> "grab $top; focus $top"
487 bind $top <Key-Return> "destroy $top"
491 proc error_popup msg {
495 show_error $w $w $msg
498 proc confirm_popup msg {
504 message $w.m -text $msg -justify center -aspect 400
505 pack $w.m -side top -fill x -padx 20 -pady 20
506 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
507 pack $w.ok -side left -fill x
508 button $w.cancel -text Cancel -command "destroy $w"
509 pack $w.cancel -side right -fill x
510 bind $w <Visibility> "grab $w; focus $w"
516 global canv canv2 canv3 linespc charspc ctext cflist
517 global textfont mainfont uifont tabstop
518 global findtype findtypemenu findloc findstring fstring geometry
519 global entries sha1entry sha1string sha1but
520 global maincursor textcursor curtextcursor
521 global rowctxmenu fakerowmenu mergemax wrapcomment
522 global highlight_files gdttype
523 global searchstring sstring
524 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
528 .bar add cascade -label "File" -menu .bar.file
529 .bar configure -font $uifont
531 .bar.file add command -label "Update" -command updatecommits
532 .bar.file add command -label "Reread references" -command rereadrefs
533 .bar.file add command -label "Quit" -command doquit
534 .bar.file configure -font $uifont
536 .bar add cascade -label "Edit" -menu .bar.edit
537 .bar.edit add command -label "Preferences" -command doprefs
538 .bar.edit configure -font $uifont
540 menu .bar.view -font $uifont
541 .bar add cascade -label "View" -menu .bar.view
542 .bar.view add command -label "New view..." -command {newview 0}
543 .bar.view add command -label "Edit view..." -command editview \
545 .bar.view add command -label "Delete view" -command delview -state disabled
546 .bar.view add separator
547 .bar.view add radiobutton -label "All files" -command {showview 0} \
548 -variable selectedview -value 0
551 .bar add cascade -label "Help" -menu .bar.help
552 .bar.help add command -label "About gitk" -command about
553 .bar.help add command -label "Key bindings" -command keys
554 .bar.help configure -font $uifont
555 . configure -menu .bar
557 # the gui has upper and lower half, parts of a paned window.
558 panedwindow .ctop -orient vertical
560 # possibly use assumed geometry
561 if {![info exists geometry(pwsash0)]} {
562 set geometry(topheight) [expr {15 * $linespc}]
563 set geometry(topwidth) [expr {80 * $charspc}]
564 set geometry(botheight) [expr {15 * $linespc}]
565 set geometry(botwidth) [expr {50 * $charspc}]
566 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
567 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
570 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
571 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
573 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
575 # create three canvases
576 set cscroll .tf.histframe.csb
577 set canv .tf.histframe.pwclist.canv
579 -selectbackground $selectbgcolor \
580 -background $bgcolor -bd 0 \
581 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
582 .tf.histframe.pwclist add $canv
583 set canv2 .tf.histframe.pwclist.canv2
585 -selectbackground $selectbgcolor \
586 -background $bgcolor -bd 0 -yscrollincr $linespc
587 .tf.histframe.pwclist add $canv2
588 set canv3 .tf.histframe.pwclist.canv3
590 -selectbackground $selectbgcolor \
591 -background $bgcolor -bd 0 -yscrollincr $linespc
592 .tf.histframe.pwclist add $canv3
593 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
594 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
596 # a scroll bar to rule them
597 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
598 pack $cscroll -side right -fill y
599 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
600 lappend bglist $canv $canv2 $canv3
601 pack .tf.histframe.pwclist -fill both -expand 1 -side left
603 # we have two button bars at bottom of top frame. Bar 1
605 frame .tf.lbar -height 15
607 set sha1entry .tf.bar.sha1
608 set entries $sha1entry
609 set sha1but .tf.bar.sha1label
610 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
611 -command gotocommit -width 8 -font $uifont
612 $sha1but conf -disabledforeground [$sha1but cget -foreground]
613 pack .tf.bar.sha1label -side left
614 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
615 trace add variable sha1string write sha1change
616 pack $sha1entry -side left -pady 2
618 image create bitmap bm-left -data {
619 #define left_width 16
620 #define left_height 16
621 static unsigned char left_bits[] = {
622 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
623 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
624 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
626 image create bitmap bm-right -data {
627 #define right_width 16
628 #define right_height 16
629 static unsigned char right_bits[] = {
630 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
631 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
632 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
634 button .tf.bar.leftbut -image bm-left -command goback \
635 -state disabled -width 26
636 pack .tf.bar.leftbut -side left -fill y
637 button .tf.bar.rightbut -image bm-right -command goforw \
638 -state disabled -width 26
639 pack .tf.bar.rightbut -side left -fill y
641 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
642 pack .tf.bar.findbut -side left
644 set fstring .tf.bar.findstring
645 lappend entries $fstring
646 entry $fstring -width 30 -font $textfont -textvariable findstring
647 trace add variable findstring write find_change
648 pack $fstring -side left -expand 1 -fill x -in .tf.bar
650 set findtypemenu [tk_optionMenu .tf.bar.findtype \
651 findtype Exact IgnCase Regexp]
652 trace add variable findtype write find_change
653 .tf.bar.findtype configure -font $uifont
654 .tf.bar.findtype.menu configure -font $uifont
655 set findloc "All fields"
656 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
657 Comments Author Committer
658 trace add variable findloc write find_change
659 .tf.bar.findloc configure -font $uifont
660 .tf.bar.findloc.menu configure -font $uifont
661 pack .tf.bar.findloc -side right
662 pack .tf.bar.findtype -side right
664 # build up the bottom bar of upper window
665 label .tf.lbar.flabel -text "Highlight: Commits " \
667 pack .tf.lbar.flabel -side left -fill y
668 set gdttype "touching paths:"
669 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
670 "adding/removing string:"]
671 trace add variable gdttype write hfiles_change
672 $gm conf -font $uifont
673 .tf.lbar.gdttype conf -font $uifont
674 pack .tf.lbar.gdttype -side left -fill y
675 entry .tf.lbar.fent -width 25 -font $textfont \
676 -textvariable highlight_files
677 trace add variable highlight_files write hfiles_change
678 lappend entries .tf.lbar.fent
679 pack .tf.lbar.fent -side left -fill x -expand 1
680 label .tf.lbar.vlabel -text " OR in view" -font $uifont
681 pack .tf.lbar.vlabel -side left -fill y
682 global viewhlmenu selectedhlview
683 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
684 $viewhlmenu entryconf None -command delvhighlight
685 $viewhlmenu conf -font $uifont
686 .tf.lbar.vhl conf -font $uifont
687 pack .tf.lbar.vhl -side left -fill y
688 label .tf.lbar.rlabel -text " OR " -font $uifont
689 pack .tf.lbar.rlabel -side left -fill y
690 global highlight_related
691 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
692 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
693 $m conf -font $uifont
694 .tf.lbar.relm conf -font $uifont
695 trace add variable highlight_related write vrel_change
696 pack .tf.lbar.relm -side left -fill y
698 # Finish putting the upper half of the viewer together
699 pack .tf.lbar -in .tf -side bottom -fill x
700 pack .tf.bar -in .tf -side bottom -fill x
701 pack .tf.histframe -fill both -side top -expand 1
703 .ctop paneconfigure .tf -height $geometry(topheight)
704 .ctop paneconfigure .tf -width $geometry(topwidth)
706 # now build up the bottom
707 panedwindow .pwbottom -orient horizontal
709 # lower left, a text box over search bar, scroll bar to the right
710 # if we know window height, then that will set the lower text height, otherwise
711 # we set lower text height which will drive window height
712 if {[info exists geometry(main)]} {
713 frame .bleft -width $geometry(botwidth)
715 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
720 button .bleft.top.search -text "Search" -command dosearch \
722 pack .bleft.top.search -side left -padx 5
723 set sstring .bleft.top.sstring
724 entry $sstring -width 20 -font $textfont -textvariable searchstring
725 lappend entries $sstring
726 trace add variable searchstring write incrsearch
727 pack $sstring -side left -expand 1 -fill x
728 radiobutton .bleft.mid.diff -text "Diff" \
729 -command changediffdisp -variable diffelide -value {0 0}
730 radiobutton .bleft.mid.old -text "Old version" \
731 -command changediffdisp -variable diffelide -value {0 1}
732 radiobutton .bleft.mid.new -text "New version" \
733 -command changediffdisp -variable diffelide -value {1 0}
734 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
735 set ctext .bleft.ctext
736 text $ctext -background $bgcolor -foreground $fgcolor \
737 -tabs "[expr {$tabstop * $charspc}]" \
738 -state disabled -font $textfont \
739 -yscrollcommand scrolltext -wrap none
740 scrollbar .bleft.sb -command "$ctext yview"
741 pack .bleft.top -side top -fill x
742 pack .bleft.mid -side top -fill x
743 pack .bleft.sb -side right -fill y
744 pack $ctext -side left -fill both -expand 1
745 lappend bglist $ctext
746 lappend fglist $ctext
748 $ctext tag conf comment -wrap $wrapcomment
749 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
750 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
751 $ctext tag conf d0 -fore [lindex $diffcolors 0]
752 $ctext tag conf d1 -fore [lindex $diffcolors 1]
753 $ctext tag conf m0 -fore red
754 $ctext tag conf m1 -fore blue
755 $ctext tag conf m2 -fore green
756 $ctext tag conf m3 -fore purple
757 $ctext tag conf m4 -fore brown
758 $ctext tag conf m5 -fore "#009090"
759 $ctext tag conf m6 -fore magenta
760 $ctext tag conf m7 -fore "#808000"
761 $ctext tag conf m8 -fore "#009000"
762 $ctext tag conf m9 -fore "#ff0080"
763 $ctext tag conf m10 -fore cyan
764 $ctext tag conf m11 -fore "#b07070"
765 $ctext tag conf m12 -fore "#70b0f0"
766 $ctext tag conf m13 -fore "#70f0b0"
767 $ctext tag conf m14 -fore "#f0b070"
768 $ctext tag conf m15 -fore "#ff70b0"
769 $ctext tag conf mmax -fore darkgrey
771 $ctext tag conf mresult -font [concat $textfont bold]
772 $ctext tag conf msep -font [concat $textfont bold]
773 $ctext tag conf found -back yellow
776 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
781 radiobutton .bright.mode.patch -text "Patch" \
782 -command reselectline -variable cmitmode -value "patch"
783 .bright.mode.patch configure -font $uifont
784 radiobutton .bright.mode.tree -text "Tree" \
785 -command reselectline -variable cmitmode -value "tree"
786 .bright.mode.tree configure -font $uifont
787 grid .bright.mode.patch .bright.mode.tree -sticky ew
788 pack .bright.mode -side top -fill x
789 set cflist .bright.cfiles
790 set indent [font measure $mainfont "nn"]
792 -selectbackground $selectbgcolor \
793 -background $bgcolor -foreground $fgcolor \
795 -tabs [list $indent [expr {2 * $indent}]] \
796 -yscrollcommand ".bright.sb set" \
797 -cursor [. cget -cursor] \
798 -spacing1 1 -spacing3 1
799 lappend bglist $cflist
800 lappend fglist $cflist
801 scrollbar .bright.sb -command "$cflist yview"
802 pack .bright.sb -side right -fill y
803 pack $cflist -side left -fill both -expand 1
804 $cflist tag configure highlight \
805 -background [$cflist cget -selectbackground]
806 $cflist tag configure bold -font [concat $mainfont bold]
808 .pwbottom add .bright
811 # restore window position if known
812 if {[info exists geometry(main)]} {
813 wm geometry . "$geometry(main)"
816 if {[tk windowingsystem] eq {aqua}} {
822 bind .pwbottom <Configure> {resizecdetpanes %W %w}
823 pack .ctop -fill both -expand 1
824 bindall <1> {selcanvline %W %x %y}
825 #bindall <B1-Motion> {selcanvline %W %x %y}
826 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
827 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
828 bindall <2> "canvscan mark %W %x %y"
829 bindall <B2-Motion> "canvscan dragto %W %x %y"
830 bindkey <Home> selfirstline
831 bindkey <End> sellastline
832 bind . <Key-Up> "selnextline -1"
833 bind . <Key-Down> "selnextline 1"
834 bind . <Shift-Key-Up> "next_highlight -1"
835 bind . <Shift-Key-Down> "next_highlight 1"
836 bindkey <Key-Right> "goforw"
837 bindkey <Key-Left> "goback"
838 bind . <Key-Prior> "selnextpage -1"
839 bind . <Key-Next> "selnextpage 1"
840 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
841 bind . <$M1B-End> "allcanvs yview moveto 1.0"
842 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
843 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
844 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
845 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
846 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
847 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
848 bindkey <Key-space> "$ctext yview scroll 1 pages"
849 bindkey p "selnextline -1"
850 bindkey n "selnextline 1"
853 bindkey i "selnextline -1"
854 bindkey k "selnextline 1"
857 bindkey b "$ctext yview scroll -1 pages"
858 bindkey d "$ctext yview scroll 18 units"
859 bindkey u "$ctext yview scroll -18 units"
860 bindkey / {findnext 1}
861 bindkey <Key-Return> {findnext 0}
864 bindkey <F5> updatecommits
865 bind . <$M1B-q> doquit
866 bind . <$M1B-f> dofind
867 bind . <$M1B-g> {findnext 0}
868 bind . <$M1B-r> dosearchback
869 bind . <$M1B-s> dosearch
870 bind . <$M1B-equal> {incrfont 1}
871 bind . <$M1B-KP_Add> {incrfont 1}
872 bind . <$M1B-minus> {incrfont -1}
873 bind . <$M1B-KP_Subtract> {incrfont -1}
874 wm protocol . WM_DELETE_WINDOW doquit
875 bind . <Button-1> "click %W"
876 bind $fstring <Key-Return> dofind
877 bind $sha1entry <Key-Return> gotocommit
878 bind $sha1entry <<PasteSelection>> clearsha1
879 bind $cflist <1> {sel_flist %W %x %y; break}
880 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
881 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
883 set maincursor [. cget -cursor]
884 set textcursor [$ctext cget -cursor]
885 set curtextcursor $textcursor
887 set rowctxmenu .rowctxmenu
888 menu $rowctxmenu -tearoff 0
889 $rowctxmenu add command -label "Diff this -> selected" \
890 -command {diffvssel 0}
891 $rowctxmenu add command -label "Diff selected -> this" \
892 -command {diffvssel 1}
893 $rowctxmenu add command -label "Make patch" -command mkpatch
894 $rowctxmenu add command -label "Create tag" -command mktag
895 $rowctxmenu add command -label "Write commit to file" -command writecommit
896 $rowctxmenu add command -label "Create new branch" -command mkbranch
897 $rowctxmenu add command -label "Cherry-pick this commit" \
899 $rowctxmenu add command -label "Reset HEAD branch to here" \
902 set fakerowmenu .fakerowmenu
903 menu $fakerowmenu -tearoff 0
904 $fakerowmenu add command -label "Diff this -> selected" \
905 -command {diffvssel 0}
906 $fakerowmenu add command -label "Diff selected -> this" \
907 -command {diffvssel 1}
908 $fakerowmenu add command -label "Make patch" -command mkpatch
909 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
910 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
911 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
913 set headctxmenu .headctxmenu
914 menu $headctxmenu -tearoff 0
915 $headctxmenu add command -label "Check out this branch" \
917 $headctxmenu add command -label "Remove this branch" \
921 # mouse-2 makes all windows scan vertically, but only the one
922 # the cursor is in scans horizontally
923 proc canvscan {op w x y} {
924 global canv canv2 canv3
925 foreach c [list $canv $canv2 $canv3] {
934 proc scrollcanv {cscroll f0 f1} {
940 # when we make a key binding for the toplevel, make sure
941 # it doesn't get triggered when that key is pressed in the
942 # find string entry widget.
943 proc bindkey {ev script} {
946 set escript [bind Entry $ev]
947 if {$escript == {}} {
948 set escript [bind Entry <Key>]
951 bind $e $ev "$escript; break"
955 # set the focus back to the toplevel for any click outside
966 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
967 global stuffsaved findmergefiles maxgraphpct
968 global maxwidth showneartags showlocalchanges
969 global viewname viewfiles viewargs viewperm nextviewnum
970 global cmitmode wrapcomment
971 global colors bgcolor fgcolor diffcolors selectbgcolor
973 if {$stuffsaved} return
974 if {![winfo viewable .]} return
976 set f [open "~/.gitk-new" w]
977 puts $f [list set mainfont $mainfont]
978 puts $f [list set textfont $textfont]
979 puts $f [list set uifont $uifont]
980 puts $f [list set tabstop $tabstop]
981 puts $f [list set findmergefiles $findmergefiles]
982 puts $f [list set maxgraphpct $maxgraphpct]
983 puts $f [list set maxwidth $maxwidth]
984 puts $f [list set cmitmode $cmitmode]
985 puts $f [list set wrapcomment $wrapcomment]
986 puts $f [list set showneartags $showneartags]
987 puts $f [list set showlocalchanges $showlocalchanges]
988 puts $f [list set bgcolor $bgcolor]
989 puts $f [list set fgcolor $fgcolor]
990 puts $f [list set colors $colors]
991 puts $f [list set diffcolors $diffcolors]
992 puts $f [list set selectbgcolor $selectbgcolor]
994 puts $f "set geometry(main) [wm geometry .]"
995 puts $f "set geometry(topwidth) [winfo width .tf]"
996 puts $f "set geometry(topheight) [winfo height .tf]"
997 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
998 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
999 puts $f "set geometry(botwidth) [winfo width .bleft]"
1000 puts $f "set geometry(botheight) [winfo height .bleft]"
1002 puts -nonewline $f "set permviews {"
1003 for {set v 0} {$v < $nextviewnum} {incr v} {
1004 if {$viewperm($v)} {
1005 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1010 file rename -force "~/.gitk-new" "~/.gitk"
1015 proc resizeclistpanes {win w} {
1017 if {[info exists oldwidth($win)]} {
1018 set s0 [$win sash coord 0]
1019 set s1 [$win sash coord 1]
1021 set sash0 [expr {int($w/2 - 2)}]
1022 set sash1 [expr {int($w*5/6 - 2)}]
1024 set factor [expr {1.0 * $w / $oldwidth($win)}]
1025 set sash0 [expr {int($factor * [lindex $s0 0])}]
1026 set sash1 [expr {int($factor * [lindex $s1 0])}]
1030 if {$sash1 < $sash0 + 20} {
1031 set sash1 [expr {$sash0 + 20}]
1033 if {$sash1 > $w - 10} {
1034 set sash1 [expr {$w - 10}]
1035 if {$sash0 > $sash1 - 20} {
1036 set sash0 [expr {$sash1 - 20}]
1040 $win sash place 0 $sash0 [lindex $s0 1]
1041 $win sash place 1 $sash1 [lindex $s1 1]
1043 set oldwidth($win) $w
1046 proc resizecdetpanes {win w} {
1048 if {[info exists oldwidth($win)]} {
1049 set s0 [$win sash coord 0]
1051 set sash0 [expr {int($w*3/4 - 2)}]
1053 set factor [expr {1.0 * $w / $oldwidth($win)}]
1054 set sash0 [expr {int($factor * [lindex $s0 0])}]
1058 if {$sash0 > $w - 15} {
1059 set sash0 [expr {$w - 15}]
1062 $win sash place 0 $sash0 [lindex $s0 1]
1064 set oldwidth($win) $w
1067 proc allcanvs args {
1068 global canv canv2 canv3
1074 proc bindall {event action} {
1075 global canv canv2 canv3
1076 bind $canv $event $action
1077 bind $canv2 $event $action
1078 bind $canv3 $event $action
1084 if {[winfo exists $w]} {
1089 wm title $w "About gitk"
1090 message $w.m -text {
1091 Gitk - a commit viewer for git
1093 Copyright © 2005-2006 Paul Mackerras
1095 Use and redistribute under the terms of the GNU General Public License} \
1096 -justify center -aspect 400 -border 2 -bg white -relief groove
1097 pack $w.m -side top -fill x -padx 2 -pady 2
1098 $w.m configure -font $uifont
1099 button $w.ok -text Close -command "destroy $w" -default active
1100 pack $w.ok -side bottom
1101 $w.ok configure -font $uifont
1102 bind $w <Visibility> "focus $w.ok"
1103 bind $w <Key-Escape> "destroy $w"
1104 bind $w <Key-Return> "destroy $w"
1110 if {[winfo exists $w]} {
1114 if {[tk windowingsystem] eq {aqua}} {
1120 wm title $w "Gitk key bindings"
1121 message $w.m -text "
1125 <Home> Move to first commit
1126 <End> Move to last commit
1127 <Up>, p, i Move up one commit
1128 <Down>, n, k Move down one commit
1129 <Left>, z, j Go back in history list
1130 <Right>, x, l Go forward in history list
1131 <PageUp> Move up one page in commit list
1132 <PageDown> Move down one page in commit list
1133 <$M1T-Home> Scroll to top of commit list
1134 <$M1T-End> Scroll to bottom of commit list
1135 <$M1T-Up> Scroll commit list up one line
1136 <$M1T-Down> Scroll commit list down one line
1137 <$M1T-PageUp> Scroll commit list up one page
1138 <$M1T-PageDown> Scroll commit list down one page
1139 <Shift-Up> Move to previous highlighted line
1140 <Shift-Down> Move to next highlighted line
1141 <Delete>, b Scroll diff view up one page
1142 <Backspace> Scroll diff view up one page
1143 <Space> Scroll diff view down one page
1144 u Scroll diff view up 18 lines
1145 d Scroll diff view down 18 lines
1147 <$M1T-G> Move to next find hit
1148 <Return> Move to next find hit
1149 / Move to next find hit, or redo find
1150 ? Move to previous find hit
1151 f Scroll diff view to next file
1152 <$M1T-S> Search for next hit in diff view
1153 <$M1T-R> Search for previous hit in diff view
1154 <$M1T-KP+> Increase font size
1155 <$M1T-plus> Increase font size
1156 <$M1T-KP-> Decrease font size
1157 <$M1T-minus> Decrease font size
1160 -justify left -bg white -border 2 -relief groove
1161 pack $w.m -side top -fill both -padx 2 -pady 2
1162 $w.m configure -font $uifont
1163 button $w.ok -text Close -command "destroy $w" -default active
1164 pack $w.ok -side bottom
1165 $w.ok configure -font $uifont
1166 bind $w <Visibility> "focus $w.ok"
1167 bind $w <Key-Escape> "destroy $w"
1168 bind $w <Key-Return> "destroy $w"
1171 # Procedures for manipulating the file list window at the
1172 # bottom right of the overall window.
1174 proc treeview {w l openlevs} {
1175 global treecontents treediropen treeheight treeparent treeindex
1185 set treecontents() {}
1186 $w conf -state normal
1188 while {[string range $f 0 $prefixend] ne $prefix} {
1189 if {$lev <= $openlevs} {
1190 $w mark set e:$treeindex($prefix) "end -1c"
1191 $w mark gravity e:$treeindex($prefix) left
1193 set treeheight($prefix) $ht
1194 incr ht [lindex $htstack end]
1195 set htstack [lreplace $htstack end end]
1196 set prefixend [lindex $prefendstack end]
1197 set prefendstack [lreplace $prefendstack end end]
1198 set prefix [string range $prefix 0 $prefixend]
1201 set tail [string range $f [expr {$prefixend+1}] end]
1202 while {[set slash [string first "/" $tail]] >= 0} {
1205 lappend prefendstack $prefixend
1206 incr prefixend [expr {$slash + 1}]
1207 set d [string range $tail 0 $slash]
1208 lappend treecontents($prefix) $d
1209 set oldprefix $prefix
1211 set treecontents($prefix) {}
1212 set treeindex($prefix) [incr ix]
1213 set treeparent($prefix) $oldprefix
1214 set tail [string range $tail [expr {$slash+1}] end]
1215 if {$lev <= $openlevs} {
1217 set treediropen($prefix) [expr {$lev < $openlevs}]
1218 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1219 $w mark set d:$ix "end -1c"
1220 $w mark gravity d:$ix left
1222 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1224 $w image create end -align center -image $bm -padx 1 \
1226 $w insert end $d [highlight_tag $prefix]
1227 $w mark set s:$ix "end -1c"
1228 $w mark gravity s:$ix left
1233 if {$lev <= $openlevs} {
1236 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1238 $w insert end $tail [highlight_tag $f]
1240 lappend treecontents($prefix) $tail
1243 while {$htstack ne {}} {
1244 set treeheight($prefix) $ht
1245 incr ht [lindex $htstack end]
1246 set htstack [lreplace $htstack end end]
1247 set prefixend [lindex $prefendstack end]
1248 set prefendstack [lreplace $prefendstack end end]
1249 set prefix [string range $prefix 0 $prefixend]
1251 $w conf -state disabled
1254 proc linetoelt {l} {
1255 global treeheight treecontents
1260 foreach e $treecontents($prefix) {
1265 if {[string index $e end] eq "/"} {
1266 set n $treeheight($prefix$e)
1278 proc highlight_tree {y prefix} {
1279 global treeheight treecontents cflist
1281 foreach e $treecontents($prefix) {
1283 if {[highlight_tag $path] ne {}} {
1284 $cflist tag add bold $y.0 "$y.0 lineend"
1287 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1288 set y [highlight_tree $y $path]
1294 proc treeclosedir {w dir} {
1295 global treediropen treeheight treeparent treeindex
1297 set ix $treeindex($dir)
1298 $w conf -state normal
1299 $w delete s:$ix e:$ix
1300 set treediropen($dir) 0
1301 $w image configure a:$ix -image tri-rt
1302 $w conf -state disabled
1303 set n [expr {1 - $treeheight($dir)}]
1304 while {$dir ne {}} {
1305 incr treeheight($dir) $n
1306 set dir $treeparent($dir)
1310 proc treeopendir {w dir} {
1311 global treediropen treeheight treeparent treecontents treeindex
1313 set ix $treeindex($dir)
1314 $w conf -state normal
1315 $w image configure a:$ix -image tri-dn
1316 $w mark set e:$ix s:$ix
1317 $w mark gravity e:$ix right
1320 set n [llength $treecontents($dir)]
1321 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1324 incr treeheight($x) $n
1326 foreach e $treecontents($dir) {
1328 if {[string index $e end] eq "/"} {
1329 set iy $treeindex($de)
1330 $w mark set d:$iy e:$ix
1331 $w mark gravity d:$iy left
1332 $w insert e:$ix $str
1333 set treediropen($de) 0
1334 $w image create e:$ix -align center -image tri-rt -padx 1 \
1336 $w insert e:$ix $e [highlight_tag $de]
1337 $w mark set s:$iy e:$ix
1338 $w mark gravity s:$iy left
1339 set treeheight($de) 1
1341 $w insert e:$ix $str
1342 $w insert e:$ix $e [highlight_tag $de]
1345 $w mark gravity e:$ix left
1346 $w conf -state disabled
1347 set treediropen($dir) 1
1348 set top [lindex [split [$w index @0,0] .] 0]
1349 set ht [$w cget -height]
1350 set l [lindex [split [$w index s:$ix] .] 0]
1353 } elseif {$l + $n + 1 > $top + $ht} {
1354 set top [expr {$l + $n + 2 - $ht}]
1362 proc treeclick {w x y} {
1363 global treediropen cmitmode ctext cflist cflist_top
1365 if {$cmitmode ne "tree"} return
1366 if {![info exists cflist_top]} return
1367 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1368 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1369 $cflist tag add highlight $l.0 "$l.0 lineend"
1375 set e [linetoelt $l]
1376 if {[string index $e end] ne "/"} {
1378 } elseif {$treediropen($e)} {
1385 proc setfilelist {id} {
1386 global treefilelist cflist
1388 treeview $cflist $treefilelist($id) 0
1391 image create bitmap tri-rt -background black -foreground blue -data {
1392 #define tri-rt_width 13
1393 #define tri-rt_height 13
1394 static unsigned char tri-rt_bits[] = {
1395 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1396 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1399 #define tri-rt-mask_width 13
1400 #define tri-rt-mask_height 13
1401 static unsigned char tri-rt-mask_bits[] = {
1402 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1403 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1406 image create bitmap tri-dn -background black -foreground blue -data {
1407 #define tri-dn_width 13
1408 #define tri-dn_height 13
1409 static unsigned char tri-dn_bits[] = {
1410 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1411 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1414 #define tri-dn-mask_width 13
1415 #define tri-dn-mask_height 13
1416 static unsigned char tri-dn-mask_bits[] = {
1417 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1418 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1422 proc init_flist {first} {
1423 global cflist cflist_top selectedline difffilestart
1425 $cflist conf -state normal
1426 $cflist delete 0.0 end
1428 $cflist insert end $first
1430 $cflist tag add highlight 1.0 "1.0 lineend"
1432 catch {unset cflist_top}
1434 $cflist conf -state disabled
1435 set difffilestart {}
1438 proc highlight_tag {f} {
1439 global highlight_paths
1441 foreach p $highlight_paths {
1442 if {[string match $p $f]} {
1449 proc highlight_filelist {} {
1450 global cmitmode cflist
1452 $cflist conf -state normal
1453 if {$cmitmode ne "tree"} {
1454 set end [lindex [split [$cflist index end] .] 0]
1455 for {set l 2} {$l < $end} {incr l} {
1456 set line [$cflist get $l.0 "$l.0 lineend"]
1457 if {[highlight_tag $line] ne {}} {
1458 $cflist tag add bold $l.0 "$l.0 lineend"
1464 $cflist conf -state disabled
1467 proc unhighlight_filelist {} {
1470 $cflist conf -state normal
1471 $cflist tag remove bold 1.0 end
1472 $cflist conf -state disabled
1475 proc add_flist {fl} {
1478 $cflist conf -state normal
1480 $cflist insert end "\n"
1481 $cflist insert end $f [highlight_tag $f]
1483 $cflist conf -state disabled
1486 proc sel_flist {w x y} {
1487 global ctext difffilestart cflist cflist_top cmitmode
1489 if {$cmitmode eq "tree"} return
1490 if {![info exists cflist_top]} return
1491 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1492 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1493 $cflist tag add highlight $l.0 "$l.0 lineend"
1498 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1502 # Functions for adding and removing shell-type quoting
1504 proc shellquote {str} {
1505 if {![string match "*\['\"\\ \t]*" $str]} {
1508 if {![string match "*\['\"\\]*" $str]} {
1511 if {![string match "*'*" $str]} {
1514 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1517 proc shellarglist {l} {
1523 append str [shellquote $a]
1528 proc shelldequote {str} {
1533 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1534 append ret [string range $str $used end]
1535 set used [string length $str]
1538 set first [lindex $first 0]
1539 set ch [string index $str $first]
1540 if {$first > $used} {
1541 append ret [string range $str $used [expr {$first - 1}]]
1544 if {$ch eq " " || $ch eq "\t"} break
1547 set first [string first "'" $str $used]
1549 error "unmatched single-quote"
1551 append ret [string range $str $used [expr {$first - 1}]]
1556 if {$used >= [string length $str]} {
1557 error "trailing backslash"
1559 append ret [string index $str $used]
1564 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1565 error "unmatched double-quote"
1567 set first [lindex $first 0]
1568 set ch [string index $str $first]
1569 if {$first > $used} {
1570 append ret [string range $str $used [expr {$first - 1}]]
1573 if {$ch eq "\""} break
1575 append ret [string index $str $used]
1579 return [list $used $ret]
1582 proc shellsplit {str} {
1585 set str [string trimleft $str]
1586 if {$str eq {}} break
1587 set dq [shelldequote $str]
1588 set n [lindex $dq 0]
1589 set word [lindex $dq 1]
1590 set str [string range $str $n end]
1596 # Code to implement multiple views
1598 proc newview {ishighlight} {
1599 global nextviewnum newviewname newviewperm uifont newishighlight
1600 global newviewargs revtreeargs
1602 set newishighlight $ishighlight
1604 if {[winfo exists $top]} {
1608 set newviewname($nextviewnum) "View $nextviewnum"
1609 set newviewperm($nextviewnum) 0
1610 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1611 vieweditor $top $nextviewnum "Gitk view definition"
1616 global viewname viewperm newviewname newviewperm
1617 global viewargs newviewargs
1619 set top .gitkvedit-$curview
1620 if {[winfo exists $top]} {
1624 set newviewname($curview) $viewname($curview)
1625 set newviewperm($curview) $viewperm($curview)
1626 set newviewargs($curview) [shellarglist $viewargs($curview)]
1627 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1630 proc vieweditor {top n title} {
1631 global newviewname newviewperm viewfiles
1635 wm title $top $title
1636 label $top.nl -text "Name" -font $uifont
1637 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1638 grid $top.nl $top.name -sticky w -pady 5
1639 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1641 grid $top.perm - -pady 5 -sticky w
1642 message $top.al -aspect 1000 -font $uifont \
1643 -text "Commits to include (arguments to git rev-list):"
1644 grid $top.al - -sticky w -pady 5
1645 entry $top.args -width 50 -textvariable newviewargs($n) \
1646 -background white -font $uifont
1647 grid $top.args - -sticky ew -padx 5
1648 message $top.l -aspect 1000 -font $uifont \
1649 -text "Enter files and directories to include, one per line:"
1650 grid $top.l - -sticky w
1651 text $top.t -width 40 -height 10 -background white -font $uifont
1652 if {[info exists viewfiles($n)]} {
1653 foreach f $viewfiles($n) {
1654 $top.t insert end $f
1655 $top.t insert end "\n"
1657 $top.t delete {end - 1c} end
1658 $top.t mark set insert 0.0
1660 grid $top.t - -sticky ew -padx 5
1662 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1664 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1666 grid $top.buts.ok $top.buts.can
1667 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1668 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1669 grid $top.buts - -pady 10 -sticky ew
1673 proc doviewmenu {m first cmd op argv} {
1674 set nmenu [$m index end]
1675 for {set i $first} {$i <= $nmenu} {incr i} {
1676 if {[$m entrycget $i -command] eq $cmd} {
1677 eval $m $op $i $argv
1683 proc allviewmenus {n op args} {
1686 doviewmenu .bar.view 5 [list showview $n] $op $args
1687 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1690 proc newviewok {top n} {
1691 global nextviewnum newviewperm newviewname newishighlight
1692 global viewname viewfiles viewperm selectedview curview
1693 global viewargs newviewargs viewhlmenu
1696 set newargs [shellsplit $newviewargs($n)]
1698 error_popup "Error in commit selection arguments: $err"
1704 foreach f [split [$top.t get 0.0 end] "\n"] {
1705 set ft [string trim $f]
1710 if {![info exists viewfiles($n)]} {
1711 # creating a new view
1713 set viewname($n) $newviewname($n)
1714 set viewperm($n) $newviewperm($n)
1715 set viewfiles($n) $files
1716 set viewargs($n) $newargs
1718 if {!$newishighlight} {
1721 run addvhighlight $n
1724 # editing an existing view
1725 set viewperm($n) $newviewperm($n)
1726 if {$newviewname($n) ne $viewname($n)} {
1727 set viewname($n) $newviewname($n)
1728 doviewmenu .bar.view 5 [list showview $n] \
1729 entryconf [list -label $viewname($n)]
1730 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1731 entryconf [list -label $viewname($n) -value $viewname($n)]
1733 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1734 set viewfiles($n) $files
1735 set viewargs($n) $newargs
1736 if {$curview == $n} {
1741 catch {destroy $top}
1745 global curview viewdata viewperm hlview selectedhlview
1747 if {$curview == 0} return
1748 if {[info exists hlview] && $hlview == $curview} {
1749 set selectedhlview None
1752 allviewmenus $curview delete
1753 set viewdata($curview) {}
1754 set viewperm($curview) 0
1758 proc addviewmenu {n} {
1759 global viewname viewhlmenu
1761 .bar.view add radiobutton -label $viewname($n) \
1762 -command [list showview $n] -variable selectedview -value $n
1763 $viewhlmenu add radiobutton -label $viewname($n) \
1764 -command [list addvhighlight $n] -variable selectedhlview
1767 proc flatten {var} {
1771 foreach i [array names $var] {
1772 lappend ret $i [set $var\($i\)]
1777 proc unflatten {var l} {
1787 global curview viewdata viewfiles
1788 global displayorder parentlist rowidlist rowoffsets
1789 global colormap rowtextx commitrow nextcolor canvxmax
1790 global numcommits rowrangelist commitlisted idrowranges rowchk
1791 global selectedline currentid canv canvy0
1793 global pending_select phase
1794 global commitidx rowlaidout rowoptim
1796 global selectedview selectfirst
1797 global vparentlist vdisporder vcmitlisted
1798 global hlview selectedhlview
1800 if {$n == $curview} return
1802 if {[info exists selectedline]} {
1803 set selid $currentid
1804 set y [yc $selectedline]
1805 set ymax [lindex [$canv cget -scrollregion] 3]
1806 set span [$canv yview]
1807 set ytop [expr {[lindex $span 0] * $ymax}]
1808 set ybot [expr {[lindex $span 1] * $ymax}]
1809 if {$ytop < $y && $y < $ybot} {
1810 set yscreen [expr {$y - $ytop}]
1812 set yscreen [expr {($ybot - $ytop) / 2}]
1814 } elseif {[info exists pending_select]} {
1815 set selid $pending_select
1816 unset pending_select
1820 if {$curview >= 0} {
1821 set vparentlist($curview) $parentlist
1822 set vdisporder($curview) $displayorder
1823 set vcmitlisted($curview) $commitlisted
1825 set viewdata($curview) \
1826 [list $phase $rowidlist $rowoffsets $rowrangelist \
1827 [flatten idrowranges] [flatten idinlist] \
1828 $rowlaidout $rowoptim $numcommits]
1829 } elseif {![info exists viewdata($curview)]
1830 || [lindex $viewdata($curview) 0] ne {}} {
1831 set viewdata($curview) \
1832 [list {} $rowidlist $rowoffsets $rowrangelist]
1835 catch {unset treediffs}
1837 if {[info exists hlview] && $hlview == $n} {
1839 set selectedhlview None
1844 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1845 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1847 if {![info exists viewdata($n)]} {
1849 set pending_select $selid
1856 set phase [lindex $v 0]
1857 set displayorder $vdisporder($n)
1858 set parentlist $vparentlist($n)
1859 set commitlisted $vcmitlisted($n)
1860 set rowidlist [lindex $v 1]
1861 set rowoffsets [lindex $v 2]
1862 set rowrangelist [lindex $v 3]
1864 set numcommits [llength $displayorder]
1865 catch {unset idrowranges}
1867 unflatten idrowranges [lindex $v 4]
1868 unflatten idinlist [lindex $v 5]
1869 set rowlaidout [lindex $v 6]
1870 set rowoptim [lindex $v 7]
1871 set numcommits [lindex $v 8]
1872 catch {unset rowchk}
1875 catch {unset colormap}
1876 catch {unset rowtextx}
1878 set canvxmax [$canv cget -width]
1885 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1886 set row $commitrow($n,$selid)
1887 # try to get the selected row in the same position on the screen
1888 set ymax [lindex [$canv cget -scrollregion] 3]
1889 set ytop [expr {[yc $row] - $yscreen}]
1893 set yf [expr {$ytop * 1.0 / $ymax}]
1895 allcanvs yview moveto $yf
1899 } elseif {$selid ne {}} {
1900 set pending_select $selid
1902 set row [first_real_row]
1903 if {$row < $numcommits} {
1910 if {$phase eq "getcommits"} {
1911 show_status "Reading commits..."
1914 } elseif {$numcommits == 0} {
1915 show_status "No commits selected"
1919 # Stuff relating to the highlighting facility
1921 proc ishighlighted {row} {
1922 global vhighlights fhighlights nhighlights rhighlights
1924 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1925 return $nhighlights($row)
1927 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1928 return $vhighlights($row)
1930 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1931 return $fhighlights($row)
1933 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1934 return $rhighlights($row)
1939 proc bolden {row font} {
1940 global canv linehtag selectedline boldrows
1942 lappend boldrows $row
1943 $canv itemconf $linehtag($row) -font $font
1944 if {[info exists selectedline] && $row == $selectedline} {
1946 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1947 -outline {{}} -tags secsel \
1948 -fill [$canv cget -selectbackground]]
1953 proc bolden_name {row font} {
1954 global canv2 linentag selectedline boldnamerows
1956 lappend boldnamerows $row
1957 $canv2 itemconf $linentag($row) -font $font
1958 if {[info exists selectedline] && $row == $selectedline} {
1959 $canv2 delete secsel
1960 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1961 -outline {{}} -tags secsel \
1962 -fill [$canv2 cget -selectbackground]]
1968 global mainfont boldrows
1971 foreach row $boldrows {
1972 if {![ishighlighted $row]} {
1973 bolden $row $mainfont
1975 lappend stillbold $row
1978 set boldrows $stillbold
1981 proc addvhighlight {n} {
1982 global hlview curview viewdata vhl_done vhighlights commitidx
1984 if {[info exists hlview]} {
1988 if {$n != $curview && ![info exists viewdata($n)]} {
1989 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1990 set vparentlist($n) {}
1991 set vdisporder($n) {}
1992 set vcmitlisted($n) {}
1995 set vhl_done $commitidx($hlview)
1996 if {$vhl_done > 0} {
2001 proc delvhighlight {} {
2002 global hlview vhighlights
2004 if {![info exists hlview]} return
2006 catch {unset vhighlights}
2010 proc vhighlightmore {} {
2011 global hlview vhl_done commitidx vhighlights
2012 global displayorder vdisporder curview mainfont
2014 set font [concat $mainfont bold]
2015 set max $commitidx($hlview)
2016 if {$hlview == $curview} {
2017 set disp $displayorder
2019 set disp $vdisporder($hlview)
2021 set vr [visiblerows]
2022 set r0 [lindex $vr 0]
2023 set r1 [lindex $vr 1]
2024 for {set i $vhl_done} {$i < $max} {incr i} {
2025 set id [lindex $disp $i]
2026 if {[info exists commitrow($curview,$id)]} {
2027 set row $commitrow($curview,$id)
2028 if {$r0 <= $row && $row <= $r1} {
2029 if {![highlighted $row]} {
2032 set vhighlights($row) 1
2039 proc askvhighlight {row id} {
2040 global hlview vhighlights commitrow iddrawn mainfont
2042 if {[info exists commitrow($hlview,$id)]} {
2043 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2044 bolden $row [concat $mainfont bold]
2046 set vhighlights($row) 1
2048 set vhighlights($row) 0
2052 proc hfiles_change {name ix op} {
2053 global highlight_files filehighlight fhighlights fh_serial
2054 global mainfont highlight_paths
2056 if {[info exists filehighlight]} {
2057 # delete previous highlights
2058 catch {close $filehighlight}
2060 catch {unset fhighlights}
2062 unhighlight_filelist
2064 set highlight_paths {}
2065 after cancel do_file_hl $fh_serial
2067 if {$highlight_files ne {}} {
2068 after 300 do_file_hl $fh_serial
2072 proc makepatterns {l} {
2075 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2076 if {[string index $ee end] eq "/"} {
2086 proc do_file_hl {serial} {
2087 global highlight_files filehighlight highlight_paths gdttype fhl_list
2089 if {$gdttype eq "touching paths:"} {
2090 if {[catch {set paths [shellsplit $highlight_files]}]} return
2091 set highlight_paths [makepatterns $paths]
2093 set gdtargs [concat -- $paths]
2095 set gdtargs [list "-S$highlight_files"]
2097 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2098 set filehighlight [open $cmd r+]
2099 fconfigure $filehighlight -blocking 0
2100 filerun $filehighlight readfhighlight
2106 proc flushhighlights {} {
2107 global filehighlight fhl_list
2109 if {[info exists filehighlight]} {
2111 puts $filehighlight ""
2112 flush $filehighlight
2116 proc askfilehighlight {row id} {
2117 global filehighlight fhighlights fhl_list
2119 lappend fhl_list $id
2120 set fhighlights($row) -1
2121 puts $filehighlight $id
2124 proc readfhighlight {} {
2125 global filehighlight fhighlights commitrow curview mainfont iddrawn
2128 if {![info exists filehighlight]} {
2132 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2133 set line [string trim $line]
2134 set i [lsearch -exact $fhl_list $line]
2135 if {$i < 0} continue
2136 for {set j 0} {$j < $i} {incr j} {
2137 set id [lindex $fhl_list $j]
2138 if {[info exists commitrow($curview,$id)]} {
2139 set fhighlights($commitrow($curview,$id)) 0
2142 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2143 if {$line eq {}} continue
2144 if {![info exists commitrow($curview,$line)]} continue
2145 set row $commitrow($curview,$line)
2146 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2147 bolden $row [concat $mainfont bold]
2149 set fhighlights($row) 1
2151 if {[eof $filehighlight]} {
2153 puts "oops, git diff-tree died"
2154 catch {close $filehighlight}
2162 proc find_change {name ix op} {
2163 global nhighlights mainfont boldnamerows
2164 global findstring findpattern findtype
2166 # delete previous highlights, if any
2167 foreach row $boldnamerows {
2168 bolden_name $row $mainfont
2171 catch {unset nhighlights}
2174 if {$findtype ne "Regexp"} {
2175 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2177 set findpattern "*$e*"
2182 proc doesmatch {f} {
2183 global findtype findstring findpattern
2185 if {$findtype eq "Regexp"} {
2186 return [regexp $findstring $f]
2187 } elseif {$findtype eq "IgnCase"} {
2188 return [string match -nocase $findpattern $f]
2190 return [string match $findpattern $f]
2194 proc askfindhighlight {row id} {
2195 global nhighlights commitinfo iddrawn mainfont
2197 global markingmatches
2199 if {![info exists commitinfo($id)]} {
2202 set info $commitinfo($id)
2204 set fldtypes {Headline Author Date Committer CDate Comments}
2205 foreach f $info ty $fldtypes {
2206 if {($findloc eq "All fields" || $findloc eq $ty) &&
2208 if {$ty eq "Author"} {
2215 if {$isbold && [info exists iddrawn($id)]} {
2216 set f [concat $mainfont bold]
2217 if {![ishighlighted $row]} {
2223 if {$markingmatches} {
2224 markrowmatches $row $id
2227 set nhighlights($row) $isbold
2230 proc markrowmatches {row id} {
2231 global canv canv2 linehtag linentag commitinfo findloc
2233 set headline [lindex $commitinfo($id) 0]
2234 set author [lindex $commitinfo($id) 1]
2235 $canv delete match$row
2236 $canv2 delete match$row
2237 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2238 set m [findmatches $headline]
2240 markmatches $canv $row $headline $linehtag($row) $m \
2241 [$canv itemcget $linehtag($row) -font] $row
2244 if {$findloc eq "All fields" || $findloc eq "Author"} {
2245 set m [findmatches $author]
2247 markmatches $canv2 $row $author $linentag($row) $m \
2248 [$canv2 itemcget $linentag($row) -font] $row
2253 proc vrel_change {name ix op} {
2254 global highlight_related
2257 if {$highlight_related ne "None"} {
2262 # prepare for testing whether commits are descendents or ancestors of a
2263 proc rhighlight_sel {a} {
2264 global descendent desc_todo ancestor anc_todo
2265 global highlight_related rhighlights
2267 catch {unset descendent}
2268 set desc_todo [list $a]
2269 catch {unset ancestor}
2270 set anc_todo [list $a]
2271 if {$highlight_related ne "None"} {
2277 proc rhighlight_none {} {
2280 catch {unset rhighlights}
2284 proc is_descendent {a} {
2285 global curview children commitrow descendent desc_todo
2288 set la $commitrow($v,$a)
2292 for {set i 0} {$i < [llength $todo]} {incr i} {
2293 set do [lindex $todo $i]
2294 if {$commitrow($v,$do) < $la} {
2295 lappend leftover $do
2298 foreach nk $children($v,$do) {
2299 if {![info exists descendent($nk)]} {
2300 set descendent($nk) 1
2308 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2312 set descendent($a) 0
2313 set desc_todo $leftover
2316 proc is_ancestor {a} {
2317 global curview parentlist commitrow ancestor anc_todo
2320 set la $commitrow($v,$a)
2324 for {set i 0} {$i < [llength $todo]} {incr i} {
2325 set do [lindex $todo $i]
2326 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2327 lappend leftover $do
2330 foreach np [lindex $parentlist $commitrow($v,$do)] {
2331 if {![info exists ancestor($np)]} {
2340 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2345 set anc_todo $leftover
2348 proc askrelhighlight {row id} {
2349 global descendent highlight_related iddrawn mainfont rhighlights
2350 global selectedline ancestor
2352 if {![info exists selectedline]} return
2354 if {$highlight_related eq "Descendent" ||
2355 $highlight_related eq "Not descendent"} {
2356 if {![info exists descendent($id)]} {
2359 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2362 } elseif {$highlight_related eq "Ancestor" ||
2363 $highlight_related eq "Not ancestor"} {
2364 if {![info exists ancestor($id)]} {
2367 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2371 if {[info exists iddrawn($id)]} {
2372 if {$isbold && ![ishighlighted $row]} {
2373 bolden $row [concat $mainfont bold]
2376 set rhighlights($row) $isbold
2379 proc next_hlcont {} {
2380 global fhl_row fhl_dirn displayorder numcommits
2381 global vhighlights fhighlights nhighlights rhighlights
2382 global hlview filehighlight findstring highlight_related
2384 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2387 if {$row < 0 || $row >= $numcommits} {
2392 set id [lindex $displayorder $row]
2393 if {[info exists hlview]} {
2394 if {![info exists vhighlights($row)]} {
2395 askvhighlight $row $id
2397 if {$vhighlights($row) > 0} break
2399 if {$findstring ne {}} {
2400 if {![info exists nhighlights($row)]} {
2401 askfindhighlight $row $id
2403 if {$nhighlights($row) > 0} break
2405 if {$highlight_related ne "None"} {
2406 if {![info exists rhighlights($row)]} {
2407 askrelhighlight $row $id
2409 if {$rhighlights($row) > 0} break
2411 if {[info exists filehighlight]} {
2412 if {![info exists fhighlights($row)]} {
2413 # ask for a few more while we're at it...
2415 for {set n 0} {$n < 100} {incr n} {
2416 if {![info exists fhighlights($r)]} {
2417 askfilehighlight $r [lindex $displayorder $r]
2420 if {$r < 0 || $r >= $numcommits} break
2424 if {$fhighlights($row) < 0} {
2428 if {$fhighlights($row) > 0} break
2436 proc next_highlight {dirn} {
2437 global selectedline fhl_row fhl_dirn
2438 global hlview filehighlight findstring highlight_related
2440 if {![info exists selectedline]} return
2441 if {!([info exists hlview] || $findstring ne {} ||
2442 $highlight_related ne "None" || [info exists filehighlight])} return
2443 set fhl_row [expr {$selectedline + $dirn}]
2448 proc cancel_next_highlight {} {
2454 # Graph layout functions
2456 proc shortids {ids} {
2459 if {[llength $id] > 1} {
2460 lappend res [shortids $id]
2461 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2462 lappend res [string range $id 0 7]
2470 proc incrange {l x o} {
2473 set e [lindex $l $x]
2475 lset l $x [expr {$e + $o}]
2484 for {} {$n > 0} {incr n -1} {
2490 proc usedinrange {id l1 l2} {
2491 global children commitrow curview
2493 if {[info exists commitrow($curview,$id)]} {
2494 set r $commitrow($curview,$id)
2495 if {$l1 <= $r && $r <= $l2} {
2496 return [expr {$r - $l1 + 1}]
2499 set kids $children($curview,$id)
2501 set r $commitrow($curview,$c)
2502 if {$l1 <= $r && $r <= $l2} {
2503 return [expr {$r - $l1 + 1}]
2509 proc sanity {row {full 0}} {
2510 global rowidlist rowoffsets
2513 set ids [lindex $rowidlist $row]
2516 if {$id eq {}} continue
2517 if {$col < [llength $ids] - 1 &&
2518 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2519 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2521 set o [lindex $rowoffsets $row $col]
2527 if {[lindex $rowidlist $y $x] != $id} {
2528 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2529 puts " id=[shortids $id] check started at row $row"
2530 for {set i $row} {$i >= $y} {incr i -1} {
2531 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2536 set o [lindex $rowoffsets $y $x]
2541 proc makeuparrow {oid x y z} {
2542 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2544 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2547 set off0 [lindex $rowoffsets $y]
2548 for {set x0 $x} {1} {incr x0} {
2549 if {$x0 >= [llength $off0]} {
2550 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2553 set z [lindex $off0 $x0]
2559 set z [expr {$x0 - $x}]
2560 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2561 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2563 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2564 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2565 lappend idrowranges($oid) [lindex $displayorder $y]
2568 proc initlayout {} {
2569 global rowidlist rowoffsets displayorder commitlisted
2570 global rowlaidout rowoptim
2571 global idinlist rowchk rowrangelist idrowranges
2572 global numcommits canvxmax canv
2575 global colormap rowtextx
2586 catch {unset idinlist}
2587 catch {unset rowchk}
2590 set canvxmax [$canv cget -width]
2591 catch {unset colormap}
2592 catch {unset rowtextx}
2593 catch {unset idrowranges}
2597 proc setcanvscroll {} {
2598 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2600 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2601 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2602 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2603 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2606 proc visiblerows {} {
2607 global canv numcommits linespc
2609 set ymax [lindex [$canv cget -scrollregion] 3]
2610 if {$ymax eq {} || $ymax == 0} return
2612 set y0 [expr {int([lindex $f 0] * $ymax)}]
2613 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2617 set y1 [expr {int([lindex $f 1] * $ymax)}]
2618 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2619 if {$r1 >= $numcommits} {
2620 set r1 [expr {$numcommits - 1}]
2622 return [list $r0 $r1]
2625 proc layoutmore {tmax allread} {
2626 global rowlaidout rowoptim commitidx numcommits optim_delay
2627 global uparrowlen curview rowidlist idinlist
2630 set showdelay $optim_delay
2631 set optdelay [expr {$uparrowlen + 1}]
2633 if {$rowoptim - $showdelay > $numcommits} {
2634 showstuff [expr {$rowoptim - $showdelay}] $showlast
2635 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2636 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2640 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2642 } elseif {$commitidx($curview) > $rowlaidout} {
2643 set nr [expr {$commitidx($curview) - $rowlaidout}]
2644 # may need to increase this threshold if uparrowlen or
2645 # mingaplen are increased...
2650 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2651 if {$rowlaidout == $row} {
2654 } elseif {$allread} {
2656 set nrows $commitidx($curview)
2657 if {[lindex $rowidlist $nrows] ne {} ||
2658 [array names idinlist] ne {}} {
2660 set rowlaidout $commitidx($curview)
2661 } elseif {$rowoptim == $nrows} {
2664 if {$numcommits == $nrows} {
2671 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2677 proc showstuff {canshow last} {
2678 global numcommits commitrow pending_select selectedline curview
2679 global lookingforhead mainheadid displayorder selectfirst
2680 global lastscrollset
2682 if {$numcommits == 0} {
2684 set phase "incrdraw"
2688 set prev $numcommits
2689 set numcommits $canshow
2690 set t [clock clicks -milliseconds]
2691 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2692 set lastscrollset $t
2695 set rows [visiblerows]
2696 set r1 [lindex $rows 1]
2697 if {$r1 >= $canshow} {
2698 set r1 [expr {$canshow - 1}]
2703 if {[info exists pending_select] &&
2704 [info exists commitrow($curview,$pending_select)] &&
2705 $commitrow($curview,$pending_select) < $numcommits} {
2706 selectline $commitrow($curview,$pending_select) 1
2709 if {[info exists selectedline] || [info exists pending_select]} {
2712 set l [first_real_row]
2717 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2718 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2719 set lookingforhead 0
2724 proc doshowlocalchanges {} {
2725 global lookingforhead curview mainheadid phase commitrow
2727 if {[info exists commitrow($curview,$mainheadid)] &&
2728 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2730 } elseif {$phase ne {}} {
2731 set lookingforhead 1
2735 proc dohidelocalchanges {} {
2736 global lookingforhead localfrow localirow lserial
2738 set lookingforhead 0
2739 if {$localfrow >= 0} {
2740 removerow $localfrow
2742 if {$localirow > 0} {
2746 if {$localirow >= 0} {
2747 removerow $localirow
2753 # spawn off a process to do git diff-index --cached HEAD
2754 proc dodiffindex {} {
2755 global localirow localfrow lserial
2760 set fd [open "|git diff-index --cached HEAD" r]
2761 fconfigure $fd -blocking 0
2762 filerun $fd [list readdiffindex $fd $lserial]
2765 proc readdiffindex {fd serial} {
2766 global localirow commitrow mainheadid nullid2 curview
2767 global commitinfo commitdata lserial
2770 if {[gets $fd line] < 0} {
2776 # we only need to see one line and we don't really care what it says...
2779 # now see if there are any local changes not checked in to the index
2780 if {$serial == $lserial} {
2781 set fd [open "|git diff-files" r]
2782 fconfigure $fd -blocking 0
2783 filerun $fd [list readdifffiles $fd $serial]
2786 if {$isdiff && $serial == $lserial && $localirow == -1} {
2787 # add the line for the changes in the index to the graph
2788 set localirow $commitrow($curview,$mainheadid)
2789 set hl "Local changes checked in to index but not committed"
2790 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2791 set commitdata($nullid2) "\n $hl\n"
2792 insertrow $localirow $nullid2
2797 proc readdifffiles {fd serial} {
2798 global localirow localfrow commitrow mainheadid nullid curview
2799 global commitinfo commitdata lserial
2802 if {[gets $fd line] < 0} {
2808 # we only need to see one line and we don't really care what it says...
2811 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2812 # add the line for the local diff to the graph
2813 if {$localirow >= 0} {
2814 set localfrow $localirow
2817 set localfrow $commitrow($curview,$mainheadid)
2819 set hl "Local uncommitted changes, not checked in to index"
2820 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2821 set commitdata($nullid) "\n $hl\n"
2822 insertrow $localfrow $nullid
2827 proc layoutrows {row endrow last} {
2828 global rowidlist rowoffsets displayorder
2829 global uparrowlen downarrowlen maxwidth mingaplen
2830 global children parentlist
2832 global commitidx curview
2833 global idinlist rowchk rowrangelist
2835 set idlist [lindex $rowidlist $row]
2836 set offs [lindex $rowoffsets $row]
2837 while {$row < $endrow} {
2838 set id [lindex $displayorder $row]
2841 foreach p [lindex $parentlist $row] {
2842 if {![info exists idinlist($p)]} {
2844 } elseif {!$idinlist($p)} {
2848 set nev [expr {[llength $idlist] + [llength $newolds]
2849 + [llength $oldolds] - $maxwidth + 1}]
2852 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2853 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2854 set i [lindex $idlist $x]
2855 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2856 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2857 [expr {$row + $uparrowlen + $mingaplen}]]
2859 set idlist [lreplace $idlist $x $x]
2860 set offs [lreplace $offs $x $x]
2861 set offs [incrange $offs $x 1]
2863 set rm1 [expr {$row - 1}]
2864 lappend idrowranges($i) [lindex $displayorder $rm1]
2865 if {[incr nev -1] <= 0} break
2868 set rowchk($id) [expr {$row + $r}]
2871 lset rowidlist $row $idlist
2872 lset rowoffsets $row $offs
2874 set col [lsearch -exact $idlist $id]
2876 set col [llength $idlist]
2878 lset rowidlist $row $idlist
2880 if {$children($curview,$id) ne {}} {
2881 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2885 lset rowoffsets $row $offs
2887 makeuparrow $id $col $row $z
2893 if {[info exists idrowranges($id)]} {
2894 set ranges $idrowranges($id)
2896 unset idrowranges($id)
2898 lappend rowrangelist $ranges
2900 set offs [ntimes [llength $idlist] 0]
2901 set l [llength $newolds]
2902 set idlist [eval lreplace \$idlist $col $col $newolds]
2905 set offs [lrange $offs 0 [expr {$col - 1}]]
2906 foreach x $newolds {
2911 set tmp [expr {[llength $idlist] - [llength $offs]}]
2913 set offs [concat $offs [ntimes $tmp $o]]
2918 foreach i $newolds {
2920 set idrowranges($i) $id
2923 foreach oid $oldolds {
2924 set idinlist($oid) 1
2925 set idlist [linsert $idlist $col $oid]
2926 set offs [linsert $offs $col $o]
2927 makeuparrow $oid $col $row $o
2930 lappend rowidlist $idlist
2931 lappend rowoffsets $offs
2936 proc addextraid {id row} {
2937 global displayorder commitrow commitinfo
2938 global commitidx commitlisted
2939 global parentlist children curview
2941 incr commitidx($curview)
2942 lappend displayorder $id
2943 lappend commitlisted 0
2944 lappend parentlist {}
2945 set commitrow($curview,$id) $row
2947 if {![info exists commitinfo($id)]} {
2948 set commitinfo($id) {"No commit information available"}
2950 if {![info exists children($curview,$id)]} {
2951 set children($curview,$id) {}
2955 proc layouttail {} {
2956 global rowidlist rowoffsets idinlist commitidx curview
2957 global idrowranges rowrangelist
2959 set row $commitidx($curview)
2960 set idlist [lindex $rowidlist $row]
2961 while {$idlist ne {}} {
2962 set col [expr {[llength $idlist] - 1}]
2963 set id [lindex $idlist $col]
2966 lappend idrowranges($id) $id
2967 lappend rowrangelist $idrowranges($id)
2968 unset idrowranges($id)
2970 set offs [ntimes $col 0]
2971 set idlist [lreplace $idlist $col $col]
2972 lappend rowidlist $idlist
2973 lappend rowoffsets $offs
2976 foreach id [array names idinlist] {
2979 lset rowidlist $row [list $id]
2980 lset rowoffsets $row 0
2981 makeuparrow $id 0 $row 0
2982 lappend idrowranges($id) $id
2983 lappend rowrangelist $idrowranges($id)
2984 unset idrowranges($id)
2986 lappend rowidlist {}
2987 lappend rowoffsets {}
2991 proc insert_pad {row col npad} {
2992 global rowidlist rowoffsets
2994 set pad [ntimes $npad {}]
2995 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2996 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2997 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
3000 proc optimize_rows {row col endrow} {
3001 global rowidlist rowoffsets displayorder
3003 for {} {$row < $endrow} {incr row} {
3004 set idlist [lindex $rowidlist $row]
3005 set offs [lindex $rowoffsets $row]
3007 for {} {$col < [llength $offs]} {incr col} {
3008 if {[lindex $idlist $col] eq {}} {
3012 set z [lindex $offs $col]
3013 if {$z eq {}} continue
3015 set x0 [expr {$col + $z}]
3016 set y0 [expr {$row - 1}]
3017 set z0 [lindex $rowoffsets $y0 $x0]
3019 set id [lindex $idlist $col]
3020 set ranges [rowranges $id]
3021 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3025 # Looking at lines from this row to the previous row,
3026 # make them go straight up if they end in an arrow on
3027 # the previous row; otherwise make them go straight up
3029 if {$z < -1 || ($z < 0 && $isarrow)} {
3030 # Line currently goes left too much;
3031 # insert pads in the previous row, then optimize it
3032 set npad [expr {-1 - $z + $isarrow}]
3033 set offs [incrange $offs $col $npad]
3034 insert_pad $y0 $x0 $npad
3036 optimize_rows $y0 $x0 $row
3038 set z [lindex $offs $col]
3039 set x0 [expr {$col + $z}]
3040 set z0 [lindex $rowoffsets $y0 $x0]
3041 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3042 # Line currently goes right too much;
3043 # insert pads in this line and adjust the next's rowoffsets
3044 set npad [expr {$z - 1 + $isarrow}]
3045 set y1 [expr {$row + 1}]
3046 set offs2 [lindex $rowoffsets $y1]
3050 if {$z eq {} || $x1 + $z < $col} continue
3051 if {$x1 + $z > $col} {
3054 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3057 set pad [ntimes $npad {}]
3058 set idlist [eval linsert \$idlist $col $pad]
3059 set tmp [eval linsert \$offs $col $pad]
3061 set offs [incrange $tmp $col [expr {-$npad}]]
3062 set z [lindex $offs $col]
3065 if {$z0 eq {} && !$isarrow} {
3066 # this line links to its first child on row $row-2
3067 set rm2 [expr {$row - 2}]
3068 set id [lindex $displayorder $rm2]
3069 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3071 set z0 [expr {$xc - $x0}]
3074 # avoid lines jigging left then immediately right
3075 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3076 insert_pad $y0 $x0 1
3077 set offs [incrange $offs $col 1]
3078 optimize_rows $y0 [expr {$x0 + 1}] $row
3083 # Find the first column that doesn't have a line going right
3084 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3085 set o [lindex $offs $col]
3087 # check if this is the link to the first child
3088 set id [lindex $idlist $col]
3089 set ranges [rowranges $id]
3090 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3091 # it is, work out offset to child
3092 set y0 [expr {$row - 1}]
3093 set id [lindex $displayorder $y0]
3094 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3096 set o [expr {$x0 - $col}]
3100 if {$o eq {} || $o <= 0} break
3102 # Insert a pad at that column as long as it has a line and
3103 # isn't the last column, and adjust the next row' offsets
3104 if {$o ne {} && [incr col] < [llength $idlist]} {
3105 set y1 [expr {$row + 1}]
3106 set offs2 [lindex $rowoffsets $y1]
3110 if {$z eq {} || $x1 + $z < $col} continue
3111 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3114 set idlist [linsert $idlist $col {}]
3115 set tmp [linsert $offs $col {}]
3117 set offs [incrange $tmp $col -1]
3120 lset rowidlist $row $idlist
3121 lset rowoffsets $row $offs
3127 global canvx0 linespc
3128 return [expr {$canvx0 + $col * $linespc}]
3132 global canvy0 linespc
3133 return [expr {$canvy0 + $row * $linespc}]
3136 proc linewidth {id} {
3137 global thickerline lthickness
3140 if {[info exists thickerline] && $id eq $thickerline} {
3141 set wid [expr {2 * $lthickness}]
3146 proc rowranges {id} {
3147 global phase idrowranges commitrow rowlaidout rowrangelist curview
3151 ([info exists commitrow($curview,$id)]
3152 && $commitrow($curview,$id) < $rowlaidout)} {
3153 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3154 } elseif {[info exists idrowranges($id)]} {
3155 set ranges $idrowranges($id)
3158 foreach rid $ranges {
3159 lappend linenos $commitrow($curview,$rid)
3161 if {$linenos ne {}} {
3162 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3167 # work around tk8.4 refusal to draw arrows on diagonal segments
3168 proc adjarrowhigh {coords} {
3171 set x0 [lindex $coords 0]
3172 set x1 [lindex $coords 2]
3174 set y0 [lindex $coords 1]
3175 set y1 [lindex $coords 3]
3176 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3177 # we have a nearby vertical segment, just trim off the diag bit
3178 set coords [lrange $coords 2 end]
3180 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3181 set xi [expr {$x0 - $slope * $linespc / 2}]
3182 set yi [expr {$y0 - $linespc / 2}]
3183 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3189 proc drawlineseg {id row endrow arrowlow} {
3190 global rowidlist displayorder iddrawn linesegs
3191 global canv colormap linespc curview maxlinelen
3193 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3194 set le [expr {$row + 1}]
3197 set c [lsearch -exact [lindex $rowidlist $le] $id]
3203 set x [lindex $displayorder $le]
3208 if {[info exists iddrawn($x)] || $le == $endrow} {
3209 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3225 if {[info exists linesegs($id)]} {
3226 set lines $linesegs($id)
3228 set r0 [lindex $li 0]
3230 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3240 set li [lindex $lines [expr {$i-1}]]
3241 set r1 [lindex $li 1]
3242 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3247 set x [lindex $cols [expr {$le - $row}]]
3248 set xp [lindex $cols [expr {$le - 1 - $row}]]
3249 set dir [expr {$xp - $x}]
3251 set ith [lindex $lines $i 2]
3252 set coords [$canv coords $ith]
3253 set ah [$canv itemcget $ith -arrow]
3254 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3255 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3256 if {$x2 ne {} && $x - $x2 == $dir} {
3257 set coords [lrange $coords 0 end-2]
3260 set coords [list [xc $le $x] [yc $le]]
3263 set itl [lindex $lines [expr {$i-1}] 2]
3264 set al [$canv itemcget $itl -arrow]
3265 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3266 } elseif {$arrowlow &&
3267 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3270 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3271 for {set y $le} {[incr y -1] > $row} {} {
3273 set xp [lindex $cols [expr {$y - 1 - $row}]]
3274 set ndir [expr {$xp - $x}]
3275 if {$dir != $ndir || $xp < 0} {
3276 lappend coords [xc $y $x] [yc $y]
3282 # join parent line to first child
3283 set ch [lindex $displayorder $row]
3284 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3286 puts "oops: drawlineseg: child $ch not on row $row"
3289 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3290 } elseif {$xc > $x + 1} {
3291 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3295 lappend coords [xc $row $x] [yc $row]
3297 set xn [xc $row $xp]
3299 # work around tk8.4 refusal to draw arrows on diagonal segments
3300 if {$arrowlow && $xn != [lindex $coords end-1]} {
3301 if {[llength $coords] < 4 ||
3302 [lindex $coords end-3] != [lindex $coords end-1] ||
3303 [lindex $coords end] - $yn > 2 * $linespc} {
3304 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3305 set yo [yc [expr {$row + 0.5}]]
3306 lappend coords $xn $yo $xn $yn
3309 lappend coords $xn $yn
3314 set coords [adjarrowhigh $coords]
3317 set t [$canv create line $coords -width [linewidth $id] \
3318 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3321 set lines [linsert $lines $i [list $row $le $t]]
3323 $canv coords $ith $coords
3324 if {$arrow ne $ah} {
3325 $canv itemconf $ith -arrow $arrow
3327 lset lines $i 0 $row
3330 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3331 set ndir [expr {$xo - $xp}]
3332 set clow [$canv coords $itl]
3333 if {$dir == $ndir} {
3334 set clow [lrange $clow 2 end]
3336 set coords [concat $coords $clow]
3338 lset lines [expr {$i-1}] 1 $le
3340 set coords [adjarrowhigh $coords]
3343 # coalesce two pieces
3345 set b [lindex $lines [expr {$i-1}] 0]
3346 set e [lindex $lines $i 1]
3347 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3349 $canv coords $itl $coords
3350 if {$arrow ne $al} {
3351 $canv itemconf $itl -arrow $arrow
3355 set linesegs($id) $lines
3359 proc drawparentlinks {id row} {
3360 global rowidlist canv colormap curview parentlist
3363 set rowids [lindex $rowidlist $row]
3364 set col [lsearch -exact $rowids $id]
3365 if {$col < 0} return
3366 set olds [lindex $parentlist $row]
3367 set row2 [expr {$row + 1}]
3368 set x [xc $row $col]
3371 set ids [lindex $rowidlist $row2]
3372 # rmx = right-most X coord used
3375 set i [lsearch -exact $ids $p]
3377 puts "oops, parent $p of $id not in list"
3380 set x2 [xc $row2 $i]
3384 if {[lsearch -exact $rowids $p] < 0} {
3385 # drawlineseg will do this one for us
3389 # should handle duplicated parents here...
3390 set coords [list $x $y]
3391 if {$i < $col - 1} {
3392 lappend coords [xc $row [expr {$i + 1}]] $y
3393 } elseif {$i > $col + 1} {
3394 lappend coords [xc $row [expr {$i - 1}]] $y
3396 lappend coords $x2 $y2
3397 set t [$canv create line $coords -width [linewidth $p] \
3398 -fill $colormap($p) -tags lines.$p]
3402 if {$rmx > [lindex $idpos($id) 1]} {
3403 lset idpos($id) 1 $rmx
3408 proc drawlines {id} {
3411 $canv itemconf lines.$id -width [linewidth $id]
3414 proc drawcmittext {id row col} {
3415 global linespc canv canv2 canv3 canvy0 fgcolor curview
3416 global commitlisted commitinfo rowidlist parentlist
3417 global rowtextx idpos idtags idheads idotherrefs
3418 global linehtag linentag linedtag
3419 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3421 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3422 set listed [lindex $commitlisted $row]
3423 if {$id eq $nullid} {
3425 } elseif {$id eq $nullid2} {
3428 set ofill [expr {$listed != 0? "blue": "white"}]
3430 set x [xc $row $col]
3432 set orad [expr {$linespc / 3}]
3434 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3435 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3436 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3437 } elseif {$listed == 2} {
3438 # triangle pointing left for left-side commits
3439 set t [$canv create polygon \
3440 [expr {$x - $orad}] $y \
3441 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3442 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3443 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3445 # triangle pointing right for right-side commits
3446 set t [$canv create polygon \
3447 [expr {$x + $orad - 1}] $y \
3448 [expr {$x - $orad}] [expr {$y - $orad}] \
3449 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3450 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3453 $canv bind $t <1> {selcanvline {} %x %y}
3454 set rmx [llength [lindex $rowidlist $row]]
3455 set olds [lindex $parentlist $row]
3457 set nextids [lindex $rowidlist [expr {$row + 1}]]
3459 set i [lsearch -exact $nextids $p]
3465 set xt [xc $row $rmx]
3466 set rowtextx($row) $xt
3467 set idpos($id) [list $x $xt $y]
3468 if {[info exists idtags($id)] || [info exists idheads($id)]
3469 || [info exists idotherrefs($id)]} {
3470 set xt [drawtags $id $x $xt $y]
3472 set headline [lindex $commitinfo($id) 0]
3473 set name [lindex $commitinfo($id) 1]
3474 set date [lindex $commitinfo($id) 2]
3475 set date [formatdate $date]
3478 set isbold [ishighlighted $row]
3480 lappend boldrows $row
3483 lappend boldnamerows $row
3487 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3488 -text $headline -font $font -tags text]
3489 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3490 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3491 -text $name -font $nfont -tags text]
3492 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3493 -text $date -font $mainfont -tags text]
3494 set xr [expr {$xt + [font measure $mainfont $headline]}]
3495 if {$xr > $canvxmax} {
3501 proc drawcmitrow {row} {
3502 global displayorder rowidlist
3503 global iddrawn markingmatches
3504 global commitinfo parentlist numcommits
3505 global filehighlight fhighlights findstring nhighlights
3506 global hlview vhighlights
3507 global highlight_related rhighlights
3509 if {$row >= $numcommits} return
3511 set id [lindex $displayorder $row]
3512 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3513 askvhighlight $row $id
3515 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3516 askfilehighlight $row $id
3518 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3519 askfindhighlight $row $id
3521 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3522 askrelhighlight $row $id
3524 if {![info exists iddrawn($id)]} {
3525 set col [lsearch -exact [lindex $rowidlist $row] $id]
3527 puts "oops, row $row id $id not in list"
3530 if {![info exists commitinfo($id)]} {
3534 drawcmittext $id $row $col
3537 if {$markingmatches} {
3538 markrowmatches $row $id
3542 proc drawcommits {row {endrow {}}} {
3543 global numcommits iddrawn displayorder curview
3544 global parentlist rowidlist
3549 if {$endrow eq {}} {
3552 if {$endrow >= $numcommits} {
3553 set endrow [expr {$numcommits - 1}]
3556 # make the lines join to already-drawn rows either side
3557 set r [expr {$row - 1}]
3558 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3561 set er [expr {$endrow + 1}]
3562 if {$er >= $numcommits ||
3563 ![info exists iddrawn([lindex $displayorder $er])]} {
3566 for {} {$r <= $er} {incr r} {
3567 set id [lindex $displayorder $r]
3568 set wasdrawn [info exists iddrawn($id)]
3570 if {$r == $er} break
3571 set nextid [lindex $displayorder [expr {$r + 1}]]
3572 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3573 catch {unset prevlines}
3576 drawparentlinks $id $r
3578 if {[info exists lineends($r)]} {
3579 foreach lid $lineends($r) {
3580 unset prevlines($lid)
3583 set rowids [lindex $rowidlist $r]
3584 foreach lid $rowids {
3585 if {$lid eq {}} continue
3587 # see if this is the first child of any of its parents
3588 foreach p [lindex $parentlist $r] {
3589 if {[lsearch -exact $rowids $p] < 0} {
3590 # make this line extend up to the child
3591 set le [drawlineseg $p $r $er 0]
3592 lappend lineends($le) $p
3596 } elseif {![info exists prevlines($lid)]} {
3597 set le [drawlineseg $lid $r $er 1]
3598 lappend lineends($le) $lid
3599 set prevlines($lid) 1
3605 proc drawfrac {f0 f1} {
3608 set ymax [lindex [$canv cget -scrollregion] 3]
3609 if {$ymax eq {} || $ymax == 0} return
3610 set y0 [expr {int($f0 * $ymax)}]
3611 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3612 set y1 [expr {int($f1 * $ymax)}]
3613 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3614 drawcommits $row $endrow
3617 proc drawvisible {} {
3619 eval drawfrac [$canv yview]
3622 proc clear_display {} {
3623 global iddrawn linesegs
3624 global vhighlights fhighlights nhighlights rhighlights
3627 catch {unset iddrawn}
3628 catch {unset linesegs}
3629 catch {unset vhighlights}
3630 catch {unset fhighlights}
3631 catch {unset nhighlights}
3632 catch {unset rhighlights}
3635 proc findcrossings {id} {
3636 global rowidlist parentlist numcommits rowoffsets displayorder
3640 foreach {s e} [rowranges $id] {
3641 if {$e >= $numcommits} {
3642 set e [expr {$numcommits - 1}]
3644 if {$e <= $s} continue
3645 set x [lsearch -exact [lindex $rowidlist $e] $id]
3647 puts "findcrossings: oops, no [shortids $id] in row $e"
3650 for {set row $e} {[incr row -1] >= $s} {} {
3651 set olds [lindex $parentlist $row]
3652 set kid [lindex $displayorder $row]
3653 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3654 if {$kidx < 0} continue
3655 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3657 set px [lsearch -exact $nextrow $p]
3658 if {$px < 0} continue
3659 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3660 if {[lsearch -exact $ccross $p] >= 0} continue
3661 if {$x == $px + ($kidx < $px? -1: 1)} {
3663 } elseif {[lsearch -exact $cross $p] < 0} {
3668 set inc [lindex $rowoffsets $row $x]
3669 if {$inc eq {}} break
3673 return [concat $ccross {{}} $cross]
3676 proc assigncolor {id} {
3677 global colormap colors nextcolor
3678 global commitrow parentlist children children curview
3680 if {[info exists colormap($id)]} return
3681 set ncolors [llength $colors]
3682 if {[info exists children($curview,$id)]} {
3683 set kids $children($curview,$id)
3687 if {[llength $kids] == 1} {
3688 set child [lindex $kids 0]
3689 if {[info exists colormap($child)]
3690 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3691 set colormap($id) $colormap($child)
3697 foreach x [findcrossings $id] {
3699 # delimiter between corner crossings and other crossings
3700 if {[llength $badcolors] >= $ncolors - 1} break
3701 set origbad $badcolors
3703 if {[info exists colormap($x)]
3704 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3705 lappend badcolors $colormap($x)
3708 if {[llength $badcolors] >= $ncolors} {
3709 set badcolors $origbad
3711 set origbad $badcolors
3712 if {[llength $badcolors] < $ncolors - 1} {
3713 foreach child $kids {
3714 if {[info exists colormap($child)]
3715 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3716 lappend badcolors $colormap($child)
3718 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3719 if {[info exists colormap($p)]
3720 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3721 lappend badcolors $colormap($p)
3725 if {[llength $badcolors] >= $ncolors} {
3726 set badcolors $origbad
3729 for {set i 0} {$i <= $ncolors} {incr i} {
3730 set c [lindex $colors $nextcolor]
3731 if {[incr nextcolor] >= $ncolors} {
3734 if {[lsearch -exact $badcolors $c]} break
3736 set colormap($id) $c
3739 proc bindline {t id} {
3742 $canv bind $t <Enter> "lineenter %x %y $id"
3743 $canv bind $t <Motion> "linemotion %x %y $id"
3744 $canv bind $t <Leave> "lineleave $id"
3745 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3748 proc drawtags {id x xt y1} {
3749 global idtags idheads idotherrefs mainhead
3750 global linespc lthickness
3751 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3756 if {[info exists idtags($id)]} {
3757 set marks $idtags($id)
3758 set ntags [llength $marks]
3760 if {[info exists idheads($id)]} {
3761 set marks [concat $marks $idheads($id)]
3762 set nheads [llength $idheads($id)]
3764 if {[info exists idotherrefs($id)]} {
3765 set marks [concat $marks $idotherrefs($id)]
3771 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3772 set yt [expr {$y1 - 0.5 * $linespc}]
3773 set yb [expr {$yt + $linespc - 1}]
3777 foreach tag $marks {
3779 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3780 set wid [font measure [concat $mainfont bold] $tag]
3782 set wid [font measure $mainfont $tag]
3786 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3788 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3789 -width $lthickness -fill black -tags tag.$id]
3791 foreach tag $marks x $xvals wid $wvals {
3792 set xl [expr {$x + $delta}]
3793 set xr [expr {$x + $delta + $wid + $lthickness}]
3795 if {[incr ntags -1] >= 0} {
3797 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3798 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3799 -width 1 -outline black -fill yellow -tags tag.$id]
3800 $canv bind $t <1> [list showtag $tag 1]
3801 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3803 # draw a head or other ref
3804 if {[incr nheads -1] >= 0} {
3806 if {$tag eq $mainhead} {
3812 set xl [expr {$xl - $delta/2}]
3813 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3814 -width 1 -outline black -fill $col -tags tag.$id
3815 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3816 set rwid [font measure $mainfont $remoteprefix]
3817 set xi [expr {$x + 1}]
3818 set yti [expr {$yt + 1}]
3819 set xri [expr {$x + $rwid}]
3820 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3821 -width 0 -fill "#ffddaa" -tags tag.$id
3824 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3825 -font $font -tags [list tag.$id text]]
3827 $canv bind $t <1> [list showtag $tag 1]
3828 } elseif {$nheads >= 0} {
3829 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3835 proc xcoord {i level ln} {
3836 global canvx0 xspc1 xspc2
3838 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3839 if {$i > 0 && $i == $level} {
3840 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3841 } elseif {$i > $level} {
3842 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3847 proc show_status {msg} {
3848 global canv mainfont fgcolor
3851 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3852 -tags text -fill $fgcolor
3855 # Insert a new commit as the child of the commit on row $row.
3856 # The new commit will be displayed on row $row and the commits
3857 # on that row and below will move down one row.
3858 proc insertrow {row newcmit} {
3859 global displayorder parentlist commitlisted children
3860 global commitrow curview rowidlist rowoffsets numcommits
3861 global rowrangelist rowlaidout rowoptim numcommits
3862 global selectedline rowchk commitidx
3864 if {$row >= $numcommits} {
3865 puts "oops, inserting new row $row but only have $numcommits rows"
3868 set p [lindex $displayorder $row]
3869 set displayorder [linsert $displayorder $row $newcmit]
3870 set parentlist [linsert $parentlist $row $p]
3871 set kids $children($curview,$p)
3872 lappend kids $newcmit
3873 set children($curview,$p) $kids
3874 set children($curview,$newcmit) {}
3875 set commitlisted [linsert $commitlisted $row 1]
3876 set l [llength $displayorder]
3877 for {set r $row} {$r < $l} {incr r} {
3878 set id [lindex $displayorder $r]
3879 set commitrow($curview,$id) $r
3881 incr commitidx($curview)
3883 set idlist [lindex $rowidlist $row]
3884 set offs [lindex $rowoffsets $row]
3887 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3893 if {[llength $kids] == 1} {
3894 set col [lsearch -exact $idlist $p]
3895 lset idlist $col $newcmit
3897 set col [llength $idlist]
3898 lappend idlist $newcmit
3900 lset rowoffsets $row $offs
3902 set rowidlist [linsert $rowidlist $row $idlist]
3903 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3905 set rowrangelist [linsert $rowrangelist $row {}]
3906 if {[llength $kids] > 1} {
3907 set rp1 [expr {$row + 1}]
3908 set ranges [lindex $rowrangelist $rp1]
3909 if {$ranges eq {}} {
3910 set ranges [list $newcmit $p]
3911 } elseif {[lindex $ranges end-1] eq $p} {
3912 lset ranges end-1 $newcmit
3914 lset rowrangelist $rp1 $ranges
3917 catch {unset rowchk}
3923 if {[info exists selectedline] && $selectedline >= $row} {
3929 # Remove a commit that was inserted with insertrow on row $row.
3930 proc removerow {row} {
3931 global displayorder parentlist commitlisted children
3932 global commitrow curview rowidlist rowoffsets numcommits
3933 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3934 global linesegends selectedline rowchk commitidx
3936 if {$row >= $numcommits} {
3937 puts "oops, removing row $row but only have $numcommits rows"
3940 set rp1 [expr {$row + 1}]
3941 set id [lindex $displayorder $row]
3942 set p [lindex $parentlist $row]
3943 set displayorder [lreplace $displayorder $row $row]
3944 set parentlist [lreplace $parentlist $row $row]
3945 set commitlisted [lreplace $commitlisted $row $row]
3946 set kids $children($curview,$p)
3947 set i [lsearch -exact $kids $id]
3949 set kids [lreplace $kids $i $i]
3950 set children($curview,$p) $kids
3952 set l [llength $displayorder]
3953 for {set r $row} {$r < $l} {incr r} {
3954 set id [lindex $displayorder $r]
3955 set commitrow($curview,$id) $r
3957 incr commitidx($curview) -1
3959 set rowidlist [lreplace $rowidlist $row $row]
3960 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3962 set offs [lindex $rowoffsets $row]
3963 set offs [lreplace $offs end end]
3964 lset rowoffsets $row $offs
3967 set rowrangelist [lreplace $rowrangelist $row $row]
3968 if {[llength $kids] > 0} {
3969 set ranges [lindex $rowrangelist $row]
3970 if {[lindex $ranges end-1] eq $id} {
3971 set ranges [lreplace $ranges end-1 end]
3972 lset rowrangelist $row $ranges
3976 catch {unset rowchk}
3982 if {[info exists selectedline] && $selectedline > $row} {
3983 incr selectedline -1
3988 # Don't change the text pane cursor if it is currently the hand cursor,
3989 # showing that we are over a sha1 ID link.
3990 proc settextcursor {c} {
3991 global ctext curtextcursor
3993 if {[$ctext cget -cursor] == $curtextcursor} {
3994 $ctext config -cursor $c
3996 set curtextcursor $c
3999 proc nowbusy {what} {
4002 if {[array names isbusy] eq {}} {
4003 . config -cursor watch
4009 proc notbusy {what} {
4010 global isbusy maincursor textcursor
4012 catch {unset isbusy($what)}
4013 if {[array names isbusy] eq {}} {
4014 . config -cursor $maincursor
4015 settextcursor $textcursor
4019 proc findmatches {f} {
4020 global findtype findstring
4021 if {$findtype == "Regexp"} {
4022 set matches [regexp -indices -all -inline $findstring $f]
4025 if {$findtype == "IgnCase"} {
4026 set f [string tolower $f]
4027 set fs [string tolower $fs]
4031 set l [string length $fs]
4032 while {[set j [string first $fs $f $i]] >= 0} {
4033 lappend matches [list $j [expr {$j+$l-1}]]
4034 set i [expr {$j + $l}]
4040 proc dofind {{rev 0}} {
4041 global findstring findstartline findcurline selectedline numcommits
4044 cancel_next_highlight
4046 if {$findstring eq {} || $numcommits == 0} return
4047 if {![info exists selectedline]} {
4048 set findstartline [lindex [visiblerows] $rev]
4050 set findstartline $selectedline
4052 set findcurline $findstartline
4057 if {$findcurline == 0} {
4058 set findcurline $numcommits
4065 proc findnext {restart} {
4067 if {![info exists findcurline]} {
4081 if {![info exists findcurline]} {
4090 global commitdata commitinfo numcommits findstring findpattern findloc
4091 global findstartline findcurline displayorder
4093 set fldtypes {Headline Author Date Committer CDate Comments}
4094 set l [expr {$findcurline + 1}]
4095 if {$l >= $numcommits} {
4098 if {$l <= $findstartline} {
4099 set lim [expr {$findstartline + 1}]
4103 if {$lim - $l > 500} {
4104 set lim [expr {$l + 500}]
4107 for {} {$l < $lim} {incr l} {
4108 set id [lindex $displayorder $l]
4109 # shouldn't happen unless git log doesn't give all the commits...
4110 if {![info exists commitdata($id)]} continue
4111 if {![doesmatch $commitdata($id)]} continue
4112 if {![info exists commitinfo($id)]} {
4115 set info $commitinfo($id)
4116 foreach f $info ty $fldtypes {
4117 if {($findloc eq "All fields" || $findloc eq $ty) &&
4125 if {$l == $findstartline + 1} {
4131 set findcurline [expr {$l - 1}]
4135 proc findmorerev {} {
4136 global commitdata commitinfo numcommits findstring findpattern findloc
4137 global findstartline findcurline displayorder
4139 set fldtypes {Headline Author Date Committer CDate Comments}
4145 if {$l >= $findstartline} {
4146 set lim [expr {$findstartline - 1}]
4150 if {$l - $lim > 500} {
4151 set lim [expr {$l - 500}]
4154 for {} {$l > $lim} {incr l -1} {
4155 set id [lindex $displayorder $l]
4156 if {![doesmatch $commitdata($id)]} continue
4157 if {![info exists commitinfo($id)]} {
4160 set info $commitinfo($id)
4161 foreach f $info ty $fldtypes {
4162 if {($findloc eq "All fields" || $findloc eq $ty) &&
4176 set findcurline [expr {$l + 1}]
4180 proc findselectline {l} {
4181 global findloc commentend ctext findcurline markingmatches
4183 set markingmatches 1
4186 if {$findloc == "All fields" || $findloc == "Comments"} {
4187 # highlight the matches in the comments
4188 set f [$ctext get 1.0 $commentend]
4189 set matches [findmatches $f]
4190 foreach match $matches {
4191 set start [lindex $match 0]
4192 set end [expr {[lindex $match 1] + 1}]
4193 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4199 # mark the bits of a headline or author that match a find string
4200 proc markmatches {canv l str tag matches font row} {
4203 set bbox [$canv bbox $tag]
4204 set x0 [lindex $bbox 0]
4205 set y0 [lindex $bbox 1]
4206 set y1 [lindex $bbox 3]
4207 foreach match $matches {
4208 set start [lindex $match 0]
4209 set end [lindex $match 1]
4210 if {$start > $end} continue
4211 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4212 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4213 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4214 [expr {$x0+$xlen+2}] $y1 \
4215 -outline {} -tags [list match$l matches] -fill yellow]
4217 if {[info exists selectedline] && $row == $selectedline} {
4218 $canv raise $t secsel
4223 proc unmarkmatches {} {
4224 global findids markingmatches findcurline
4226 allcanvs delete matches
4227 catch {unset findids}
4228 set markingmatches 0
4229 catch {unset findcurline}
4232 proc selcanvline {w x y} {
4233 global canv canvy0 ctext linespc
4235 set ymax [lindex [$canv cget -scrollregion] 3]
4236 if {$ymax == {}} return
4237 set yfrac [lindex [$canv yview] 0]
4238 set y [expr {$y + $yfrac * $ymax}]
4239 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4244 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4250 proc commit_descriptor {p} {
4252 if {![info exists commitinfo($p)]} {
4256 if {[llength $commitinfo($p)] > 1} {
4257 set l [lindex $commitinfo($p) 0]
4262 # append some text to the ctext widget, and make any SHA1 ID
4263 # that we know about be a clickable link.
4264 proc appendwithlinks {text tags} {
4265 global ctext commitrow linknum curview
4267 set start [$ctext index "end - 1c"]
4268 $ctext insert end $text $tags
4269 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4273 set linkid [string range $text $s $e]
4274 if {![info exists commitrow($curview,$linkid)]} continue
4276 $ctext tag add link "$start + $s c" "$start + $e c"
4277 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4278 $ctext tag bind link$linknum <1> \
4279 [list selectline $commitrow($curview,$linkid) 1]
4282 $ctext tag conf link -foreground blue -underline 1
4283 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4284 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4287 proc viewnextline {dir} {
4291 set ymax [lindex [$canv cget -scrollregion] 3]
4292 set wnow [$canv yview]
4293 set wtop [expr {[lindex $wnow 0] * $ymax}]
4294 set newtop [expr {$wtop + $dir * $linespc}]
4297 } elseif {$newtop > $ymax} {
4300 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4303 # add a list of tag or branch names at position pos
4304 # returns the number of names inserted
4305 proc appendrefs {pos ids var} {
4306 global ctext commitrow linknum curview $var maxrefs
4308 if {[catch {$ctext index $pos}]} {
4311 $ctext conf -state normal
4312 $ctext delete $pos "$pos lineend"
4315 foreach tag [set $var\($id\)] {
4316 lappend tags [list $tag $id]
4319 if {[llength $tags] > $maxrefs} {
4320 $ctext insert $pos "many ([llength $tags])"
4322 set tags [lsort -index 0 -decreasing $tags]
4325 set id [lindex $ti 1]
4328 $ctext tag delete $lk
4329 $ctext insert $pos $sep
4330 $ctext insert $pos [lindex $ti 0] $lk
4331 if {[info exists commitrow($curview,$id)]} {
4332 $ctext tag conf $lk -foreground blue
4333 $ctext tag bind $lk <1> \
4334 [list selectline $commitrow($curview,$id) 1]
4335 $ctext tag conf $lk -underline 1
4336 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4337 $ctext tag bind $lk <Leave> \
4338 { %W configure -cursor $curtextcursor }
4343 $ctext conf -state disabled
4344 return [llength $tags]
4347 # called when we have finished computing the nearby tags
4348 proc dispneartags {delay} {
4349 global selectedline currentid showneartags tagphase
4351 if {![info exists selectedline] || !$showneartags} return
4352 after cancel dispnexttag
4354 after 200 dispnexttag
4357 after idle dispnexttag
4362 proc dispnexttag {} {
4363 global selectedline currentid showneartags tagphase ctext
4365 if {![info exists selectedline] || !$showneartags} return
4366 switch -- $tagphase {
4368 set dtags [desctags $currentid]
4370 appendrefs precedes $dtags idtags
4374 set atags [anctags $currentid]
4376 appendrefs follows $atags idtags
4380 set dheads [descheads $currentid]
4381 if {$dheads ne {}} {
4382 if {[appendrefs branch $dheads idheads] > 1
4383 && [$ctext get "branch -3c"] eq "h"} {
4384 # turn "Branch" into "Branches"
4385 $ctext conf -state normal
4386 $ctext insert "branch -2c" "es"
4387 $ctext conf -state disabled
4392 if {[incr tagphase] <= 2} {
4393 after idle dispnexttag
4397 proc selectline {l isnew} {
4398 global canv canv2 canv3 ctext commitinfo selectedline
4399 global displayorder linehtag linentag linedtag
4400 global canvy0 linespc parentlist children curview
4401 global currentid sha1entry
4402 global commentend idtags linknum
4403 global mergemax numcommits pending_select
4404 global cmitmode showneartags allcommits
4406 catch {unset pending_select}
4409 cancel_next_highlight
4410 if {$l < 0 || $l >= $numcommits} return
4411 set y [expr {$canvy0 + $l * $linespc}]
4412 set ymax [lindex [$canv cget -scrollregion] 3]
4413 set ytop [expr {$y - $linespc - 1}]
4414 set ybot [expr {$y + $linespc + 1}]
4415 set wnow [$canv yview]
4416 set wtop [expr {[lindex $wnow 0] * $ymax}]
4417 set wbot [expr {[lindex $wnow 1] * $ymax}]
4418 set wh [expr {$wbot - $wtop}]
4420 if {$ytop < $wtop} {
4421 if {$ybot < $wtop} {
4422 set newtop [expr {$y - $wh / 2.0}]
4425 if {$newtop > $wtop - $linespc} {
4426 set newtop [expr {$wtop - $linespc}]
4429 } elseif {$ybot > $wbot} {
4430 if {$ytop > $wbot} {
4431 set newtop [expr {$y - $wh / 2.0}]
4433 set newtop [expr {$ybot - $wh}]
4434 if {$newtop < $wtop + $linespc} {
4435 set newtop [expr {$wtop + $linespc}]
4439 if {$newtop != $wtop} {
4443 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4447 if {![info exists linehtag($l)]} return
4449 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4450 -tags secsel -fill [$canv cget -selectbackground]]
4452 $canv2 delete secsel
4453 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4454 -tags secsel -fill [$canv2 cget -selectbackground]]
4456 $canv3 delete secsel
4457 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4458 -tags secsel -fill [$canv3 cget -selectbackground]]
4462 addtohistory [list selectline $l 0]
4467 set id [lindex $displayorder $l]
4469 $sha1entry delete 0 end
4470 $sha1entry insert 0 $id
4471 $sha1entry selection from 0
4472 $sha1entry selection to end
4475 $ctext conf -state normal
4478 set info $commitinfo($id)
4479 set date [formatdate [lindex $info 2]]
4480 $ctext insert end "Author: [lindex $info 1] $date\n"
4481 set date [formatdate [lindex $info 4]]
4482 $ctext insert end "Committer: [lindex $info 3] $date\n"
4483 if {[info exists idtags($id)]} {
4484 $ctext insert end "Tags:"
4485 foreach tag $idtags($id) {
4486 $ctext insert end " $tag"
4488 $ctext insert end "\n"
4492 set olds [lindex $parentlist $l]
4493 if {[llength $olds] > 1} {
4496 if {$np >= $mergemax} {
4501 $ctext insert end "Parent: " $tag
4502 appendwithlinks [commit_descriptor $p] {}
4507 append headers "Parent: [commit_descriptor $p]"
4511 foreach c $children($curview,$id) {
4512 append headers "Child: [commit_descriptor $c]"
4515 # make anything that looks like a SHA1 ID be a clickable link
4516 appendwithlinks $headers {}
4517 if {$showneartags} {
4518 if {![info exists allcommits]} {
4521 $ctext insert end "Branch: "
4522 $ctext mark set branch "end -1c"
4523 $ctext mark gravity branch left
4524 $ctext insert end "\nFollows: "
4525 $ctext mark set follows "end -1c"
4526 $ctext mark gravity follows left
4527 $ctext insert end "\nPrecedes: "
4528 $ctext mark set precedes "end -1c"
4529 $ctext mark gravity precedes left
4530 $ctext insert end "\n"
4533 $ctext insert end "\n"
4534 set comment [lindex $info 5]
4535 if {[string first "\r" $comment] >= 0} {
4536 set comment [string map {"\r" "\n "} $comment]
4538 appendwithlinks $comment {comment}
4540 $ctext tag remove found 1.0 end
4541 $ctext conf -state disabled
4542 set commentend [$ctext index "end - 1c"]
4544 init_flist "Comments"
4545 if {$cmitmode eq "tree"} {
4547 } elseif {[llength $olds] <= 1} {
4554 proc selfirstline {} {
4559 proc sellastline {} {
4562 set l [expr {$numcommits - 1}]
4566 proc selnextline {dir} {
4568 if {![info exists selectedline]} return
4569 set l [expr {$selectedline + $dir}]
4574 proc selnextpage {dir} {
4575 global canv linespc selectedline numcommits
4577 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4581 allcanvs yview scroll [expr {$dir * $lpp}] units
4583 if {![info exists selectedline]} return
4584 set l [expr {$selectedline + $dir * $lpp}]
4587 } elseif {$l >= $numcommits} {
4588 set l [expr $numcommits - 1]
4594 proc unselectline {} {
4595 global selectedline currentid
4597 catch {unset selectedline}
4598 catch {unset currentid}
4599 allcanvs delete secsel
4601 cancel_next_highlight
4604 proc reselectline {} {
4607 if {[info exists selectedline]} {
4608 selectline $selectedline 0
4612 proc addtohistory {cmd} {
4613 global history historyindex curview
4615 set elt [list $curview $cmd]
4616 if {$historyindex > 0
4617 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4621 if {$historyindex < [llength $history]} {
4622 set history [lreplace $history $historyindex end $elt]
4624 lappend history $elt
4627 if {$historyindex > 1} {
4628 .tf.bar.leftbut conf -state normal
4630 .tf.bar.leftbut conf -state disabled
4632 .tf.bar.rightbut conf -state disabled
4638 set view [lindex $elt 0]
4639 set cmd [lindex $elt 1]
4640 if {$curview != $view} {
4647 global history historyindex
4649 if {$historyindex > 1} {
4650 incr historyindex -1
4651 godo [lindex $history [expr {$historyindex - 1}]]
4652 .tf.bar.rightbut conf -state normal
4654 if {$historyindex <= 1} {
4655 .tf.bar.leftbut conf -state disabled
4660 global history historyindex
4662 if {$historyindex < [llength $history]} {
4663 set cmd [lindex $history $historyindex]
4666 .tf.bar.leftbut conf -state normal
4668 if {$historyindex >= [llength $history]} {
4669 .tf.bar.rightbut conf -state disabled
4674 global treefilelist treeidlist diffids diffmergeid treepending
4675 global nullid nullid2
4678 catch {unset diffmergeid}
4679 if {![info exists treefilelist($id)]} {
4680 if {![info exists treepending]} {
4681 if {$id eq $nullid} {
4682 set cmd [list | git ls-files]
4683 } elseif {$id eq $nullid2} {
4684 set cmd [list | git ls-files --stage -t]
4686 set cmd [list | git ls-tree -r $id]
4688 if {[catch {set gtf [open $cmd r]}]} {
4692 set treefilelist($id) {}
4693 set treeidlist($id) {}
4694 fconfigure $gtf -blocking 0
4695 filerun $gtf [list gettreeline $gtf $id]
4702 proc gettreeline {gtf id} {
4703 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4706 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4707 if {$diffids eq $nullid} {
4710 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4711 set i [string first "\t" $line]
4712 if {$i < 0} continue
4713 set sha1 [lindex $line 2]
4714 set fname [string range $line [expr {$i+1}] end]
4715 if {[string index $fname 0] eq "\""} {
4716 set fname [lindex $fname 0]
4718 lappend treeidlist($id) $sha1
4720 lappend treefilelist($id) $fname
4723 return [expr {$nl >= 1000? 2: 1}]
4727 if {$cmitmode ne "tree"} {
4728 if {![info exists diffmergeid]} {
4729 gettreediffs $diffids
4731 } elseif {$id ne $diffids} {
4740 global treefilelist treeidlist diffids nullid nullid2
4741 global ctext commentend
4743 set i [lsearch -exact $treefilelist($diffids) $f]
4745 puts "oops, $f not in list for id $diffids"
4748 if {$diffids eq $nullid} {
4749 if {[catch {set bf [open $f r]} err]} {
4750 puts "oops, can't read $f: $err"
4754 set blob [lindex $treeidlist($diffids) $i]
4755 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4756 puts "oops, error reading blob $blob: $err"
4760 fconfigure $bf -blocking 0
4761 filerun $bf [list getblobline $bf $diffids]
4762 $ctext config -state normal
4763 clear_ctext $commentend
4764 $ctext insert end "\n"
4765 $ctext insert end "$f\n" filesep
4766 $ctext config -state disabled
4767 $ctext yview $commentend
4770 proc getblobline {bf id} {
4771 global diffids cmitmode ctext
4773 if {$id ne $diffids || $cmitmode ne "tree"} {
4777 $ctext config -state normal
4779 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4780 $ctext insert end "$line\n"
4783 # delete last newline
4784 $ctext delete "end - 2c" "end - 1c"
4788 $ctext config -state disabled
4789 return [expr {$nl >= 1000? 2: 1}]
4792 proc mergediff {id l} {
4793 global diffmergeid diffopts mdifffd
4799 # this doesn't seem to actually affect anything...
4800 set env(GIT_DIFF_OPTS) $diffopts
4801 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4802 if {[catch {set mdf [open $cmd r]} err]} {
4803 error_popup "Error getting merge diffs: $err"
4806 fconfigure $mdf -blocking 0
4807 set mdifffd($id) $mdf
4808 set np [llength [lindex $parentlist $l]]
4809 filerun $mdf [list getmergediffline $mdf $id $np]
4812 proc getmergediffline {mdf id np} {
4813 global diffmergeid ctext cflist mergemax
4814 global difffilestart mdifffd
4816 $ctext conf -state normal
4818 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4819 if {![info exists diffmergeid] || $id != $diffmergeid
4820 || $mdf != $mdifffd($id)} {
4824 if {[regexp {^diff --cc (.*)} $line match fname]} {
4825 # start of a new file
4826 $ctext insert end "\n"
4827 set here [$ctext index "end - 1c"]
4828 lappend difffilestart $here
4829 add_flist [list $fname]
4830 set l [expr {(78 - [string length $fname]) / 2}]
4831 set pad [string range "----------------------------------------" 1 $l]
4832 $ctext insert end "$pad $fname $pad\n" filesep
4833 } elseif {[regexp {^@@} $line]} {
4834 $ctext insert end "$line\n" hunksep
4835 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4838 # parse the prefix - one ' ', '-' or '+' for each parent
4843 for {set j 0} {$j < $np} {incr j} {
4844 set c [string range $line $j $j]
4847 } elseif {$c == "-"} {
4849 } elseif {$c == "+"} {
4858 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4859 # line doesn't appear in result, parents in $minuses have the line
4860 set num [lindex $minuses 0]
4861 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4862 # line appears in result, parents in $pluses don't have the line
4863 lappend tags mresult
4864 set num [lindex $spaces 0]
4867 if {$num >= $mergemax} {
4872 $ctext insert end "$line\n" $tags
4875 $ctext conf -state disabled
4880 return [expr {$nr >= 1000? 2: 1}]
4883 proc startdiff {ids} {
4884 global treediffs diffids treepending diffmergeid nullid nullid2
4887 catch {unset diffmergeid}
4888 if {![info exists treediffs($ids)] ||
4889 [lsearch -exact $ids $nullid] >= 0 ||
4890 [lsearch -exact $ids $nullid2] >= 0} {
4891 if {![info exists treepending]} {
4899 proc addtocflist {ids} {
4900 global treediffs cflist
4901 add_flist $treediffs($ids)
4905 proc diffcmd {ids flags} {
4906 global nullid nullid2
4908 set i [lsearch -exact $ids $nullid]
4909 set j [lsearch -exact $ids $nullid2]
4911 if {[llength $ids] > 1 && $j < 0} {
4912 # comparing working directory with some specific revision
4913 set cmd [concat | git diff-index $flags]
4915 lappend cmd -R [lindex $ids 1]
4917 lappend cmd [lindex $ids 0]
4920 # comparing working directory with index
4921 set cmd [concat | git diff-files $flags]
4926 } elseif {$j >= 0} {
4927 set cmd [concat | git diff-index --cached $flags]
4928 if {[llength $ids] > 1} {
4929 # comparing index with specific revision
4931 lappend cmd -R [lindex $ids 1]
4933 lappend cmd [lindex $ids 0]
4936 # comparing index with HEAD
4940 set cmd [concat | git diff-tree -r $flags $ids]
4945 proc gettreediffs {ids} {
4946 global treediff treepending
4948 set treepending $ids
4950 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4951 fconfigure $gdtf -blocking 0
4952 filerun $gdtf [list gettreediffline $gdtf $ids]
4955 proc gettreediffline {gdtf ids} {
4956 global treediff treediffs treepending diffids diffmergeid
4960 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4961 set i [string first "\t" $line]
4963 set file [string range $line [expr {$i+1}] end]
4964 if {[string index $file 0] eq "\""} {
4965 set file [lindex $file 0]
4967 lappend treediff $file
4971 return [expr {$nr >= 1000? 2: 1}]
4974 set treediffs($ids) $treediff
4976 if {$cmitmode eq "tree"} {
4978 } elseif {$ids != $diffids} {
4979 if {![info exists diffmergeid]} {
4980 gettreediffs $diffids
4988 proc getblobdiffs {ids} {
4989 global diffopts blobdifffd diffids env
4990 global diffinhdr treediffs
4992 set env(GIT_DIFF_OPTS) $diffopts
4993 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4994 puts "error getting diffs: $err"
4998 fconfigure $bdf -blocking 0
4999 set blobdifffd($ids) $bdf
5000 filerun $bdf [list getblobdiffline $bdf $diffids]
5003 proc setinlist {var i val} {
5006 while {[llength [set $var]] < $i} {
5009 if {[llength [set $var]] == $i} {
5016 proc makediffhdr {fname ids} {
5017 global ctext curdiffstart treediffs
5019 set i [lsearch -exact $treediffs($ids) $fname]
5021 setinlist difffilestart $i $curdiffstart
5023 set l [expr {(78 - [string length $fname]) / 2}]
5024 set pad [string range "----------------------------------------" 1 $l]
5025 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5028 proc getblobdiffline {bdf ids} {
5029 global diffids blobdifffd ctext curdiffstart
5030 global diffnexthead diffnextnote difffilestart
5031 global diffinhdr treediffs
5034 $ctext conf -state normal
5035 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5036 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5040 if {![string compare -length 11 "diff --git " $line]} {
5041 # trim off "diff --git "
5042 set line [string range $line 11 end]
5044 # start of a new file
5045 $ctext insert end "\n"
5046 set curdiffstart [$ctext index "end - 1c"]
5047 $ctext insert end "\n" filesep
5048 # If the name hasn't changed the length will be odd,
5049 # the middle char will be a space, and the two bits either
5050 # side will be a/name and b/name, or "a/name" and "b/name".
5051 # If the name has changed we'll get "rename from" and
5052 # "rename to" lines following this, and we'll use them
5053 # to get the filenames.
5054 # This complexity is necessary because spaces in the filename(s)
5055 # don't get escaped.
5056 set l [string length $line]
5057 set i [expr {$l / 2}]
5058 if {!(($l & 1) && [string index $line $i] eq " " &&
5059 [string range $line 2 [expr {$i - 1}]] eq \
5060 [string range $line [expr {$i + 3}] end])} {
5063 # unescape if quoted and chop off the a/ from the front
5064 if {[string index $line 0] eq "\""} {
5065 set fname [string range [lindex $line 0] 2 end]
5067 set fname [string range $line 2 [expr {$i - 1}]]
5069 makediffhdr $fname $ids
5071 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5072 $line match f1l f1c f2l f2c rest]} {
5073 $ctext insert end "$line\n" hunksep
5076 } elseif {$diffinhdr} {
5077 if {![string compare -length 12 "rename from " $line]} {
5078 set fname [string range $line 12 end]
5079 if {[string index $fname 0] eq "\""} {
5080 set fname [lindex $fname 0]
5082 set i [lsearch -exact $treediffs($ids) $fname]
5084 setinlist difffilestart $i $curdiffstart
5086 } elseif {![string compare -length 10 $line "rename to "]} {
5087 set fname [string range $line 10 end]
5088 if {[string index $fname 0] eq "\""} {
5089 set fname [lindex $fname 0]
5091 makediffhdr $fname $ids
5092 } elseif {[string compare -length 3 $line "---"] == 0} {
5095 } elseif {[string compare -length 3 $line "+++"] == 0} {
5099 $ctext insert end "$line\n" filesep
5102 set x [string range $line 0 0]
5103 if {$x == "-" || $x == "+"} {
5104 set tag [expr {$x == "+"}]
5105 $ctext insert end "$line\n" d$tag
5106 } elseif {$x == " "} {
5107 $ctext insert end "$line\n"
5109 # "\ No newline at end of file",
5110 # or something else we don't recognize
5111 $ctext insert end "$line\n" hunksep
5115 $ctext conf -state disabled
5120 return [expr {$nr >= 1000? 2: 1}]
5123 proc changediffdisp {} {
5124 global ctext diffelide
5126 $ctext tag conf d0 -elide [lindex $diffelide 0]
5127 $ctext tag conf d1 -elide [lindex $diffelide 1]
5131 global difffilestart ctext
5132 set prev [lindex $difffilestart 0]
5133 set here [$ctext index @0,0]
5134 foreach loc $difffilestart {
5135 if {[$ctext compare $loc >= $here]} {
5145 global difffilestart ctext
5146 set here [$ctext index @0,0]
5147 foreach loc $difffilestart {
5148 if {[$ctext compare $loc > $here]} {
5155 proc clear_ctext {{first 1.0}} {
5156 global ctext smarktop smarkbot
5158 set l [lindex [split $first .] 0]
5159 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5162 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5165 $ctext delete $first end
5168 proc incrsearch {name ix op} {
5169 global ctext searchstring searchdirn
5171 $ctext tag remove found 1.0 end
5172 if {[catch {$ctext index anchor}]} {
5173 # no anchor set, use start of selection, or of visible area
5174 set sel [$ctext tag ranges sel]
5176 $ctext mark set anchor [lindex $sel 0]
5177 } elseif {$searchdirn eq "-forwards"} {
5178 $ctext mark set anchor @0,0
5180 $ctext mark set anchor @0,[winfo height $ctext]
5183 if {$searchstring ne {}} {
5184 set here [$ctext search $searchdirn -- $searchstring anchor]
5193 global sstring ctext searchstring searchdirn
5196 $sstring icursor end
5197 set searchdirn -forwards
5198 if {$searchstring ne {}} {
5199 set sel [$ctext tag ranges sel]
5201 set start "[lindex $sel 0] + 1c"
5202 } elseif {[catch {set start [$ctext index anchor]}]} {
5205 set match [$ctext search -count mlen -- $searchstring $start]
5206 $ctext tag remove sel 1.0 end
5212 set mend "$match + $mlen c"
5213 $ctext tag add sel $match $mend
5214 $ctext mark unset anchor
5218 proc dosearchback {} {
5219 global sstring ctext searchstring searchdirn
5222 $sstring icursor end
5223 set searchdirn -backwards
5224 if {$searchstring ne {}} {
5225 set sel [$ctext tag ranges sel]
5227 set start [lindex $sel 0]
5228 } elseif {[catch {set start [$ctext index anchor]}]} {
5229 set start @0,[winfo height $ctext]
5231 set match [$ctext search -backwards -count ml -- $searchstring $start]
5232 $ctext tag remove sel 1.0 end
5238 set mend "$match + $ml c"
5239 $ctext tag add sel $match $mend
5240 $ctext mark unset anchor
5244 proc searchmark {first last} {
5245 global ctext searchstring
5249 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5250 if {$match eq {}} break
5251 set mend "$match + $mlen c"
5252 $ctext tag add found $match $mend
5256 proc searchmarkvisible {doall} {
5257 global ctext smarktop smarkbot
5259 set topline [lindex [split [$ctext index @0,0] .] 0]
5260 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5261 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5262 # no overlap with previous
5263 searchmark $topline $botline
5264 set smarktop $topline
5265 set smarkbot $botline
5267 if {$topline < $smarktop} {
5268 searchmark $topline [expr {$smarktop-1}]
5269 set smarktop $topline
5271 if {$botline > $smarkbot} {
5272 searchmark [expr {$smarkbot+1}] $botline
5273 set smarkbot $botline
5278 proc scrolltext {f0 f1} {
5281 .bleft.sb set $f0 $f1
5282 if {$searchstring ne {}} {
5288 global linespc charspc canvx0 canvy0 mainfont
5289 global xspc1 xspc2 lthickness
5291 set linespc [font metrics $mainfont -linespace]
5292 set charspc [font measure $mainfont "m"]
5293 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5294 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5295 set lthickness [expr {int($linespc / 9) + 1}]
5296 set xspc1(0) $linespc
5304 set ymax [lindex [$canv cget -scrollregion] 3]
5305 if {$ymax eq {} || $ymax == 0} return
5306 set span [$canv yview]
5309 allcanvs yview moveto [lindex $span 0]
5311 if {[info exists selectedline]} {
5312 selectline $selectedline 0
5313 allcanvs yview moveto [lindex $span 0]
5317 proc incrfont {inc} {
5318 global mainfont textfont ctext canv phase cflist
5319 global charspc tabstop
5320 global stopped entries
5322 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5323 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5325 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5326 $cflist conf -font $textfont
5327 $ctext tag conf filesep -font [concat $textfont bold]
5328 foreach e $entries {
5329 $e conf -font $mainfont
5331 if {$phase eq "getcommits"} {
5332 $canv itemconf textitems -font $mainfont
5338 global sha1entry sha1string
5339 if {[string length $sha1string] == 40} {
5340 $sha1entry delete 0 end
5344 proc sha1change {n1 n2 op} {
5345 global sha1string currentid sha1but
5346 if {$sha1string == {}
5347 || ([info exists currentid] && $sha1string == $currentid)} {
5352 if {[$sha1but cget -state] == $state} return
5353 if {$state == "normal"} {
5354 $sha1but conf -state normal -relief raised -text "Goto: "
5356 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5360 proc gotocommit {} {
5361 global sha1string currentid commitrow tagids headids
5362 global displayorder numcommits curview
5364 if {$sha1string == {}
5365 || ([info exists currentid] && $sha1string == $currentid)} return
5366 if {[info exists tagids($sha1string)]} {
5367 set id $tagids($sha1string)
5368 } elseif {[info exists headids($sha1string)]} {
5369 set id $headids($sha1string)
5371 set id [string tolower $sha1string]
5372 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5374 foreach i $displayorder {
5375 if {[string match $id* $i]} {
5379 if {$matches ne {}} {
5380 if {[llength $matches] > 1} {
5381 error_popup "Short SHA1 id $id is ambiguous"
5384 set id [lindex $matches 0]
5388 if {[info exists commitrow($curview,$id)]} {
5389 selectline $commitrow($curview,$id) 1
5392 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5397 error_popup "$type $sha1string is not known"
5400 proc lineenter {x y id} {
5401 global hoverx hovery hoverid hovertimer
5402 global commitinfo canv
5404 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5408 if {[info exists hovertimer]} {
5409 after cancel $hovertimer
5411 set hovertimer [after 500 linehover]
5415 proc linemotion {x y id} {
5416 global hoverx hovery hoverid hovertimer
5418 if {[info exists hoverid] && $id == $hoverid} {
5421 if {[info exists hovertimer]} {
5422 after cancel $hovertimer
5424 set hovertimer [after 500 linehover]
5428 proc lineleave {id} {
5429 global hoverid hovertimer canv
5431 if {[info exists hoverid] && $id == $hoverid} {
5433 if {[info exists hovertimer]} {
5434 after cancel $hovertimer
5442 global hoverx hovery hoverid hovertimer
5443 global canv linespc lthickness
5444 global commitinfo mainfont
5446 set text [lindex $commitinfo($hoverid) 0]
5447 set ymax [lindex [$canv cget -scrollregion] 3]
5448 if {$ymax == {}} return
5449 set yfrac [lindex [$canv yview] 0]
5450 set x [expr {$hoverx + 2 * $linespc}]
5451 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5452 set x0 [expr {$x - 2 * $lthickness}]
5453 set y0 [expr {$y - 2 * $lthickness}]
5454 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5455 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5456 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5457 -fill \#ffff80 -outline black -width 1 -tags hover]
5459 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5464 proc clickisonarrow {id y} {
5467 set ranges [rowranges $id]
5468 set thresh [expr {2 * $lthickness + 6}]
5469 set n [expr {[llength $ranges] - 1}]
5470 for {set i 1} {$i < $n} {incr i} {
5471 set row [lindex $ranges $i]
5472 if {abs([yc $row] - $y) < $thresh} {
5479 proc arrowjump {id n y} {
5482 # 1 <-> 2, 3 <-> 4, etc...
5483 set n [expr {(($n - 1) ^ 1) + 1}]
5484 set row [lindex [rowranges $id] $n]
5486 set ymax [lindex [$canv cget -scrollregion] 3]
5487 if {$ymax eq {} || $ymax <= 0} return
5488 set view [$canv yview]
5489 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5490 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5494 allcanvs yview moveto $yfrac
5497 proc lineclick {x y id isnew} {
5498 global ctext commitinfo children canv thickerline curview
5500 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5505 # draw this line thicker than normal
5509 set ymax [lindex [$canv cget -scrollregion] 3]
5510 if {$ymax eq {}} return
5511 set yfrac [lindex [$canv yview] 0]
5512 set y [expr {$y + $yfrac * $ymax}]
5514 set dirn [clickisonarrow $id $y]
5516 arrowjump $id $dirn $y
5521 addtohistory [list lineclick $x $y $id 0]
5523 # fill the details pane with info about this line
5524 $ctext conf -state normal
5526 $ctext tag conf link -foreground blue -underline 1
5527 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5528 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5529 $ctext insert end "Parent:\t"
5530 $ctext insert end $id [list link link0]
5531 $ctext tag bind link0 <1> [list selbyid $id]
5532 set info $commitinfo($id)
5533 $ctext insert end "\n\t[lindex $info 0]\n"
5534 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5535 set date [formatdate [lindex $info 2]]
5536 $ctext insert end "\tDate:\t$date\n"
5537 set kids $children($curview,$id)
5539 $ctext insert end "\nChildren:"
5541 foreach child $kids {
5543 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5544 set info $commitinfo($child)
5545 $ctext insert end "\n\t"
5546 $ctext insert end $child [list link link$i]
5547 $ctext tag bind link$i <1> [list selbyid $child]
5548 $ctext insert end "\n\t[lindex $info 0]"
5549 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5550 set date [formatdate [lindex $info 2]]
5551 $ctext insert end "\n\tDate:\t$date\n"
5554 $ctext conf -state disabled
5558 proc normalline {} {
5560 if {[info exists thickerline]} {
5568 global commitrow curview
5569 if {[info exists commitrow($curview,$id)]} {
5570 selectline $commitrow($curview,$id) 1
5576 if {![info exists startmstime]} {
5577 set startmstime [clock clicks -milliseconds]
5579 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5582 proc rowmenu {x y id} {
5583 global rowctxmenu commitrow selectedline rowmenuid curview
5584 global nullid nullid2 fakerowmenu mainhead
5587 if {![info exists selectedline]
5588 || $commitrow($curview,$id) eq $selectedline} {
5593 if {$id ne $nullid && $id ne $nullid2} {
5594 set menu $rowctxmenu
5595 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5597 set menu $fakerowmenu
5599 $menu entryconfigure "Diff this*" -state $state
5600 $menu entryconfigure "Diff selected*" -state $state
5601 $menu entryconfigure "Make patch" -state $state
5602 tk_popup $menu $x $y
5605 proc diffvssel {dirn} {
5606 global rowmenuid selectedline displayorder
5608 if {![info exists selectedline]} return
5610 set oldid [lindex $displayorder $selectedline]
5611 set newid $rowmenuid
5613 set oldid $rowmenuid
5614 set newid [lindex $displayorder $selectedline]
5616 addtohistory [list doseldiff $oldid $newid]
5617 doseldiff $oldid $newid
5620 proc doseldiff {oldid newid} {
5624 $ctext conf -state normal
5627 $ctext insert end "From "
5628 $ctext tag conf link -foreground blue -underline 1
5629 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5630 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5631 $ctext tag bind link0 <1> [list selbyid $oldid]
5632 $ctext insert end $oldid [list link link0]
5633 $ctext insert end "\n "
5634 $ctext insert end [lindex $commitinfo($oldid) 0]
5635 $ctext insert end "\n\nTo "
5636 $ctext tag bind link1 <1> [list selbyid $newid]
5637 $ctext insert end $newid [list link link1]
5638 $ctext insert end "\n "
5639 $ctext insert end [lindex $commitinfo($newid) 0]
5640 $ctext insert end "\n"
5641 $ctext conf -state disabled
5642 $ctext tag remove found 1.0 end
5643 startdiff [list $oldid $newid]
5647 global rowmenuid currentid commitinfo patchtop patchnum
5649 if {![info exists currentid]} return
5650 set oldid $currentid
5651 set oldhead [lindex $commitinfo($oldid) 0]
5652 set newid $rowmenuid
5653 set newhead [lindex $commitinfo($newid) 0]
5656 catch {destroy $top}
5658 label $top.title -text "Generate patch"
5659 grid $top.title - -pady 10
5660 label $top.from -text "From:"
5661 entry $top.fromsha1 -width 40 -relief flat
5662 $top.fromsha1 insert 0 $oldid
5663 $top.fromsha1 conf -state readonly
5664 grid $top.from $top.fromsha1 -sticky w
5665 entry $top.fromhead -width 60 -relief flat
5666 $top.fromhead insert 0 $oldhead
5667 $top.fromhead conf -state readonly
5668 grid x $top.fromhead -sticky w
5669 label $top.to -text "To:"
5670 entry $top.tosha1 -width 40 -relief flat
5671 $top.tosha1 insert 0 $newid
5672 $top.tosha1 conf -state readonly
5673 grid $top.to $top.tosha1 -sticky w
5674 entry $top.tohead -width 60 -relief flat
5675 $top.tohead insert 0 $newhead
5676 $top.tohead conf -state readonly
5677 grid x $top.tohead -sticky w
5678 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5679 grid $top.rev x -pady 10
5680 label $top.flab -text "Output file:"
5681 entry $top.fname -width 60
5682 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5684 grid $top.flab $top.fname -sticky w
5686 button $top.buts.gen -text "Generate" -command mkpatchgo
5687 button $top.buts.can -text "Cancel" -command mkpatchcan
5688 grid $top.buts.gen $top.buts.can
5689 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5690 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5691 grid $top.buts - -pady 10 -sticky ew
5695 proc mkpatchrev {} {
5698 set oldid [$patchtop.fromsha1 get]
5699 set oldhead [$patchtop.fromhead get]
5700 set newid [$patchtop.tosha1 get]
5701 set newhead [$patchtop.tohead get]
5702 foreach e [list fromsha1 fromhead tosha1 tohead] \
5703 v [list $newid $newhead $oldid $oldhead] {
5704 $patchtop.$e conf -state normal
5705 $patchtop.$e delete 0 end
5706 $patchtop.$e insert 0 $v
5707 $patchtop.$e conf -state readonly
5712 global patchtop nullid nullid2
5714 set oldid [$patchtop.fromsha1 get]
5715 set newid [$patchtop.tosha1 get]
5716 set fname [$patchtop.fname get]
5717 set cmd [diffcmd [list $oldid $newid] -p]
5718 lappend cmd >$fname &
5719 if {[catch {eval exec $cmd} err]} {
5720 error_popup "Error creating patch: $err"
5722 catch {destroy $patchtop}
5726 proc mkpatchcan {} {
5729 catch {destroy $patchtop}
5734 global rowmenuid mktagtop commitinfo
5738 catch {destroy $top}
5740 label $top.title -text "Create tag"
5741 grid $top.title - -pady 10
5742 label $top.id -text "ID:"
5743 entry $top.sha1 -width 40 -relief flat
5744 $top.sha1 insert 0 $rowmenuid
5745 $top.sha1 conf -state readonly
5746 grid $top.id $top.sha1 -sticky w
5747 entry $top.head -width 60 -relief flat
5748 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5749 $top.head conf -state readonly
5750 grid x $top.head -sticky w
5751 label $top.tlab -text "Tag name:"
5752 entry $top.tag -width 60
5753 grid $top.tlab $top.tag -sticky w
5755 button $top.buts.gen -text "Create" -command mktaggo
5756 button $top.buts.can -text "Cancel" -command mktagcan
5757 grid $top.buts.gen $top.buts.can
5758 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5759 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5760 grid $top.buts - -pady 10 -sticky ew
5765 global mktagtop env tagids idtags
5767 set id [$mktagtop.sha1 get]
5768 set tag [$mktagtop.tag get]
5770 error_popup "No tag name specified"
5773 if {[info exists tagids($tag)]} {
5774 error_popup "Tag \"$tag\" already exists"
5779 set fname [file join $dir "refs/tags" $tag]
5780 set f [open $fname w]
5784 error_popup "Error creating tag: $err"
5788 set tagids($tag) $id
5789 lappend idtags($id) $tag
5794 proc redrawtags {id} {
5795 global canv linehtag commitrow idpos selectedline curview
5796 global mainfont canvxmax iddrawn
5798 if {![info exists commitrow($curview,$id)]} return
5799 if {![info exists iddrawn($id)]} return
5800 drawcommits $commitrow($curview,$id)
5801 $canv delete tag.$id
5802 set xt [eval drawtags $id $idpos($id)]
5803 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5804 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5805 set xr [expr {$xt + [font measure $mainfont $text]}]
5806 if {$xr > $canvxmax} {
5810 if {[info exists selectedline]
5811 && $selectedline == $commitrow($curview,$id)} {
5812 selectline $selectedline 0
5819 catch {destroy $mktagtop}
5828 proc writecommit {} {
5829 global rowmenuid wrcomtop commitinfo wrcomcmd
5831 set top .writecommit
5833 catch {destroy $top}
5835 label $top.title -text "Write commit to file"
5836 grid $top.title - -pady 10
5837 label $top.id -text "ID:"
5838 entry $top.sha1 -width 40 -relief flat
5839 $top.sha1 insert 0 $rowmenuid
5840 $top.sha1 conf -state readonly
5841 grid $top.id $top.sha1 -sticky w
5842 entry $top.head -width 60 -relief flat
5843 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5844 $top.head conf -state readonly
5845 grid x $top.head -sticky w
5846 label $top.clab -text "Command:"
5847 entry $top.cmd -width 60 -textvariable wrcomcmd
5848 grid $top.clab $top.cmd -sticky w -pady 10
5849 label $top.flab -text "Output file:"
5850 entry $top.fname -width 60
5851 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5852 grid $top.flab $top.fname -sticky w
5854 button $top.buts.gen -text "Write" -command wrcomgo
5855 button $top.buts.can -text "Cancel" -command wrcomcan
5856 grid $top.buts.gen $top.buts.can
5857 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5858 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5859 grid $top.buts - -pady 10 -sticky ew
5866 set id [$wrcomtop.sha1 get]
5867 set cmd "echo $id | [$wrcomtop.cmd get]"
5868 set fname [$wrcomtop.fname get]
5869 if {[catch {exec sh -c $cmd >$fname &} err]} {
5870 error_popup "Error writing commit: $err"
5872 catch {destroy $wrcomtop}
5879 catch {destroy $wrcomtop}
5884 global rowmenuid mkbrtop
5887 catch {destroy $top}
5889 label $top.title -text "Create new branch"
5890 grid $top.title - -pady 10
5891 label $top.id -text "ID:"
5892 entry $top.sha1 -width 40 -relief flat
5893 $top.sha1 insert 0 $rowmenuid
5894 $top.sha1 conf -state readonly
5895 grid $top.id $top.sha1 -sticky w
5896 label $top.nlab -text "Name:"
5897 entry $top.name -width 40
5898 grid $top.nlab $top.name -sticky w
5900 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5901 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5902 grid $top.buts.go $top.buts.can
5903 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5904 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5905 grid $top.buts - -pady 10 -sticky ew
5910 global headids idheads
5912 set name [$top.name get]
5913 set id [$top.sha1 get]
5915 error_popup "Please specify a name for the new branch"
5918 catch {destroy $top}
5922 exec git branch $name $id
5927 set headids($name) $id
5928 lappend idheads($id) $name
5936 proc cherrypick {} {
5937 global rowmenuid curview commitrow
5940 set oldhead [exec git rev-parse HEAD]
5941 set dheads [descheads $rowmenuid]
5942 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5943 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5944 included in branch $mainhead -- really re-apply it?"]
5949 # Unfortunately git-cherry-pick writes stuff to stderr even when
5950 # no error occurs, and exec takes that as an indication of error...
5951 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5956 set newhead [exec git rev-parse HEAD]
5957 if {$newhead eq $oldhead} {
5959 error_popup "No changes committed"
5962 addnewchild $newhead $oldhead
5963 if {[info exists commitrow($curview,$oldhead)]} {
5964 insertrow $commitrow($curview,$oldhead) $newhead
5965 if {$mainhead ne {}} {
5966 movehead $newhead $mainhead
5967 movedhead $newhead $mainhead
5976 global mainheadid mainhead rowmenuid confirm_ok resettype
5977 global showlocalchanges
5980 set w ".confirmreset"
5983 wm title $w "Confirm reset"
5984 message $w.m -text \
5985 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5986 -justify center -aspect 1000
5987 pack $w.m -side top -fill x -padx 20 -pady 20
5988 frame $w.f -relief sunken -border 2
5989 message $w.f.rt -text "Reset type:" -aspect 1000
5990 grid $w.f.rt -sticky w
5992 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5993 -text "Soft: Leave working tree and index untouched"
5994 grid $w.f.soft -sticky w
5995 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5996 -text "Mixed: Leave working tree untouched, reset index"
5997 grid $w.f.mixed -sticky w
5998 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5999 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6000 grid $w.f.hard -sticky w
6001 pack $w.f -side top -fill x
6002 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6003 pack $w.ok -side left -fill x -padx 20 -pady 20
6004 button $w.cancel -text Cancel -command "destroy $w"
6005 pack $w.cancel -side right -fill x -padx 20 -pady 20
6006 bind $w <Visibility> "grab $w; focus $w"
6008 if {!$confirm_ok} return
6009 if {[catch {set fd [open \
6010 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6014 set w ".resetprogress"
6015 filerun $fd [list readresetstat $fd $w]
6018 wm title $w "Reset progress"
6019 message $w.m -text "Reset in progress, please wait..." \
6020 -justify center -aspect 1000
6021 pack $w.m -side top -fill x -padx 20 -pady 5
6022 canvas $w.c -width 150 -height 20 -bg white
6023 $w.c create rect 0 0 0 20 -fill green -tags rect
6024 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6029 proc readresetstat {fd w} {
6030 global mainhead mainheadid showlocalchanges
6032 if {[gets $fd line] >= 0} {
6033 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6034 set x [expr {($m * 150) / $n}]
6035 $w.c coords rect 0 0 $x 20
6041 if {[catch {close $fd} err]} {
6044 set oldhead $mainheadid
6045 set newhead [exec git rev-parse HEAD]
6046 if {$newhead ne $oldhead} {
6047 movehead $newhead $mainhead
6048 movedhead $newhead $mainhead
6049 set mainheadid $newhead
6053 if {$showlocalchanges} {
6059 # context menu for a head
6060 proc headmenu {x y id head} {
6061 global headmenuid headmenuhead headctxmenu mainhead
6064 set headmenuhead $head
6066 if {$head eq $mainhead} {
6069 $headctxmenu entryconfigure 0 -state $state
6070 $headctxmenu entryconfigure 1 -state $state
6071 tk_popup $headctxmenu $x $y
6075 global headmenuid headmenuhead mainhead headids
6076 global showlocalchanges mainheadid
6078 # check the tree is clean first??
6079 set oldmainhead $mainhead
6084 exec git checkout -q $headmenuhead
6090 set mainhead $headmenuhead
6091 set mainheadid $headmenuid
6092 if {[info exists headids($oldmainhead)]} {
6093 redrawtags $headids($oldmainhead)
6095 redrawtags $headmenuid
6097 if {$showlocalchanges} {
6103 global headmenuid headmenuhead mainhead
6104 global headids idheads
6106 set head $headmenuhead
6108 # this check shouldn't be needed any more...
6109 if {$head eq $mainhead} {
6110 error_popup "Cannot delete the currently checked-out branch"
6113 set dheads [descheads $id]
6114 if {$dheads eq $headids($head)} {
6115 # the stuff on this branch isn't on any other branch
6116 if {![confirm_popup "The commits on branch $head aren't on any other\
6117 branch.\nReally delete branch $head?"]} return
6121 if {[catch {exec git branch -D $head} err]} {
6126 removehead $id $head
6127 removedhead $id $head
6133 # Stuff for finding nearby tags
6134 proc getallcommits {} {
6135 global allcommits allids nbmp nextarc seeds
6145 # Called when the graph might have changed
6146 proc regetallcommits {} {
6147 global allcommits seeds
6149 set cmd [concat | git rev-list --all --parents]
6153 set fd [open $cmd r]
6154 fconfigure $fd -blocking 0
6157 filerun $fd [list getallclines $fd]
6160 # Since most commits have 1 parent and 1 child, we group strings of
6161 # such commits into "arcs" joining branch/merge points (BMPs), which
6162 # are commits that either don't have 1 parent or don't have 1 child.
6164 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6165 # arcout(id) - outgoing arcs for BMP
6166 # arcids(a) - list of IDs on arc including end but not start
6167 # arcstart(a) - BMP ID at start of arc
6168 # arcend(a) - BMP ID at end of arc
6169 # growing(a) - arc a is still growing
6170 # arctags(a) - IDs out of arcids (excluding end) that have tags
6171 # archeads(a) - IDs out of arcids (excluding end) that have heads
6172 # The start of an arc is at the descendent end, so "incoming" means
6173 # coming from descendents, and "outgoing" means going towards ancestors.
6175 proc getallclines {fd} {
6176 global allids allparents allchildren idtags idheads nextarc nbmp
6177 global arcnos arcids arctags arcout arcend arcstart archeads growing
6178 global seeds allcommits
6181 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6182 set id [lindex $line 0]
6183 if {[info exists allparents($id)]} {
6188 set olds [lrange $line 1 end]
6189 set allparents($id) $olds
6190 if {![info exists allchildren($id)]} {
6191 set allchildren($id) {}
6196 if {[llength $olds] == 1 && [llength $a] == 1} {
6197 lappend arcids($a) $id
6198 if {[info exists idtags($id)]} {
6199 lappend arctags($a) $id
6201 if {[info exists idheads($id)]} {
6202 lappend archeads($a) $id
6204 if {[info exists allparents($olds)]} {
6205 # seen parent already
6206 if {![info exists arcout($olds)]} {
6209 lappend arcids($a) $olds
6210 set arcend($a) $olds
6213 lappend allchildren($olds) $id
6214 lappend arcnos($olds) $a
6219 foreach a $arcnos($id) {
6220 lappend arcids($a) $id
6227 lappend allchildren($p) $id
6228 set a [incr nextarc]
6229 set arcstart($a) $id
6236 if {[info exists allparents($p)]} {
6237 # seen it already, may need to make a new branch
6238 if {![info exists arcout($p)]} {
6241 lappend arcids($a) $p
6245 lappend arcnos($p) $a
6250 global cached_dheads cached_dtags cached_atags
6251 catch {unset cached_dheads}
6252 catch {unset cached_dtags}
6253 catch {unset cached_atags}
6256 return [expr {$nid >= 1000? 2: 1}]
6259 if {[incr allcommits -1] == 0} {
6266 proc recalcarc {a} {
6267 global arctags archeads arcids idtags idheads
6271 foreach id [lrange $arcids($a) 0 end-1] {
6272 if {[info exists idtags($id)]} {
6275 if {[info exists idheads($id)]} {
6280 set archeads($a) $ah
6284 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6285 global arcstart arcend arcout allparents growing
6288 if {[llength $a] != 1} {
6289 puts "oops splitarc called but [llength $a] arcs already"
6293 set i [lsearch -exact $arcids($a) $p]
6295 puts "oops splitarc $p not in arc $a"
6298 set na [incr nextarc]
6299 if {[info exists arcend($a)]} {
6300 set arcend($na) $arcend($a)
6302 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6303 set j [lsearch -exact $arcnos($l) $a]
6304 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6306 set tail [lrange $arcids($a) [expr {$i+1}] end]
6307 set arcids($a) [lrange $arcids($a) 0 $i]
6309 set arcstart($na) $p
6311 set arcids($na) $tail
6312 if {[info exists growing($a)]} {
6319 if {[llength $arcnos($id)] == 1} {
6322 set j [lsearch -exact $arcnos($id) $a]
6323 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6327 # reconstruct tags and heads lists
6328 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6333 set archeads($na) {}
6337 # Update things for a new commit added that is a child of one
6338 # existing commit. Used when cherry-picking.
6339 proc addnewchild {id p} {
6340 global allids allparents allchildren idtags nextarc nbmp
6341 global arcnos arcids arctags arcout arcend arcstart archeads growing
6345 set allparents($id) [list $p]
6346 set allchildren($id) {}
6350 lappend allchildren($p) $id
6351 set a [incr nextarc]
6352 set arcstart($a) $id
6355 set arcids($a) [list $p]
6357 if {![info exists arcout($p)]} {
6360 lappend arcnos($p) $a
6361 set arcout($id) [list $a]
6364 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6365 # or 0 if neither is true.
6366 proc anc_or_desc {a b} {
6367 global arcout arcstart arcend arcnos cached_isanc
6369 if {$arcnos($a) eq $arcnos($b)} {
6370 # Both are on the same arc(s); either both are the same BMP,
6371 # or if one is not a BMP, the other is also not a BMP or is
6372 # the BMP at end of the arc (and it only has 1 incoming arc).
6373 # Or both can be BMPs with no incoming arcs.
6374 if {$a eq $b || $arcnos($a) eq {}} {
6377 # assert {[llength $arcnos($a)] == 1}
6378 set arc [lindex $arcnos($a) 0]
6379 set i [lsearch -exact $arcids($arc) $a]
6380 set j [lsearch -exact $arcids($arc) $b]
6381 if {$i < 0 || $i > $j} {
6388 if {![info exists arcout($a)]} {
6389 set arc [lindex $arcnos($a) 0]
6390 if {[info exists arcend($arc)]} {
6391 set aend $arcend($arc)
6395 set a $arcstart($arc)
6399 if {![info exists arcout($b)]} {
6400 set arc [lindex $arcnos($b) 0]
6401 if {[info exists arcend($arc)]} {
6402 set bend $arcend($arc)
6406 set b $arcstart($arc)
6416 if {[info exists cached_isanc($a,$bend)]} {
6417 if {$cached_isanc($a,$bend)} {
6421 if {[info exists cached_isanc($b,$aend)]} {
6422 if {$cached_isanc($b,$aend)} {
6425 if {[info exists cached_isanc($a,$bend)]} {
6430 set todo [list $a $b]
6433 for {set i 0} {$i < [llength $todo]} {incr i} {
6434 set x [lindex $todo $i]
6435 if {$anc($x) eq {}} {
6438 foreach arc $arcnos($x) {
6439 set xd $arcstart($arc)
6441 set cached_isanc($a,$bend) 1
6442 set cached_isanc($b,$aend) 0
6444 } elseif {$xd eq $aend} {
6445 set cached_isanc($b,$aend) 1
6446 set cached_isanc($a,$bend) 0
6449 if {![info exists anc($xd)]} {
6450 set anc($xd) $anc($x)
6452 } elseif {$anc($xd) ne $anc($x)} {
6457 set cached_isanc($a,$bend) 0
6458 set cached_isanc($b,$aend) 0
6462 # This identifies whether $desc has an ancestor that is
6463 # a growing tip of the graph and which is not an ancestor of $anc
6464 # and returns 0 if so and 1 if not.
6465 # If we subsequently discover a tag on such a growing tip, and that
6466 # turns out to be a descendent of $anc (which it could, since we
6467 # don't necessarily see children before parents), then $desc
6468 # isn't a good choice to display as a descendent tag of
6469 # $anc (since it is the descendent of another tag which is
6470 # a descendent of $anc). Similarly, $anc isn't a good choice to
6471 # display as a ancestor tag of $desc.
6473 proc is_certain {desc anc} {
6474 global arcnos arcout arcstart arcend growing problems
6477 if {[llength $arcnos($anc)] == 1} {
6478 # tags on the same arc are certain
6479 if {$arcnos($desc) eq $arcnos($anc)} {
6482 if {![info exists arcout($anc)]} {
6483 # if $anc is partway along an arc, use the start of the arc instead
6484 set a [lindex $arcnos($anc) 0]
6485 set anc $arcstart($a)
6488 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6491 set a [lindex $arcnos($desc) 0]
6497 set anclist [list $x]
6501 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6502 set x [lindex $anclist $i]
6507 foreach a $arcout($x) {
6508 if {[info exists growing($a)]} {
6509 if {![info exists growanc($x)] && $dl($x)} {
6515 if {[info exists dl($y)]} {
6519 if {![info exists done($y)]} {
6522 if {[info exists growanc($x)]} {
6526 for {set k 0} {$k < [llength $xl]} {incr k} {
6527 set z [lindex $xl $k]
6528 foreach c $arcout($z) {
6529 if {[info exists arcend($c)]} {
6531 if {[info exists dl($v)] && $dl($v)} {
6533 if {![info exists done($v)]} {
6536 if {[info exists growanc($v)]} {
6546 } elseif {$y eq $anc || !$dl($x)} {
6557 foreach x [array names growanc] {
6566 proc validate_arctags {a} {
6567 global arctags idtags
6571 foreach id $arctags($a) {
6573 if {![info exists idtags($id)]} {
6574 set na [lreplace $na $i $i]
6581 proc validate_archeads {a} {
6582 global archeads idheads
6585 set na $archeads($a)
6586 foreach id $archeads($a) {
6588 if {![info exists idheads($id)]} {
6589 set na [lreplace $na $i $i]
6593 set archeads($a) $na
6596 # Return the list of IDs that have tags that are descendents of id,
6597 # ignoring IDs that are descendents of IDs already reported.
6598 proc desctags {id} {
6599 global arcnos arcstart arcids arctags idtags allparents
6600 global growing cached_dtags
6602 if {![info exists allparents($id)]} {
6605 set t1 [clock clicks -milliseconds]
6607 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6608 # part-way along an arc; check that arc first
6609 set a [lindex $arcnos($id) 0]
6610 if {$arctags($a) ne {}} {
6612 set i [lsearch -exact $arcids($a) $id]
6614 foreach t $arctags($a) {
6615 set j [lsearch -exact $arcids($a) $t]
6623 set id $arcstart($a)
6624 if {[info exists idtags($id)]} {
6628 if {[info exists cached_dtags($id)]} {
6629 return $cached_dtags($id)
6636 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6637 set id [lindex $todo $i]
6639 set ta [info exists hastaggedancestor($id)]
6643 # ignore tags on starting node
6644 if {!$ta && $i > 0} {
6645 if {[info exists idtags($id)]} {
6648 } elseif {[info exists cached_dtags($id)]} {
6649 set tagloc($id) $cached_dtags($id)
6653 foreach a $arcnos($id) {
6655 if {!$ta && $arctags($a) ne {}} {
6657 if {$arctags($a) ne {}} {
6658 lappend tagloc($id) [lindex $arctags($a) end]
6661 if {$ta || $arctags($a) ne {}} {
6662 set tomark [list $d]
6663 for {set j 0} {$j < [llength $tomark]} {incr j} {
6664 set dd [lindex $tomark $j]
6665 if {![info exists hastaggedancestor($dd)]} {
6666 if {[info exists done($dd)]} {
6667 foreach b $arcnos($dd) {
6668 lappend tomark $arcstart($b)
6670 if {[info exists tagloc($dd)]} {
6673 } elseif {[info exists queued($dd)]} {
6676 set hastaggedancestor($dd) 1
6680 if {![info exists queued($d)]} {
6683 if {![info exists hastaggedancestor($d)]} {
6690 foreach id [array names tagloc] {
6691 if {![info exists hastaggedancestor($id)]} {
6692 foreach t $tagloc($id) {
6693 if {[lsearch -exact $tags $t] < 0} {
6699 set t2 [clock clicks -milliseconds]
6702 # remove tags that are descendents of other tags
6703 for {set i 0} {$i < [llength $tags]} {incr i} {
6704 set a [lindex $tags $i]
6705 for {set j 0} {$j < $i} {incr j} {
6706 set b [lindex $tags $j]
6707 set r [anc_or_desc $a $b]
6709 set tags [lreplace $tags $j $j]
6712 } elseif {$r == -1} {
6713 set tags [lreplace $tags $i $i]
6720 if {[array names growing] ne {}} {
6721 # graph isn't finished, need to check if any tag could get
6722 # eclipsed by another tag coming later. Simply ignore any
6723 # tags that could later get eclipsed.
6726 if {[is_certain $t $origid]} {
6730 if {$tags eq $ctags} {
6731 set cached_dtags($origid) $tags
6736 set cached_dtags($origid) $tags
6738 set t3 [clock clicks -milliseconds]
6739 if {0 && $t3 - $t1 >= 100} {
6740 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6741 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6747 global arcnos arcids arcout arcend arctags idtags allparents
6748 global growing cached_atags
6750 if {![info exists allparents($id)]} {
6753 set t1 [clock clicks -milliseconds]
6755 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6756 # part-way along an arc; check that arc first
6757 set a [lindex $arcnos($id) 0]
6758 if {$arctags($a) ne {}} {
6760 set i [lsearch -exact $arcids($a) $id]
6761 foreach t $arctags($a) {
6762 set j [lsearch -exact $arcids($a) $t]
6768 if {![info exists arcend($a)]} {
6772 if {[info exists idtags($id)]} {
6776 if {[info exists cached_atags($id)]} {
6777 return $cached_atags($id)
6785 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6786 set id [lindex $todo $i]
6788 set td [info exists hastaggeddescendent($id)]
6792 # ignore tags on starting node
6793 if {!$td && $i > 0} {
6794 if {[info exists idtags($id)]} {
6797 } elseif {[info exists cached_atags($id)]} {
6798 set tagloc($id) $cached_atags($id)
6802 foreach a $arcout($id) {
6803 if {!$td && $arctags($a) ne {}} {
6805 if {$arctags($a) ne {}} {
6806 lappend tagloc($id) [lindex $arctags($a) 0]
6809 if {![info exists arcend($a)]} continue
6811 if {$td || $arctags($a) ne {}} {
6812 set tomark [list $d]
6813 for {set j 0} {$j < [llength $tomark]} {incr j} {
6814 set dd [lindex $tomark $j]
6815 if {![info exists hastaggeddescendent($dd)]} {
6816 if {[info exists done($dd)]} {
6817 foreach b $arcout($dd) {
6818 if {[info exists arcend($b)]} {
6819 lappend tomark $arcend($b)
6822 if {[info exists tagloc($dd)]} {
6825 } elseif {[info exists queued($dd)]} {
6828 set hastaggeddescendent($dd) 1
6832 if {![info exists queued($d)]} {
6835 if {![info exists hastaggeddescendent($d)]} {
6841 set t2 [clock clicks -milliseconds]
6844 foreach id [array names tagloc] {
6845 if {![info exists hastaggeddescendent($id)]} {
6846 foreach t $tagloc($id) {
6847 if {[lsearch -exact $tags $t] < 0} {
6854 # remove tags that are ancestors of other tags
6855 for {set i 0} {$i < [llength $tags]} {incr i} {
6856 set a [lindex $tags $i]
6857 for {set j 0} {$j < $i} {incr j} {
6858 set b [lindex $tags $j]
6859 set r [anc_or_desc $a $b]
6861 set tags [lreplace $tags $j $j]
6864 } elseif {$r == 1} {
6865 set tags [lreplace $tags $i $i]
6872 if {[array names growing] ne {}} {
6873 # graph isn't finished, need to check if any tag could get
6874 # eclipsed by another tag coming later. Simply ignore any
6875 # tags that could later get eclipsed.
6878 if {[is_certain $origid $t]} {
6882 if {$tags eq $ctags} {
6883 set cached_atags($origid) $tags
6888 set cached_atags($origid) $tags
6890 set t3 [clock clicks -milliseconds]
6891 if {0 && $t3 - $t1 >= 100} {
6892 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6893 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6898 # Return the list of IDs that have heads that are descendents of id,
6899 # including id itself if it has a head.
6900 proc descheads {id} {
6901 global arcnos arcstart arcids archeads idheads cached_dheads
6904 if {![info exists allparents($id)]} {
6908 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6909 # part-way along an arc; check it first
6910 set a [lindex $arcnos($id) 0]
6911 if {$archeads($a) ne {}} {
6912 validate_archeads $a
6913 set i [lsearch -exact $arcids($a) $id]
6914 foreach t $archeads($a) {
6915 set j [lsearch -exact $arcids($a) $t]
6920 set id $arcstart($a)
6926 for {set i 0} {$i < [llength $todo]} {incr i} {
6927 set id [lindex $todo $i]
6928 if {[info exists cached_dheads($id)]} {
6929 set ret [concat $ret $cached_dheads($id)]
6931 if {[info exists idheads($id)]} {
6934 foreach a $arcnos($id) {
6935 if {$archeads($a) ne {}} {
6936 validate_archeads $a
6937 if {$archeads($a) ne {}} {
6938 set ret [concat $ret $archeads($a)]
6942 if {![info exists seen($d)]} {
6949 set ret [lsort -unique $ret]
6950 set cached_dheads($origid) $ret
6951 return [concat $ret $aret]
6954 proc addedtag {id} {
6955 global arcnos arcout cached_dtags cached_atags
6957 if {![info exists arcnos($id)]} return
6958 if {![info exists arcout($id)]} {
6959 recalcarc [lindex $arcnos($id) 0]
6961 catch {unset cached_dtags}
6962 catch {unset cached_atags}
6965 proc addedhead {hid head} {
6966 global arcnos arcout cached_dheads
6968 if {![info exists arcnos($hid)]} return
6969 if {![info exists arcout($hid)]} {
6970 recalcarc [lindex $arcnos($hid) 0]
6972 catch {unset cached_dheads}
6975 proc removedhead {hid head} {
6976 global cached_dheads
6978 catch {unset cached_dheads}
6981 proc movedhead {hid head} {
6982 global arcnos arcout cached_dheads
6984 if {![info exists arcnos($hid)]} return
6985 if {![info exists arcout($hid)]} {
6986 recalcarc [lindex $arcnos($hid) 0]
6988 catch {unset cached_dheads}
6991 proc changedrefs {} {
6992 global cached_dheads cached_dtags cached_atags
6993 global arctags archeads arcnos arcout idheads idtags
6995 foreach id [concat [array names idheads] [array names idtags]] {
6996 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6997 set a [lindex $arcnos($id) 0]
6998 if {![info exists donearc($a)]} {
7004 catch {unset cached_dtags}
7005 catch {unset cached_atags}
7006 catch {unset cached_dheads}
7009 proc rereadrefs {} {
7010 global idtags idheads idotherrefs mainhead
7012 set refids [concat [array names idtags] \
7013 [array names idheads] [array names idotherrefs]]
7014 foreach id $refids {
7015 if {![info exists ref($id)]} {
7016 set ref($id) [listrefs $id]
7019 set oldmainhead $mainhead
7022 set refids [lsort -unique [concat $refids [array names idtags] \
7023 [array names idheads] [array names idotherrefs]]]
7024 foreach id $refids {
7025 set v [listrefs $id]
7026 if {![info exists ref($id)] || $ref($id) != $v ||
7027 ($id eq $oldmainhead && $id ne $mainhead) ||
7028 ($id eq $mainhead && $id ne $oldmainhead)} {
7034 proc listrefs {id} {
7035 global idtags idheads idotherrefs
7038 if {[info exists idtags($id)]} {
7042 if {[info exists idheads($id)]} {
7046 if {[info exists idotherrefs($id)]} {
7047 set z $idotherrefs($id)
7049 return [list $x $y $z]
7052 proc showtag {tag isnew} {
7053 global ctext tagcontents tagids linknum tagobjid
7056 addtohistory [list showtag $tag 0]
7058 $ctext conf -state normal
7061 if {![info exists tagcontents($tag)]} {
7063 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7066 if {[info exists tagcontents($tag)]} {
7067 set text $tagcontents($tag)
7069 set text "Tag: $tag\nId: $tagids($tag)"
7071 appendwithlinks $text {}
7072 $ctext conf -state disabled
7084 global maxwidth maxgraphpct diffopts
7085 global oldprefs prefstop showneartags showlocalchanges
7086 global bgcolor fgcolor ctext diffcolors selectbgcolor
7087 global uifont tabstop
7091 if {[winfo exists $top]} {
7095 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7096 set oldprefs($v) [set $v]
7099 wm title $top "Gitk preferences"
7100 label $top.ldisp -text "Commit list display options"
7101 $top.ldisp configure -font $uifont
7102 grid $top.ldisp - -sticky w -pady 10
7103 label $top.spacer -text " "
7104 label $top.maxwidthl -text "Maximum graph width (lines)" \
7106 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7107 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7108 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7110 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7111 grid x $top.maxpctl $top.maxpct -sticky w
7112 frame $top.showlocal
7113 label $top.showlocal.l -text "Show local changes" -font optionfont
7114 checkbutton $top.showlocal.b -variable showlocalchanges
7115 pack $top.showlocal.b $top.showlocal.l -side left
7116 grid x $top.showlocal -sticky w
7118 label $top.ddisp -text "Diff display options"
7119 $top.ddisp configure -font $uifont
7120 grid $top.ddisp - -sticky w -pady 10
7121 label $top.diffoptl -text "Options for diff program" \
7123 entry $top.diffopt -width 20 -textvariable diffopts
7124 grid x $top.diffoptl $top.diffopt -sticky w
7126 label $top.ntag.l -text "Display nearby tags" -font optionfont
7127 checkbutton $top.ntag.b -variable showneartags
7128 pack $top.ntag.b $top.ntag.l -side left
7129 grid x $top.ntag -sticky w
7130 label $top.tabstopl -text "tabstop" -font optionfont
7131 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7132 grid x $top.tabstopl $top.tabstop -sticky w
7134 label $top.cdisp -text "Colors: press to choose"
7135 $top.cdisp configure -font $uifont
7136 grid $top.cdisp - -sticky w -pady 10
7137 label $top.bg -padx 40 -relief sunk -background $bgcolor
7138 button $top.bgbut -text "Background" -font optionfont \
7139 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7140 grid x $top.bgbut $top.bg -sticky w
7141 label $top.fg -padx 40 -relief sunk -background $fgcolor
7142 button $top.fgbut -text "Foreground" -font optionfont \
7143 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7144 grid x $top.fgbut $top.fg -sticky w
7145 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7146 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7147 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7148 [list $ctext tag conf d0 -foreground]]
7149 grid x $top.diffoldbut $top.diffold -sticky w
7150 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7151 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7152 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7153 [list $ctext tag conf d1 -foreground]]
7154 grid x $top.diffnewbut $top.diffnew -sticky w
7155 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7156 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7157 -command [list choosecolor diffcolors 2 $top.hunksep \
7158 "diff hunk header" \
7159 [list $ctext tag conf hunksep -foreground]]
7160 grid x $top.hunksepbut $top.hunksep -sticky w
7161 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7162 button $top.selbgbut -text "Select bg" -font optionfont \
7163 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7164 grid x $top.selbgbut $top.selbgsep -sticky w
7167 button $top.buts.ok -text "OK" -command prefsok -default active
7168 $top.buts.ok configure -font $uifont
7169 button $top.buts.can -text "Cancel" -command prefscan -default normal
7170 $top.buts.can configure -font $uifont
7171 grid $top.buts.ok $top.buts.can
7172 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7173 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7174 grid $top.buts - - -pady 10 -sticky ew
7175 bind $top <Visibility> "focus $top.buts.ok"
7178 proc choosecolor {v vi w x cmd} {
7181 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7182 -title "Gitk: choose color for $x"]
7183 if {$c eq {}} return
7184 $w conf -background $c
7190 global bglist cflist
7192 $w configure -selectbackground $c
7194 $cflist tag configure highlight \
7195 -background [$cflist cget -selectbackground]
7196 allcanvs itemconf secsel -fill $c
7203 $w conf -background $c
7211 $w conf -foreground $c
7213 allcanvs itemconf text -fill $c
7214 $canv itemconf circle -outline $c
7218 global maxwidth maxgraphpct diffopts
7219 global oldprefs prefstop showneartags showlocalchanges
7221 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7222 set $v $oldprefs($v)
7224 catch {destroy $prefstop}
7229 global maxwidth maxgraphpct
7230 global oldprefs prefstop showneartags showlocalchanges
7231 global charspc ctext tabstop
7233 catch {destroy $prefstop}
7235 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7236 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7237 if {$showlocalchanges} {
7243 if {$maxwidth != $oldprefs(maxwidth)
7244 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7246 } elseif {$showneartags != $oldprefs(showneartags)} {
7251 proc formatdate {d} {
7253 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7258 # This list of encoding names and aliases is distilled from
7259 # http://www.iana.org/assignments/character-sets.
7260 # Not all of them are supported by Tcl.
7261 set encoding_aliases {
7262 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7263 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7264 { ISO-10646-UTF-1 csISO10646UTF1 }
7265 { ISO_646.basic:1983 ref csISO646basic1983 }
7266 { INVARIANT csINVARIANT }
7267 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7268 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7269 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7270 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7271 { NATS-DANO iso-ir-9-1 csNATSDANO }
7272 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7273 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7274 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7275 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7276 { ISO-2022-KR csISO2022KR }
7278 { ISO-2022-JP csISO2022JP }
7279 { ISO-2022-JP-2 csISO2022JP2 }
7280 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7282 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7283 { IT iso-ir-15 ISO646-IT csISO15Italian }
7284 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7285 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7286 { greek7-old iso-ir-18 csISO18Greek7Old }
7287 { latin-greek iso-ir-19 csISO19LatinGreek }
7288 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7289 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7290 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7291 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7292 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7293 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7294 { INIS iso-ir-49 csISO49INIS }
7295 { INIS-8 iso-ir-50 csISO50INIS8 }
7296 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7297 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7298 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7299 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7300 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7301 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7303 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7304 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7305 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7306 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7307 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7308 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7309 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7310 { greek7 iso-ir-88 csISO88Greek7 }
7311 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7312 { iso-ir-90 csISO90 }
7313 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7314 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7315 csISO92JISC62991984b }
7316 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7317 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7318 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7319 csISO95JIS62291984handadd }
7320 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7321 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7322 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7323 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7325 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7326 { T.61-7bit iso-ir-102 csISO102T617bit }
7327 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7328 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7329 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7330 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7331 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7332 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7333 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7334 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7335 arabic csISOLatinArabic }
7336 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7337 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7338 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7339 greek greek8 csISOLatinGreek }
7340 { T.101-G2 iso-ir-128 csISO128T101G2 }
7341 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7343 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7344 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7345 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7346 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7347 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7348 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7349 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7350 csISOLatinCyrillic }
7351 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7352 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7353 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7354 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7355 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7356 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7357 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7358 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7359 { ISO_10367-box iso-ir-155 csISO10367Box }
7360 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7361 { latin-lap lap iso-ir-158 csISO158Lap }
7362 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7363 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7366 { JIS_X0201 X0201 csHalfWidthKatakana }
7367 { KSC5636 ISO646-KR csKSC5636 }
7368 { ISO-10646-UCS-2 csUnicode }
7369 { ISO-10646-UCS-4 csUCS4 }
7370 { DEC-MCS dec csDECMCS }
7371 { hp-roman8 roman8 r8 csHPRoman8 }
7372 { macintosh mac csMacintosh }
7373 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7375 { IBM038 EBCDIC-INT cp038 csIBM038 }
7376 { IBM273 CP273 csIBM273 }
7377 { IBM274 EBCDIC-BE CP274 csIBM274 }
7378 { IBM275 EBCDIC-BR cp275 csIBM275 }
7379 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7380 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7381 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7382 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7383 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7384 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7385 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7386 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7387 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7388 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7389 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7390 { IBM437 cp437 437 csPC8CodePage437 }
7391 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7392 { IBM775 cp775 csPC775Baltic }
7393 { IBM850 cp850 850 csPC850Multilingual }
7394 { IBM851 cp851 851 csIBM851 }
7395 { IBM852 cp852 852 csPCp852 }
7396 { IBM855 cp855 855 csIBM855 }
7397 { IBM857 cp857 857 csIBM857 }
7398 { IBM860 cp860 860 csIBM860 }
7399 { IBM861 cp861 861 cp-is csIBM861 }
7400 { IBM862 cp862 862 csPC862LatinHebrew }
7401 { IBM863 cp863 863 csIBM863 }
7402 { IBM864 cp864 csIBM864 }
7403 { IBM865 cp865 865 csIBM865 }
7404 { IBM866 cp866 866 csIBM866 }
7405 { IBM868 CP868 cp-ar csIBM868 }
7406 { IBM869 cp869 869 cp-gr csIBM869 }
7407 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7408 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7409 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7410 { IBM891 cp891 csIBM891 }
7411 { IBM903 cp903 csIBM903 }
7412 { IBM904 cp904 904 csIBBM904 }
7413 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7414 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7415 { IBM1026 CP1026 csIBM1026 }
7416 { EBCDIC-AT-DE csIBMEBCDICATDE }
7417 { EBCDIC-AT-DE-A csEBCDICATDEA }
7418 { EBCDIC-CA-FR csEBCDICCAFR }
7419 { EBCDIC-DK-NO csEBCDICDKNO }
7420 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7421 { EBCDIC-FI-SE csEBCDICFISE }
7422 { EBCDIC-FI-SE-A csEBCDICFISEA }
7423 { EBCDIC-FR csEBCDICFR }
7424 { EBCDIC-IT csEBCDICIT }
7425 { EBCDIC-PT csEBCDICPT }
7426 { EBCDIC-ES csEBCDICES }
7427 { EBCDIC-ES-A csEBCDICESA }
7428 { EBCDIC-ES-S csEBCDICESS }
7429 { EBCDIC-UK csEBCDICUK }
7430 { EBCDIC-US csEBCDICUS }
7431 { UNKNOWN-8BIT csUnknown8BiT }
7432 { MNEMONIC csMnemonic }
7437 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7438 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7439 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7440 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7441 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7442 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7443 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7444 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7445 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7446 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7447 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7448 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7449 { IBM1047 IBM-1047 }
7450 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7451 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7452 { UNICODE-1-1 csUnicode11 }
7455 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7456 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7458 { ISO-8859-15 ISO_8859-15 Latin-9 }
7459 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7460 { GBK CP936 MS936 windows-936 }
7461 { JIS_Encoding csJISEncoding }
7462 { Shift_JIS MS_Kanji csShiftJIS }
7463 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7465 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7466 { ISO-10646-UCS-Basic csUnicodeASCII }
7467 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7468 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7469 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7470 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7471 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7472 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7473 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7474 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7475 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7476 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7477 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7478 { Ventura-US csVenturaUS }
7479 { Ventura-International csVenturaInternational }
7480 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7481 { PC8-Turkish csPC8Turkish }
7482 { IBM-Symbols csIBMSymbols }
7483 { IBM-Thai csIBMThai }
7484 { HP-Legal csHPLegal }
7485 { HP-Pi-font csHPPiFont }
7486 { HP-Math8 csHPMath8 }
7487 { Adobe-Symbol-Encoding csHPPSMath }
7488 { HP-DeskTop csHPDesktop }
7489 { Ventura-Math csVenturaMath }
7490 { Microsoft-Publishing csMicrosoftPublishing }
7491 { Windows-31J csWindows31J }
7496 proc tcl_encoding {enc} {
7497 global encoding_aliases
7498 set names [encoding names]
7499 set lcnames [string tolower $names]
7500 set enc [string tolower $enc]
7501 set i [lsearch -exact $lcnames $enc]
7503 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7504 if {[regsub {^iso[-_]} $enc iso encx]} {
7505 set i [lsearch -exact $lcnames $encx]
7509 foreach l $encoding_aliases {
7510 set ll [string tolower $l]
7511 if {[lsearch -exact $ll $enc] < 0} continue
7512 # look through the aliases for one that tcl knows about
7514 set i [lsearch -exact $lcnames $e]
7516 if {[regsub {^iso[-_]} $e iso ex]} {
7517 set i [lsearch -exact $lcnames $ex]
7526 return [lindex $names $i]
7533 set diffopts "-U 5 -p"
7534 set wrcomcmd "git diff-tree --stdin -p --pretty"
7538 set gitencoding [exec git config --get i18n.commitencoding]
7540 if {$gitencoding == ""} {
7541 set gitencoding "utf-8"
7543 set tclencoding [tcl_encoding $gitencoding]
7544 if {$tclencoding == {}} {
7545 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7548 set mainfont {Helvetica 9}
7549 set textfont {Courier 9}
7550 set uifont {Helvetica 9 bold}
7552 set findmergefiles 0
7560 set cmitmode "patch"
7561 set wrapcomment "none"
7565 set showlocalchanges 1
7567 set colors {green red blue magenta darkgrey brown orange}
7570 set diffcolors {red "#00a000" blue}
7571 set selectbgcolor gray85
7573 catch {source ~/.gitk}
7575 font create optionfont -family sans-serif -size -12
7577 # check that we can find a .git directory somewhere...
7579 if {![file isdirectory $gitdir]} {
7580 show_error {} . "Cannot find the git directory \"$gitdir\"."
7585 set cmdline_files {}
7590 "-d" { set datemode 1 }
7592 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7596 lappend revtreeargs $arg
7602 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7603 # no -- on command line, but some arguments (other than -d)
7605 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7606 set cmdline_files [split $f "\n"]
7607 set n [llength $cmdline_files]
7608 set revtreeargs [lrange $revtreeargs 0 end-$n]
7609 # Unfortunately git rev-parse doesn't produce an error when
7610 # something is both a revision and a filename. To be consistent
7611 # with git log and git rev-list, check revtreeargs for filenames.
7612 foreach arg $revtreeargs {
7613 if {[file exists $arg]} {
7614 show_error {} . "Ambiguous argument '$arg': both revision\
7620 # unfortunately we get both stdout and stderr in $err,
7621 # so look for "fatal:".
7622 set i [string first "fatal:" $err]
7624 set err [string range $err [expr {$i + 6}] end]
7626 show_error {} . "Bad arguments to gitk:\n$err"
7631 set nullid "0000000000000000000000000000000000000000"
7632 set nullid2 "0000000000000000000000000000000000000001"
7640 set highlight_paths {}
7641 set searchdirn -forwards
7645 set markingmatches 0
7652 set selectedhlview None
7661 set lookingforhead 0
7667 # wait for the window to become visible
7669 wm title . "[file tail $argv0]: [file tail [pwd]]"
7672 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7673 # create a view for the files/dirs specified on the command line
7677 set viewname(1) "Command line"
7678 set viewfiles(1) $cmdline_files
7679 set viewargs(1) $revtreeargs
7682 .bar.view entryconf Edit* -state normal
7683 .bar.view entryconf Delete* -state normal
7686 if {[info exists permviews]} {
7687 foreach v $permviews {
7690 set viewname($n) [lindex $v 0]
7691 set viewfiles($n) [lindex $v 1]
7692 set viewargs($n) [lindex $v 2]