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 vnextroot
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set vnextroot($view) 0
91 set order "--topo-order"
93 set order "--date-order"
96 set fd [open [concat | git log -z --pretty=raw $order --parents \
97 --boundary $viewargs($view) "--" $viewfiles($view)] r]
99 error_popup "Error executing git rev-list: $err"
102 set commfd($view) $fd
103 set leftover($view) {}
104 set lookingforhead $showlocalchanges
105 fconfigure $fd -blocking 0 -translation lf -eofchar {}
106 if {$tclencoding != {}} {
107 fconfigure $fd -encoding $tclencoding
109 filerun $fd [list getcommitlines $fd $view]
113 proc stop_rev_list {} {
114 global commfd curview
116 if {![info exists commfd($curview)]} return
117 set fd $commfd($curview)
123 unset commfd($curview)
127 global phase canv mainfont curview
131 start_rev_list $curview
132 show_status "Reading commits..."
135 # This makes a string representation of a positive integer which
136 # sorts as a string in numerical order
139 return [format "%x" $n]
140 } elseif {$n < 256} {
141 return [format "x%.2x" $n]
142 } elseif {$n < 65536} {
143 return [format "y%.4x" $n]
145 return [format "z%.8x" $n]
148 proc getcommitlines {fd view} {
150 global leftover commfd
151 global displayorder commitidx commitrow commitdata
152 global parentlist children curview hlview
153 global vparentlist vdisporder vcmitlisted
154 global ordertok vnextroot
156 set stuff [read $fd 500000]
157 # git log doesn't terminate the last commit with a null...
158 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
168 # set it blocking so we wait for the process to terminate
169 fconfigure $fd -blocking 1
170 if {[catch {close $fd} err]} {
172 if {$view != $curview} {
173 set fv " for the \"$viewname($view)\" view"
175 if {[string range $err 0 4] == "usage"} {
176 set err "Gitk: error reading commits$fv:\
177 bad arguments to git rev-list."
178 if {$viewname($view) eq "Command line"} {
180 " (Note: arguments to gitk are passed to git rev-list\
181 to allow selection of commits to be displayed.)"
184 set err "Error reading commits$fv: $err"
188 if {$view == $curview} {
189 run chewcommits $view
196 set i [string first "\0" $stuff $start]
198 append leftover($view) [string range $stuff $start end]
202 set cmit $leftover($view)
203 append cmit [string range $stuff 0 [expr {$i - 1}]]
204 set leftover($view) {}
206 set cmit [string range $stuff $start [expr {$i - 1}]]
208 set start [expr {$i + 1}]
209 set j [string first "\n" $cmit]
212 if {$j >= 0 && [string match "commit *" $cmit]} {
213 set ids [string range $cmit 7 [expr {$j - 1}]]
214 if {[string match {[-<>]*} $ids]} {
215 switch -- [string index $ids 0] {
220 set ids [string range $ids 1 end]
224 if {[string length $id] != 40} {
232 if {[string length $shortcmit] > 80} {
233 set shortcmit "[string range $shortcmit 0 80]..."
235 error_popup "Can't parse git log output: {$shortcmit}"
238 set id [lindex $ids 0]
239 if {![info exists ordertok($view,$id)]} {
240 set otok "o[strrep $vnextroot($view)]"
241 incr vnextroot($view)
242 set ordertok($view,$id) $otok
244 set otok $ordertok($view,$id)
247 set olds [lrange $ids 1 end]
248 if {[llength $olds] == 1} {
249 set p [lindex $olds 0]
250 lappend children($view,$p) $id
251 if {![info exists ordertok($view,$p)]} {
252 set ordertok($view,$p) $ordertok($view,$id)
257 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
258 lappend children($view,$p) $id
260 if {![info exists ordertok($view,$p)]} {
261 set ordertok($view,$p) "$otok[strrep $i]]"
269 if {![info exists children($view,$id)]} {
270 set children($view,$id) {}
272 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
273 set commitrow($view,$id) $commitidx($view)
274 incr commitidx($view)
275 if {$view == $curview} {
276 lappend parentlist $olds
277 lappend displayorder $id
278 lappend commitlisted $listed
280 lappend vparentlist($view) $olds
281 lappend vdisporder($view) $id
282 lappend vcmitlisted($view) $listed
287 run chewcommits $view
292 proc chewcommits {view} {
293 global curview hlview commfd
294 global selectedline pending_select
297 if {$view == $curview} {
298 set allread [expr {![info exists commfd($view)]}]
299 set tlimit [expr {[clock clicks -milliseconds] + 50}]
300 set more [layoutmore $tlimit $allread]
301 if {$allread && !$more} {
302 global displayorder commitidx phase
303 global numcommits startmsecs
305 if {[info exists pending_select]} {
306 set row [first_real_row]
309 if {$commitidx($curview) > 0} {
310 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
311 #puts "overall $ms ms for $numcommits commits"
313 show_status "No commits selected"
319 if {[info exists hlview] && $view == $hlview} {
325 proc readcommit {id} {
326 if {[catch {set contents [exec git cat-file commit $id]}]} return
327 parsecommit $id $contents 0
330 proc updatecommits {} {
331 global viewdata curview phase displayorder
332 global children commitrow selectedline thickerline
339 foreach id $displayorder {
340 catch {unset children($n,$id)}
341 catch {unset commitrow($n,$id)}
344 catch {unset selectedline}
345 catch {unset thickerline}
346 catch {unset viewdata($n)}
353 proc parsecommit {id contents listed} {
354 global commitinfo cdate
363 set hdrend [string first "\n\n" $contents]
365 # should never happen...
366 set hdrend [string length $contents]
368 set header [string range $contents 0 [expr {$hdrend - 1}]]
369 set comment [string range $contents [expr {$hdrend + 2}] end]
370 foreach line [split $header "\n"] {
371 set tag [lindex $line 0]
372 if {$tag == "author"} {
373 set audate [lindex $line end-1]
374 set auname [lrange $line 1 end-2]
375 } elseif {$tag == "committer"} {
376 set comdate [lindex $line end-1]
377 set comname [lrange $line 1 end-2]
381 # take the first non-blank line of the comment as the headline
382 set headline [string trimleft $comment]
383 set i [string first "\n" $headline]
385 set headline [string range $headline 0 $i]
387 set headline [string trimright $headline]
388 set i [string first "\r" $headline]
390 set headline [string trimright [string range $headline 0 $i]]
393 # git rev-list indents the comment by 4 spaces;
394 # if we got this via git cat-file, add the indentation
396 foreach line [split $comment "\n"] {
397 append newcomment " "
398 append newcomment $line
399 append newcomment "\n"
401 set comment $newcomment
403 if {$comdate != {}} {
404 set cdate($id) $comdate
406 set commitinfo($id) [list $headline $auname $audate \
407 $comname $comdate $comment]
410 proc getcommit {id} {
411 global commitdata commitinfo
413 if {[info exists commitdata($id)]} {
414 parsecommit $id $commitdata($id) 1
417 if {![info exists commitinfo($id)]} {
418 set commitinfo($id) {"No commit information available"}
425 global tagids idtags headids idheads tagobjid
426 global otherrefids idotherrefs mainhead mainheadid
428 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
431 set refd [open [list | git show-ref -d] r]
432 while {[gets $refd line] >= 0} {
433 if {[string index $line 40] ne " "} continue
434 set id [string range $line 0 39]
435 set ref [string range $line 41 end]
436 if {![string match "refs/*" $ref]} continue
437 set name [string range $ref 5 end]
438 if {[string match "remotes/*" $name]} {
439 if {![string match "*/HEAD" $name]} {
440 set headids($name) $id
441 lappend idheads($id) $name
443 } elseif {[string match "heads/*" $name]} {
444 set name [string range $name 6 end]
445 set headids($name) $id
446 lappend idheads($id) $name
447 } elseif {[string match "tags/*" $name]} {
448 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
449 # which is what we want since the former is the commit ID
450 set name [string range $name 5 end]
451 if {[string match "*^{}" $name]} {
452 set name [string range $name 0 end-3]
454 set tagobjid($name) $id
456 set tagids($name) $id
457 lappend idtags($id) $name
459 set otherrefids($name) $id
460 lappend idotherrefs($id) $name
467 set thehead [exec git symbolic-ref HEAD]
468 if {[string match "refs/heads/*" $thehead]} {
469 set mainhead [string range $thehead 11 end]
470 if {[info exists headids($mainhead)]} {
471 set mainheadid $headids($mainhead)
477 # skip over fake commits
478 proc first_real_row {} {
479 global nullid nullid2 displayorder numcommits
481 for {set row 0} {$row < $numcommits} {incr row} {
482 set id [lindex $displayorder $row]
483 if {$id ne $nullid && $id ne $nullid2} {
490 # update things for a head moved to a child of its previous location
491 proc movehead {id name} {
492 global headids idheads
494 removehead $headids($name) $name
495 set headids($name) $id
496 lappend idheads($id) $name
499 # update things when a head has been removed
500 proc removehead {id name} {
501 global headids idheads
503 if {$idheads($id) eq $name} {
506 set i [lsearch -exact $idheads($id) $name]
508 set idheads($id) [lreplace $idheads($id) $i $i]
514 proc show_error {w top msg} {
515 message $w.m -text $msg -justify center -aspect 400
516 pack $w.m -side top -fill x -padx 20 -pady 20
517 button $w.ok -text OK -command "destroy $top"
518 pack $w.ok -side bottom -fill x
519 bind $top <Visibility> "grab $top; focus $top"
520 bind $top <Key-Return> "destroy $top"
524 proc error_popup msg {
528 show_error $w $w $msg
531 proc confirm_popup msg {
537 message $w.m -text $msg -justify center -aspect 400
538 pack $w.m -side top -fill x -padx 20 -pady 20
539 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
540 pack $w.ok -side left -fill x
541 button $w.cancel -text Cancel -command "destroy $w"
542 pack $w.cancel -side right -fill x
543 bind $w <Visibility> "grab $w; focus $w"
549 global canv canv2 canv3 linespc charspc ctext cflist
550 global textfont mainfont uifont tabstop
551 global findtype findtypemenu findloc findstring fstring geometry
552 global entries sha1entry sha1string sha1but
553 global maincursor textcursor curtextcursor
554 global rowctxmenu fakerowmenu mergemax wrapcomment
555 global highlight_files gdttype
556 global searchstring sstring
557 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
561 .bar add cascade -label "File" -menu .bar.file
562 .bar configure -font $uifont
564 .bar.file add command -label "Update" -command updatecommits
565 .bar.file add command -label "Reread references" -command rereadrefs
566 .bar.file add command -label "Quit" -command doquit
567 .bar.file configure -font $uifont
569 .bar add cascade -label "Edit" -menu .bar.edit
570 .bar.edit add command -label "Preferences" -command doprefs
571 .bar.edit configure -font $uifont
573 menu .bar.view -font $uifont
574 .bar add cascade -label "View" -menu .bar.view
575 .bar.view add command -label "New view..." -command {newview 0}
576 .bar.view add command -label "Edit view..." -command editview \
578 .bar.view add command -label "Delete view" -command delview -state disabled
579 .bar.view add separator
580 .bar.view add radiobutton -label "All files" -command {showview 0} \
581 -variable selectedview -value 0
584 .bar add cascade -label "Help" -menu .bar.help
585 .bar.help add command -label "About gitk" -command about
586 .bar.help add command -label "Key bindings" -command keys
587 .bar.help configure -font $uifont
588 . configure -menu .bar
590 # the gui has upper and lower half, parts of a paned window.
591 panedwindow .ctop -orient vertical
593 # possibly use assumed geometry
594 if {![info exists geometry(pwsash0)]} {
595 set geometry(topheight) [expr {15 * $linespc}]
596 set geometry(topwidth) [expr {80 * $charspc}]
597 set geometry(botheight) [expr {15 * $linespc}]
598 set geometry(botwidth) [expr {50 * $charspc}]
599 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
600 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
603 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
604 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
606 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
608 # create three canvases
609 set cscroll .tf.histframe.csb
610 set canv .tf.histframe.pwclist.canv
612 -selectbackground $selectbgcolor \
613 -background $bgcolor -bd 0 \
614 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
615 .tf.histframe.pwclist add $canv
616 set canv2 .tf.histframe.pwclist.canv2
618 -selectbackground $selectbgcolor \
619 -background $bgcolor -bd 0 -yscrollincr $linespc
620 .tf.histframe.pwclist add $canv2
621 set canv3 .tf.histframe.pwclist.canv3
623 -selectbackground $selectbgcolor \
624 -background $bgcolor -bd 0 -yscrollincr $linespc
625 .tf.histframe.pwclist add $canv3
626 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
627 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
629 # a scroll bar to rule them
630 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
631 pack $cscroll -side right -fill y
632 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
633 lappend bglist $canv $canv2 $canv3
634 pack .tf.histframe.pwclist -fill both -expand 1 -side left
636 # we have two button bars at bottom of top frame. Bar 1
638 frame .tf.lbar -height 15
640 set sha1entry .tf.bar.sha1
641 set entries $sha1entry
642 set sha1but .tf.bar.sha1label
643 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
644 -command gotocommit -width 8 -font $uifont
645 $sha1but conf -disabledforeground [$sha1but cget -foreground]
646 pack .tf.bar.sha1label -side left
647 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
648 trace add variable sha1string write sha1change
649 pack $sha1entry -side left -pady 2
651 image create bitmap bm-left -data {
652 #define left_width 16
653 #define left_height 16
654 static unsigned char left_bits[] = {
655 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
656 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
657 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
659 image create bitmap bm-right -data {
660 #define right_width 16
661 #define right_height 16
662 static unsigned char right_bits[] = {
663 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
664 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
665 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
667 button .tf.bar.leftbut -image bm-left -command goback \
668 -state disabled -width 26
669 pack .tf.bar.leftbut -side left -fill y
670 button .tf.bar.rightbut -image bm-right -command goforw \
671 -state disabled -width 26
672 pack .tf.bar.rightbut -side left -fill y
674 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
675 pack .tf.bar.findbut -side left
677 set fstring .tf.bar.findstring
678 lappend entries $fstring
679 entry $fstring -width 30 -font $textfont -textvariable findstring
680 trace add variable findstring write find_change
681 pack $fstring -side left -expand 1 -fill x -in .tf.bar
683 set findtypemenu [tk_optionMenu .tf.bar.findtype \
684 findtype Exact IgnCase Regexp]
685 trace add variable findtype write find_change
686 .tf.bar.findtype configure -font $uifont
687 .tf.bar.findtype.menu configure -font $uifont
688 set findloc "All fields"
689 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
690 Comments Author Committer
691 trace add variable findloc write find_change
692 .tf.bar.findloc configure -font $uifont
693 .tf.bar.findloc.menu configure -font $uifont
694 pack .tf.bar.findloc -side right
695 pack .tf.bar.findtype -side right
697 # build up the bottom bar of upper window
698 label .tf.lbar.flabel -text "Highlight: Commits " \
700 pack .tf.lbar.flabel -side left -fill y
701 set gdttype "touching paths:"
702 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
703 "adding/removing string:"]
704 trace add variable gdttype write hfiles_change
705 $gm conf -font $uifont
706 .tf.lbar.gdttype conf -font $uifont
707 pack .tf.lbar.gdttype -side left -fill y
708 entry .tf.lbar.fent -width 25 -font $textfont \
709 -textvariable highlight_files
710 trace add variable highlight_files write hfiles_change
711 lappend entries .tf.lbar.fent
712 pack .tf.lbar.fent -side left -fill x -expand 1
713 label .tf.lbar.vlabel -text " OR in view" -font $uifont
714 pack .tf.lbar.vlabel -side left -fill y
715 global viewhlmenu selectedhlview
716 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
717 $viewhlmenu entryconf None -command delvhighlight
718 $viewhlmenu conf -font $uifont
719 .tf.lbar.vhl conf -font $uifont
720 pack .tf.lbar.vhl -side left -fill y
721 label .tf.lbar.rlabel -text " OR " -font $uifont
722 pack .tf.lbar.rlabel -side left -fill y
723 global highlight_related
724 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
725 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
726 $m conf -font $uifont
727 .tf.lbar.relm conf -font $uifont
728 trace add variable highlight_related write vrel_change
729 pack .tf.lbar.relm -side left -fill y
731 # Finish putting the upper half of the viewer together
732 pack .tf.lbar -in .tf -side bottom -fill x
733 pack .tf.bar -in .tf -side bottom -fill x
734 pack .tf.histframe -fill both -side top -expand 1
736 .ctop paneconfigure .tf -height $geometry(topheight)
737 .ctop paneconfigure .tf -width $geometry(topwidth)
739 # now build up the bottom
740 panedwindow .pwbottom -orient horizontal
742 # lower left, a text box over search bar, scroll bar to the right
743 # if we know window height, then that will set the lower text height, otherwise
744 # we set lower text height which will drive window height
745 if {[info exists geometry(main)]} {
746 frame .bleft -width $geometry(botwidth)
748 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
753 button .bleft.top.search -text "Search" -command dosearch \
755 pack .bleft.top.search -side left -padx 5
756 set sstring .bleft.top.sstring
757 entry $sstring -width 20 -font $textfont -textvariable searchstring
758 lappend entries $sstring
759 trace add variable searchstring write incrsearch
760 pack $sstring -side left -expand 1 -fill x
761 radiobutton .bleft.mid.diff -text "Diff" \
762 -command changediffdisp -variable diffelide -value {0 0}
763 radiobutton .bleft.mid.old -text "Old version" \
764 -command changediffdisp -variable diffelide -value {0 1}
765 radiobutton .bleft.mid.new -text "New version" \
766 -command changediffdisp -variable diffelide -value {1 0}
767 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
768 set ctext .bleft.ctext
769 text $ctext -background $bgcolor -foreground $fgcolor \
770 -tabs "[expr {$tabstop * $charspc}]" \
771 -state disabled -font $textfont \
772 -yscrollcommand scrolltext -wrap none
773 scrollbar .bleft.sb -command "$ctext yview"
774 pack .bleft.top -side top -fill x
775 pack .bleft.mid -side top -fill x
776 pack .bleft.sb -side right -fill y
777 pack $ctext -side left -fill both -expand 1
778 lappend bglist $ctext
779 lappend fglist $ctext
781 $ctext tag conf comment -wrap $wrapcomment
782 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
783 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
784 $ctext tag conf d0 -fore [lindex $diffcolors 0]
785 $ctext tag conf d1 -fore [lindex $diffcolors 1]
786 $ctext tag conf m0 -fore red
787 $ctext tag conf m1 -fore blue
788 $ctext tag conf m2 -fore green
789 $ctext tag conf m3 -fore purple
790 $ctext tag conf m4 -fore brown
791 $ctext tag conf m5 -fore "#009090"
792 $ctext tag conf m6 -fore magenta
793 $ctext tag conf m7 -fore "#808000"
794 $ctext tag conf m8 -fore "#009000"
795 $ctext tag conf m9 -fore "#ff0080"
796 $ctext tag conf m10 -fore cyan
797 $ctext tag conf m11 -fore "#b07070"
798 $ctext tag conf m12 -fore "#70b0f0"
799 $ctext tag conf m13 -fore "#70f0b0"
800 $ctext tag conf m14 -fore "#f0b070"
801 $ctext tag conf m15 -fore "#ff70b0"
802 $ctext tag conf mmax -fore darkgrey
804 $ctext tag conf mresult -font [concat $textfont bold]
805 $ctext tag conf msep -font [concat $textfont bold]
806 $ctext tag conf found -back yellow
809 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
814 radiobutton .bright.mode.patch -text "Patch" \
815 -command reselectline -variable cmitmode -value "patch"
816 .bright.mode.patch configure -font $uifont
817 radiobutton .bright.mode.tree -text "Tree" \
818 -command reselectline -variable cmitmode -value "tree"
819 .bright.mode.tree configure -font $uifont
820 grid .bright.mode.patch .bright.mode.tree -sticky ew
821 pack .bright.mode -side top -fill x
822 set cflist .bright.cfiles
823 set indent [font measure $mainfont "nn"]
825 -selectbackground $selectbgcolor \
826 -background $bgcolor -foreground $fgcolor \
828 -tabs [list $indent [expr {2 * $indent}]] \
829 -yscrollcommand ".bright.sb set" \
830 -cursor [. cget -cursor] \
831 -spacing1 1 -spacing3 1
832 lappend bglist $cflist
833 lappend fglist $cflist
834 scrollbar .bright.sb -command "$cflist yview"
835 pack .bright.sb -side right -fill y
836 pack $cflist -side left -fill both -expand 1
837 $cflist tag configure highlight \
838 -background [$cflist cget -selectbackground]
839 $cflist tag configure bold -font [concat $mainfont bold]
841 .pwbottom add .bright
844 # restore window position if known
845 if {[info exists geometry(main)]} {
846 wm geometry . "$geometry(main)"
849 if {[tk windowingsystem] eq {aqua}} {
855 bind .pwbottom <Configure> {resizecdetpanes %W %w}
856 pack .ctop -fill both -expand 1
857 bindall <1> {selcanvline %W %x %y}
858 #bindall <B1-Motion> {selcanvline %W %x %y}
859 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
860 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
861 bindall <2> "canvscan mark %W %x %y"
862 bindall <B2-Motion> "canvscan dragto %W %x %y"
863 bindkey <Home> selfirstline
864 bindkey <End> sellastline
865 bind . <Key-Up> "selnextline -1"
866 bind . <Key-Down> "selnextline 1"
867 bind . <Shift-Key-Up> "next_highlight -1"
868 bind . <Shift-Key-Down> "next_highlight 1"
869 bindkey <Key-Right> "goforw"
870 bindkey <Key-Left> "goback"
871 bind . <Key-Prior> "selnextpage -1"
872 bind . <Key-Next> "selnextpage 1"
873 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
874 bind . <$M1B-End> "allcanvs yview moveto 1.0"
875 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
876 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
877 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
878 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
879 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
880 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
881 bindkey <Key-space> "$ctext yview scroll 1 pages"
882 bindkey p "selnextline -1"
883 bindkey n "selnextline 1"
886 bindkey i "selnextline -1"
887 bindkey k "selnextline 1"
890 bindkey b "$ctext yview scroll -1 pages"
891 bindkey d "$ctext yview scroll 18 units"
892 bindkey u "$ctext yview scroll -18 units"
893 bindkey / {findnext 1}
894 bindkey <Key-Return> {findnext 0}
897 bindkey <F5> updatecommits
898 bind . <$M1B-q> doquit
899 bind . <$M1B-f> dofind
900 bind . <$M1B-g> {findnext 0}
901 bind . <$M1B-r> dosearchback
902 bind . <$M1B-s> dosearch
903 bind . <$M1B-equal> {incrfont 1}
904 bind . <$M1B-KP_Add> {incrfont 1}
905 bind . <$M1B-minus> {incrfont -1}
906 bind . <$M1B-KP_Subtract> {incrfont -1}
907 wm protocol . WM_DELETE_WINDOW doquit
908 bind . <Button-1> "click %W"
909 bind $fstring <Key-Return> dofind
910 bind $sha1entry <Key-Return> gotocommit
911 bind $sha1entry <<PasteSelection>> clearsha1
912 bind $cflist <1> {sel_flist %W %x %y; break}
913 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
914 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
915 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
917 set maincursor [. cget -cursor]
918 set textcursor [$ctext cget -cursor]
919 set curtextcursor $textcursor
921 set rowctxmenu .rowctxmenu
922 menu $rowctxmenu -tearoff 0
923 $rowctxmenu add command -label "Diff this -> selected" \
924 -command {diffvssel 0}
925 $rowctxmenu add command -label "Diff selected -> this" \
926 -command {diffvssel 1}
927 $rowctxmenu add command -label "Make patch" -command mkpatch
928 $rowctxmenu add command -label "Create tag" -command mktag
929 $rowctxmenu add command -label "Write commit to file" -command writecommit
930 $rowctxmenu add command -label "Create new branch" -command mkbranch
931 $rowctxmenu add command -label "Cherry-pick this commit" \
933 $rowctxmenu add command -label "Reset HEAD branch to here" \
936 set fakerowmenu .fakerowmenu
937 menu $fakerowmenu -tearoff 0
938 $fakerowmenu add command -label "Diff this -> selected" \
939 -command {diffvssel 0}
940 $fakerowmenu add command -label "Diff selected -> this" \
941 -command {diffvssel 1}
942 $fakerowmenu add command -label "Make patch" -command mkpatch
943 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
944 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
945 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
947 set headctxmenu .headctxmenu
948 menu $headctxmenu -tearoff 0
949 $headctxmenu add command -label "Check out this branch" \
951 $headctxmenu add command -label "Remove this branch" \
955 set flist_menu .flistctxmenu
956 menu $flist_menu -tearoff 0
957 $flist_menu add command -label "Highlight this too" \
958 -command {flist_hl 0}
959 $flist_menu add command -label "Highlight this only" \
960 -command {flist_hl 1}
963 # mouse-2 makes all windows scan vertically, but only the one
964 # the cursor is in scans horizontally
965 proc canvscan {op w x y} {
966 global canv canv2 canv3
967 foreach c [list $canv $canv2 $canv3] {
976 proc scrollcanv {cscroll f0 f1} {
982 # when we make a key binding for the toplevel, make sure
983 # it doesn't get triggered when that key is pressed in the
984 # find string entry widget.
985 proc bindkey {ev script} {
988 set escript [bind Entry $ev]
989 if {$escript == {}} {
990 set escript [bind Entry <Key>]
993 bind $e $ev "$escript; break"
997 # set the focus back to the toplevel for any click outside
1001 foreach e $entries {
1002 if {$w == $e} return
1007 proc savestuff {w} {
1008 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
1009 global stuffsaved findmergefiles maxgraphpct
1010 global maxwidth showneartags showlocalchanges
1011 global viewname viewfiles viewargs viewperm nextviewnum
1012 global cmitmode wrapcomment
1013 global colors bgcolor fgcolor diffcolors selectbgcolor
1015 if {$stuffsaved} return
1016 if {![winfo viewable .]} return
1018 set f [open "~/.gitk-new" w]
1019 puts $f [list set mainfont $mainfont]
1020 puts $f [list set textfont $textfont]
1021 puts $f [list set uifont $uifont]
1022 puts $f [list set tabstop $tabstop]
1023 puts $f [list set findmergefiles $findmergefiles]
1024 puts $f [list set maxgraphpct $maxgraphpct]
1025 puts $f [list set maxwidth $maxwidth]
1026 puts $f [list set cmitmode $cmitmode]
1027 puts $f [list set wrapcomment $wrapcomment]
1028 puts $f [list set showneartags $showneartags]
1029 puts $f [list set showlocalchanges $showlocalchanges]
1030 puts $f [list set bgcolor $bgcolor]
1031 puts $f [list set fgcolor $fgcolor]
1032 puts $f [list set colors $colors]
1033 puts $f [list set diffcolors $diffcolors]
1034 puts $f [list set selectbgcolor $selectbgcolor]
1036 puts $f "set geometry(main) [wm geometry .]"
1037 puts $f "set geometry(topwidth) [winfo width .tf]"
1038 puts $f "set geometry(topheight) [winfo height .tf]"
1039 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1040 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1041 puts $f "set geometry(botwidth) [winfo width .bleft]"
1042 puts $f "set geometry(botheight) [winfo height .bleft]"
1044 puts -nonewline $f "set permviews {"
1045 for {set v 0} {$v < $nextviewnum} {incr v} {
1046 if {$viewperm($v)} {
1047 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1052 file rename -force "~/.gitk-new" "~/.gitk"
1057 proc resizeclistpanes {win w} {
1059 if {[info exists oldwidth($win)]} {
1060 set s0 [$win sash coord 0]
1061 set s1 [$win sash coord 1]
1063 set sash0 [expr {int($w/2 - 2)}]
1064 set sash1 [expr {int($w*5/6 - 2)}]
1066 set factor [expr {1.0 * $w / $oldwidth($win)}]
1067 set sash0 [expr {int($factor * [lindex $s0 0])}]
1068 set sash1 [expr {int($factor * [lindex $s1 0])}]
1072 if {$sash1 < $sash0 + 20} {
1073 set sash1 [expr {$sash0 + 20}]
1075 if {$sash1 > $w - 10} {
1076 set sash1 [expr {$w - 10}]
1077 if {$sash0 > $sash1 - 20} {
1078 set sash0 [expr {$sash1 - 20}]
1082 $win sash place 0 $sash0 [lindex $s0 1]
1083 $win sash place 1 $sash1 [lindex $s1 1]
1085 set oldwidth($win) $w
1088 proc resizecdetpanes {win w} {
1090 if {[info exists oldwidth($win)]} {
1091 set s0 [$win sash coord 0]
1093 set sash0 [expr {int($w*3/4 - 2)}]
1095 set factor [expr {1.0 * $w / $oldwidth($win)}]
1096 set sash0 [expr {int($factor * [lindex $s0 0])}]
1100 if {$sash0 > $w - 15} {
1101 set sash0 [expr {$w - 15}]
1104 $win sash place 0 $sash0 [lindex $s0 1]
1106 set oldwidth($win) $w
1109 proc allcanvs args {
1110 global canv canv2 canv3
1116 proc bindall {event action} {
1117 global canv canv2 canv3
1118 bind $canv $event $action
1119 bind $canv2 $event $action
1120 bind $canv3 $event $action
1126 if {[winfo exists $w]} {
1131 wm title $w "About gitk"
1132 message $w.m -text {
1133 Gitk - a commit viewer for git
1135 Copyright © 2005-2006 Paul Mackerras
1137 Use and redistribute under the terms of the GNU General Public License} \
1138 -justify center -aspect 400 -border 2 -bg white -relief groove
1139 pack $w.m -side top -fill x -padx 2 -pady 2
1140 $w.m configure -font $uifont
1141 button $w.ok -text Close -command "destroy $w" -default active
1142 pack $w.ok -side bottom
1143 $w.ok configure -font $uifont
1144 bind $w <Visibility> "focus $w.ok"
1145 bind $w <Key-Escape> "destroy $w"
1146 bind $w <Key-Return> "destroy $w"
1152 if {[winfo exists $w]} {
1156 if {[tk windowingsystem] eq {aqua}} {
1162 wm title $w "Gitk key bindings"
1163 message $w.m -text "
1167 <Home> Move to first commit
1168 <End> Move to last commit
1169 <Up>, p, i Move up one commit
1170 <Down>, n, k Move down one commit
1171 <Left>, z, j Go back in history list
1172 <Right>, x, l Go forward in history list
1173 <PageUp> Move up one page in commit list
1174 <PageDown> Move down one page in commit list
1175 <$M1T-Home> Scroll to top of commit list
1176 <$M1T-End> Scroll to bottom of commit list
1177 <$M1T-Up> Scroll commit list up one line
1178 <$M1T-Down> Scroll commit list down one line
1179 <$M1T-PageUp> Scroll commit list up one page
1180 <$M1T-PageDown> Scroll commit list down one page
1181 <Shift-Up> Move to previous highlighted line
1182 <Shift-Down> Move to next highlighted line
1183 <Delete>, b Scroll diff view up one page
1184 <Backspace> Scroll diff view up one page
1185 <Space> Scroll diff view down one page
1186 u Scroll diff view up 18 lines
1187 d Scroll diff view down 18 lines
1189 <$M1T-G> Move to next find hit
1190 <Return> Move to next find hit
1191 / Move to next find hit, or redo find
1192 ? Move to previous find hit
1193 f Scroll diff view to next file
1194 <$M1T-S> Search for next hit in diff view
1195 <$M1T-R> Search for previous hit in diff view
1196 <$M1T-KP+> Increase font size
1197 <$M1T-plus> Increase font size
1198 <$M1T-KP-> Decrease font size
1199 <$M1T-minus> Decrease font size
1202 -justify left -bg white -border 2 -relief groove
1203 pack $w.m -side top -fill both -padx 2 -pady 2
1204 $w.m configure -font $uifont
1205 button $w.ok -text Close -command "destroy $w" -default active
1206 pack $w.ok -side bottom
1207 $w.ok configure -font $uifont
1208 bind $w <Visibility> "focus $w.ok"
1209 bind $w <Key-Escape> "destroy $w"
1210 bind $w <Key-Return> "destroy $w"
1213 # Procedures for manipulating the file list window at the
1214 # bottom right of the overall window.
1216 proc treeview {w l openlevs} {
1217 global treecontents treediropen treeheight treeparent treeindex
1227 set treecontents() {}
1228 $w conf -state normal
1230 while {[string range $f 0 $prefixend] ne $prefix} {
1231 if {$lev <= $openlevs} {
1232 $w mark set e:$treeindex($prefix) "end -1c"
1233 $w mark gravity e:$treeindex($prefix) left
1235 set treeheight($prefix) $ht
1236 incr ht [lindex $htstack end]
1237 set htstack [lreplace $htstack end end]
1238 set prefixend [lindex $prefendstack end]
1239 set prefendstack [lreplace $prefendstack end end]
1240 set prefix [string range $prefix 0 $prefixend]
1243 set tail [string range $f [expr {$prefixend+1}] end]
1244 while {[set slash [string first "/" $tail]] >= 0} {
1247 lappend prefendstack $prefixend
1248 incr prefixend [expr {$slash + 1}]
1249 set d [string range $tail 0 $slash]
1250 lappend treecontents($prefix) $d
1251 set oldprefix $prefix
1253 set treecontents($prefix) {}
1254 set treeindex($prefix) [incr ix]
1255 set treeparent($prefix) $oldprefix
1256 set tail [string range $tail [expr {$slash+1}] end]
1257 if {$lev <= $openlevs} {
1259 set treediropen($prefix) [expr {$lev < $openlevs}]
1260 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1261 $w mark set d:$ix "end -1c"
1262 $w mark gravity d:$ix left
1264 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1266 $w image create end -align center -image $bm -padx 1 \
1268 $w insert end $d [highlight_tag $prefix]
1269 $w mark set s:$ix "end -1c"
1270 $w mark gravity s:$ix left
1275 if {$lev <= $openlevs} {
1278 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1280 $w insert end $tail [highlight_tag $f]
1282 lappend treecontents($prefix) $tail
1285 while {$htstack ne {}} {
1286 set treeheight($prefix) $ht
1287 incr ht [lindex $htstack end]
1288 set htstack [lreplace $htstack end end]
1289 set prefixend [lindex $prefendstack end]
1290 set prefendstack [lreplace $prefendstack end end]
1291 set prefix [string range $prefix 0 $prefixend]
1293 $w conf -state disabled
1296 proc linetoelt {l} {
1297 global treeheight treecontents
1302 foreach e $treecontents($prefix) {
1307 if {[string index $e end] eq "/"} {
1308 set n $treeheight($prefix$e)
1320 proc highlight_tree {y prefix} {
1321 global treeheight treecontents cflist
1323 foreach e $treecontents($prefix) {
1325 if {[highlight_tag $path] ne {}} {
1326 $cflist tag add bold $y.0 "$y.0 lineend"
1329 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1330 set y [highlight_tree $y $path]
1336 proc treeclosedir {w dir} {
1337 global treediropen treeheight treeparent treeindex
1339 set ix $treeindex($dir)
1340 $w conf -state normal
1341 $w delete s:$ix e:$ix
1342 set treediropen($dir) 0
1343 $w image configure a:$ix -image tri-rt
1344 $w conf -state disabled
1345 set n [expr {1 - $treeheight($dir)}]
1346 while {$dir ne {}} {
1347 incr treeheight($dir) $n
1348 set dir $treeparent($dir)
1352 proc treeopendir {w dir} {
1353 global treediropen treeheight treeparent treecontents treeindex
1355 set ix $treeindex($dir)
1356 $w conf -state normal
1357 $w image configure a:$ix -image tri-dn
1358 $w mark set e:$ix s:$ix
1359 $w mark gravity e:$ix right
1362 set n [llength $treecontents($dir)]
1363 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1366 incr treeheight($x) $n
1368 foreach e $treecontents($dir) {
1370 if {[string index $e end] eq "/"} {
1371 set iy $treeindex($de)
1372 $w mark set d:$iy e:$ix
1373 $w mark gravity d:$iy left
1374 $w insert e:$ix $str
1375 set treediropen($de) 0
1376 $w image create e:$ix -align center -image tri-rt -padx 1 \
1378 $w insert e:$ix $e [highlight_tag $de]
1379 $w mark set s:$iy e:$ix
1380 $w mark gravity s:$iy left
1381 set treeheight($de) 1
1383 $w insert e:$ix $str
1384 $w insert e:$ix $e [highlight_tag $de]
1387 $w mark gravity e:$ix left
1388 $w conf -state disabled
1389 set treediropen($dir) 1
1390 set top [lindex [split [$w index @0,0] .] 0]
1391 set ht [$w cget -height]
1392 set l [lindex [split [$w index s:$ix] .] 0]
1395 } elseif {$l + $n + 1 > $top + $ht} {
1396 set top [expr {$l + $n + 2 - $ht}]
1404 proc treeclick {w x y} {
1405 global treediropen cmitmode ctext cflist cflist_top
1407 if {$cmitmode ne "tree"} return
1408 if {![info exists cflist_top]} return
1409 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1410 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1411 $cflist tag add highlight $l.0 "$l.0 lineend"
1417 set e [linetoelt $l]
1418 if {[string index $e end] ne "/"} {
1420 } elseif {$treediropen($e)} {
1427 proc setfilelist {id} {
1428 global treefilelist cflist
1430 treeview $cflist $treefilelist($id) 0
1433 image create bitmap tri-rt -background black -foreground blue -data {
1434 #define tri-rt_width 13
1435 #define tri-rt_height 13
1436 static unsigned char tri-rt_bits[] = {
1437 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1438 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1441 #define tri-rt-mask_width 13
1442 #define tri-rt-mask_height 13
1443 static unsigned char tri-rt-mask_bits[] = {
1444 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1445 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1448 image create bitmap tri-dn -background black -foreground blue -data {
1449 #define tri-dn_width 13
1450 #define tri-dn_height 13
1451 static unsigned char tri-dn_bits[] = {
1452 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1453 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1456 #define tri-dn-mask_width 13
1457 #define tri-dn-mask_height 13
1458 static unsigned char tri-dn-mask_bits[] = {
1459 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1460 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1464 proc init_flist {first} {
1465 global cflist cflist_top selectedline difffilestart
1467 $cflist conf -state normal
1468 $cflist delete 0.0 end
1470 $cflist insert end $first
1472 $cflist tag add highlight 1.0 "1.0 lineend"
1474 catch {unset cflist_top}
1476 $cflist conf -state disabled
1477 set difffilestart {}
1480 proc highlight_tag {f} {
1481 global highlight_paths
1483 foreach p $highlight_paths {
1484 if {[string match $p $f]} {
1491 proc highlight_filelist {} {
1492 global cmitmode cflist
1494 $cflist conf -state normal
1495 if {$cmitmode ne "tree"} {
1496 set end [lindex [split [$cflist index end] .] 0]
1497 for {set l 2} {$l < $end} {incr l} {
1498 set line [$cflist get $l.0 "$l.0 lineend"]
1499 if {[highlight_tag $line] ne {}} {
1500 $cflist tag add bold $l.0 "$l.0 lineend"
1506 $cflist conf -state disabled
1509 proc unhighlight_filelist {} {
1512 $cflist conf -state normal
1513 $cflist tag remove bold 1.0 end
1514 $cflist conf -state disabled
1517 proc add_flist {fl} {
1520 $cflist conf -state normal
1522 $cflist insert end "\n"
1523 $cflist insert end $f [highlight_tag $f]
1525 $cflist conf -state disabled
1528 proc sel_flist {w x y} {
1529 global ctext difffilestart cflist cflist_top cmitmode
1531 if {$cmitmode eq "tree"} return
1532 if {![info exists cflist_top]} return
1533 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1534 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1535 $cflist tag add highlight $l.0 "$l.0 lineend"
1540 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1544 proc pop_flist_menu {w X Y x y} {
1545 global ctext cflist cmitmode flist_menu flist_menu_file
1546 global treediffs diffids
1548 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1550 if {$cmitmode eq "tree"} {
1551 set e [linetoelt $l]
1552 if {[string index $e end] eq "/"} return
1554 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1556 set flist_menu_file $e
1557 tk_popup $flist_menu $X $Y
1560 proc flist_hl {only} {
1561 global flist_menu_file highlight_files
1563 set x [shellquote $flist_menu_file]
1564 if {$only || $highlight_files eq {}} {
1565 set highlight_files $x
1567 append highlight_files " " $x
1571 # Functions for adding and removing shell-type quoting
1573 proc shellquote {str} {
1574 if {![string match "*\['\"\\ \t]*" $str]} {
1577 if {![string match "*\['\"\\]*" $str]} {
1580 if {![string match "*'*" $str]} {
1583 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1586 proc shellarglist {l} {
1592 append str [shellquote $a]
1597 proc shelldequote {str} {
1602 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1603 append ret [string range $str $used end]
1604 set used [string length $str]
1607 set first [lindex $first 0]
1608 set ch [string index $str $first]
1609 if {$first > $used} {
1610 append ret [string range $str $used [expr {$first - 1}]]
1613 if {$ch eq " " || $ch eq "\t"} break
1616 set first [string first "'" $str $used]
1618 error "unmatched single-quote"
1620 append ret [string range $str $used [expr {$first - 1}]]
1625 if {$used >= [string length $str]} {
1626 error "trailing backslash"
1628 append ret [string index $str $used]
1633 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1634 error "unmatched double-quote"
1636 set first [lindex $first 0]
1637 set ch [string index $str $first]
1638 if {$first > $used} {
1639 append ret [string range $str $used [expr {$first - 1}]]
1642 if {$ch eq "\""} break
1644 append ret [string index $str $used]
1648 return [list $used $ret]
1651 proc shellsplit {str} {
1654 set str [string trimleft $str]
1655 if {$str eq {}} break
1656 set dq [shelldequote $str]
1657 set n [lindex $dq 0]
1658 set word [lindex $dq 1]
1659 set str [string range $str $n end]
1665 # Code to implement multiple views
1667 proc newview {ishighlight} {
1668 global nextviewnum newviewname newviewperm uifont newishighlight
1669 global newviewargs revtreeargs
1671 set newishighlight $ishighlight
1673 if {[winfo exists $top]} {
1677 set newviewname($nextviewnum) "View $nextviewnum"
1678 set newviewperm($nextviewnum) 0
1679 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1680 vieweditor $top $nextviewnum "Gitk view definition"
1685 global viewname viewperm newviewname newviewperm
1686 global viewargs newviewargs
1688 set top .gitkvedit-$curview
1689 if {[winfo exists $top]} {
1693 set newviewname($curview) $viewname($curview)
1694 set newviewperm($curview) $viewperm($curview)
1695 set newviewargs($curview) [shellarglist $viewargs($curview)]
1696 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1699 proc vieweditor {top n title} {
1700 global newviewname newviewperm viewfiles
1704 wm title $top $title
1705 label $top.nl -text "Name" -font $uifont
1706 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1707 grid $top.nl $top.name -sticky w -pady 5
1708 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1710 grid $top.perm - -pady 5 -sticky w
1711 message $top.al -aspect 1000 -font $uifont \
1712 -text "Commits to include (arguments to git rev-list):"
1713 grid $top.al - -sticky w -pady 5
1714 entry $top.args -width 50 -textvariable newviewargs($n) \
1715 -background white -font $uifont
1716 grid $top.args - -sticky ew -padx 5
1717 message $top.l -aspect 1000 -font $uifont \
1718 -text "Enter files and directories to include, one per line:"
1719 grid $top.l - -sticky w
1720 text $top.t -width 40 -height 10 -background white -font $uifont
1721 if {[info exists viewfiles($n)]} {
1722 foreach f $viewfiles($n) {
1723 $top.t insert end $f
1724 $top.t insert end "\n"
1726 $top.t delete {end - 1c} end
1727 $top.t mark set insert 0.0
1729 grid $top.t - -sticky ew -padx 5
1731 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1733 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1735 grid $top.buts.ok $top.buts.can
1736 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1737 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1738 grid $top.buts - -pady 10 -sticky ew
1742 proc doviewmenu {m first cmd op argv} {
1743 set nmenu [$m index end]
1744 for {set i $first} {$i <= $nmenu} {incr i} {
1745 if {[$m entrycget $i -command] eq $cmd} {
1746 eval $m $op $i $argv
1752 proc allviewmenus {n op args} {
1755 doviewmenu .bar.view 5 [list showview $n] $op $args
1756 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1759 proc newviewok {top n} {
1760 global nextviewnum newviewperm newviewname newishighlight
1761 global viewname viewfiles viewperm selectedview curview
1762 global viewargs newviewargs viewhlmenu
1765 set newargs [shellsplit $newviewargs($n)]
1767 error_popup "Error in commit selection arguments: $err"
1773 foreach f [split [$top.t get 0.0 end] "\n"] {
1774 set ft [string trim $f]
1779 if {![info exists viewfiles($n)]} {
1780 # creating a new view
1782 set viewname($n) $newviewname($n)
1783 set viewperm($n) $newviewperm($n)
1784 set viewfiles($n) $files
1785 set viewargs($n) $newargs
1787 if {!$newishighlight} {
1790 run addvhighlight $n
1793 # editing an existing view
1794 set viewperm($n) $newviewperm($n)
1795 if {$newviewname($n) ne $viewname($n)} {
1796 set viewname($n) $newviewname($n)
1797 doviewmenu .bar.view 5 [list showview $n] \
1798 entryconf [list -label $viewname($n)]
1799 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1800 entryconf [list -label $viewname($n) -value $viewname($n)]
1802 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1803 set viewfiles($n) $files
1804 set viewargs($n) $newargs
1805 if {$curview == $n} {
1810 catch {destroy $top}
1814 global curview viewdata viewperm hlview selectedhlview
1816 if {$curview == 0} return
1817 if {[info exists hlview] && $hlview == $curview} {
1818 set selectedhlview None
1821 allviewmenus $curview delete
1822 set viewdata($curview) {}
1823 set viewperm($curview) 0
1827 proc addviewmenu {n} {
1828 global viewname viewhlmenu
1830 .bar.view add radiobutton -label $viewname($n) \
1831 -command [list showview $n] -variable selectedview -value $n
1832 $viewhlmenu add radiobutton -label $viewname($n) \
1833 -command [list addvhighlight $n] -variable selectedhlview
1836 proc flatten {var} {
1840 foreach i [array names $var] {
1841 lappend ret $i [set $var\($i\)]
1846 proc unflatten {var l} {
1856 global curview viewdata viewfiles
1857 global displayorder parentlist rowidlist
1858 global colormap rowtextx commitrow nextcolor canvxmax
1859 global numcommits rowrangelist commitlisted idrowranges rowchk
1860 global selectedline currentid canv canvy0
1862 global pending_select phase
1863 global commitidx rowlaidout rowoptim
1865 global selectedview selectfirst
1866 global vparentlist vdisporder vcmitlisted
1867 global hlview selectedhlview
1869 if {$n == $curview} return
1871 if {[info exists selectedline]} {
1872 set selid $currentid
1873 set y [yc $selectedline]
1874 set ymax [lindex [$canv cget -scrollregion] 3]
1875 set span [$canv yview]
1876 set ytop [expr {[lindex $span 0] * $ymax}]
1877 set ybot [expr {[lindex $span 1] * $ymax}]
1878 if {$ytop < $y && $y < $ybot} {
1879 set yscreen [expr {$y - $ytop}]
1881 set yscreen [expr {($ybot - $ytop) / 2}]
1883 } elseif {[info exists pending_select]} {
1884 set selid $pending_select
1885 unset pending_select
1889 if {$curview >= 0} {
1890 set vparentlist($curview) $parentlist
1891 set vdisporder($curview) $displayorder
1892 set vcmitlisted($curview) $commitlisted
1894 set viewdata($curview) \
1895 [list $phase $rowidlist {} $rowrangelist \
1896 [flatten idrowranges] [flatten idinlist] \
1897 $rowlaidout $rowoptim $numcommits]
1898 } elseif {![info exists viewdata($curview)]
1899 || [lindex $viewdata($curview) 0] ne {}} {
1900 set viewdata($curview) \
1901 [list {} $rowidlist {} $rowrangelist]
1904 catch {unset treediffs}
1906 if {[info exists hlview] && $hlview == $n} {
1908 set selectedhlview None
1913 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1914 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1916 if {![info exists viewdata($n)]} {
1918 set pending_select $selid
1925 set phase [lindex $v 0]
1926 set displayorder $vdisporder($n)
1927 set parentlist $vparentlist($n)
1928 set commitlisted $vcmitlisted($n)
1929 set rowidlist [lindex $v 1]
1930 set rowrangelist [lindex $v 3]
1932 set numcommits [llength $displayorder]
1933 catch {unset idrowranges}
1935 unflatten idrowranges [lindex $v 4]
1936 unflatten idinlist [lindex $v 5]
1937 set rowlaidout [lindex $v 6]
1938 set rowoptim [lindex $v 7]
1939 set numcommits [lindex $v 8]
1940 catch {unset rowchk}
1943 catch {unset colormap}
1944 catch {unset rowtextx}
1946 set canvxmax [$canv cget -width]
1953 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1954 set row $commitrow($n,$selid)
1955 # try to get the selected row in the same position on the screen
1956 set ymax [lindex [$canv cget -scrollregion] 3]
1957 set ytop [expr {[yc $row] - $yscreen}]
1961 set yf [expr {$ytop * 1.0 / $ymax}]
1963 allcanvs yview moveto $yf
1967 } elseif {$selid ne {}} {
1968 set pending_select $selid
1970 set row [first_real_row]
1971 if {$row < $numcommits} {
1978 if {$phase eq "getcommits"} {
1979 show_status "Reading commits..."
1982 } elseif {$numcommits == 0} {
1983 show_status "No commits selected"
1987 # Stuff relating to the highlighting facility
1989 proc ishighlighted {row} {
1990 global vhighlights fhighlights nhighlights rhighlights
1992 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1993 return $nhighlights($row)
1995 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1996 return $vhighlights($row)
1998 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1999 return $fhighlights($row)
2001 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2002 return $rhighlights($row)
2007 proc bolden {row font} {
2008 global canv linehtag selectedline boldrows
2010 lappend boldrows $row
2011 $canv itemconf $linehtag($row) -font $font
2012 if {[info exists selectedline] && $row == $selectedline} {
2014 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2015 -outline {{}} -tags secsel \
2016 -fill [$canv cget -selectbackground]]
2021 proc bolden_name {row font} {
2022 global canv2 linentag selectedline boldnamerows
2024 lappend boldnamerows $row
2025 $canv2 itemconf $linentag($row) -font $font
2026 if {[info exists selectedline] && $row == $selectedline} {
2027 $canv2 delete secsel
2028 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2029 -outline {{}} -tags secsel \
2030 -fill [$canv2 cget -selectbackground]]
2036 global mainfont boldrows
2039 foreach row $boldrows {
2040 if {![ishighlighted $row]} {
2041 bolden $row $mainfont
2043 lappend stillbold $row
2046 set boldrows $stillbold
2049 proc addvhighlight {n} {
2050 global hlview curview viewdata vhl_done vhighlights commitidx
2052 if {[info exists hlview]} {
2056 if {$n != $curview && ![info exists viewdata($n)]} {
2057 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
2058 set vparentlist($n) {}
2059 set vdisporder($n) {}
2060 set vcmitlisted($n) {}
2063 set vhl_done $commitidx($hlview)
2064 if {$vhl_done > 0} {
2069 proc delvhighlight {} {
2070 global hlview vhighlights
2072 if {![info exists hlview]} return
2074 catch {unset vhighlights}
2078 proc vhighlightmore {} {
2079 global hlview vhl_done commitidx vhighlights
2080 global displayorder vdisporder curview mainfont
2082 set font [concat $mainfont bold]
2083 set max $commitidx($hlview)
2084 if {$hlview == $curview} {
2085 set disp $displayorder
2087 set disp $vdisporder($hlview)
2089 set vr [visiblerows]
2090 set r0 [lindex $vr 0]
2091 set r1 [lindex $vr 1]
2092 for {set i $vhl_done} {$i < $max} {incr i} {
2093 set id [lindex $disp $i]
2094 if {[info exists commitrow($curview,$id)]} {
2095 set row $commitrow($curview,$id)
2096 if {$r0 <= $row && $row <= $r1} {
2097 if {![highlighted $row]} {
2100 set vhighlights($row) 1
2107 proc askvhighlight {row id} {
2108 global hlview vhighlights commitrow iddrawn mainfont
2110 if {[info exists commitrow($hlview,$id)]} {
2111 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2112 bolden $row [concat $mainfont bold]
2114 set vhighlights($row) 1
2116 set vhighlights($row) 0
2120 proc hfiles_change {name ix op} {
2121 global highlight_files filehighlight fhighlights fh_serial
2122 global mainfont highlight_paths
2124 if {[info exists filehighlight]} {
2125 # delete previous highlights
2126 catch {close $filehighlight}
2128 catch {unset fhighlights}
2130 unhighlight_filelist
2132 set highlight_paths {}
2133 after cancel do_file_hl $fh_serial
2135 if {$highlight_files ne {}} {
2136 after 300 do_file_hl $fh_serial
2140 proc makepatterns {l} {
2143 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2144 if {[string index $ee end] eq "/"} {
2154 proc do_file_hl {serial} {
2155 global highlight_files filehighlight highlight_paths gdttype fhl_list
2157 if {$gdttype eq "touching paths:"} {
2158 if {[catch {set paths [shellsplit $highlight_files]}]} return
2159 set highlight_paths [makepatterns $paths]
2161 set gdtargs [concat -- $paths]
2163 set gdtargs [list "-S$highlight_files"]
2165 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2166 set filehighlight [open $cmd r+]
2167 fconfigure $filehighlight -blocking 0
2168 filerun $filehighlight readfhighlight
2174 proc flushhighlights {} {
2175 global filehighlight fhl_list
2177 if {[info exists filehighlight]} {
2179 puts $filehighlight ""
2180 flush $filehighlight
2184 proc askfilehighlight {row id} {
2185 global filehighlight fhighlights fhl_list
2187 lappend fhl_list $id
2188 set fhighlights($row) -1
2189 puts $filehighlight $id
2192 proc readfhighlight {} {
2193 global filehighlight fhighlights commitrow curview mainfont iddrawn
2196 if {![info exists filehighlight]} {
2200 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2201 set line [string trim $line]
2202 set i [lsearch -exact $fhl_list $line]
2203 if {$i < 0} continue
2204 for {set j 0} {$j < $i} {incr j} {
2205 set id [lindex $fhl_list $j]
2206 if {[info exists commitrow($curview,$id)]} {
2207 set fhighlights($commitrow($curview,$id)) 0
2210 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2211 if {$line eq {}} continue
2212 if {![info exists commitrow($curview,$line)]} continue
2213 set row $commitrow($curview,$line)
2214 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2215 bolden $row [concat $mainfont bold]
2217 set fhighlights($row) 1
2219 if {[eof $filehighlight]} {
2221 puts "oops, git diff-tree died"
2222 catch {close $filehighlight}
2230 proc find_change {name ix op} {
2231 global nhighlights mainfont boldnamerows
2232 global findstring findpattern findtype
2234 # delete previous highlights, if any
2235 foreach row $boldnamerows {
2236 bolden_name $row $mainfont
2239 catch {unset nhighlights}
2242 if {$findtype ne "Regexp"} {
2243 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2245 set findpattern "*$e*"
2250 proc doesmatch {f} {
2251 global findtype findstring findpattern
2253 if {$findtype eq "Regexp"} {
2254 return [regexp $findstring $f]
2255 } elseif {$findtype eq "IgnCase"} {
2256 return [string match -nocase $findpattern $f]
2258 return [string match $findpattern $f]
2262 proc askfindhighlight {row id} {
2263 global nhighlights commitinfo iddrawn mainfont
2265 global markingmatches
2267 if {![info exists commitinfo($id)]} {
2270 set info $commitinfo($id)
2272 set fldtypes {Headline Author Date Committer CDate Comments}
2273 foreach f $info ty $fldtypes {
2274 if {($findloc eq "All fields" || $findloc eq $ty) &&
2276 if {$ty eq "Author"} {
2283 if {$isbold && [info exists iddrawn($id)]} {
2284 set f [concat $mainfont bold]
2285 if {![ishighlighted $row]} {
2291 if {$markingmatches} {
2292 markrowmatches $row $id
2295 set nhighlights($row) $isbold
2298 proc markrowmatches {row id} {
2299 global canv canv2 linehtag linentag commitinfo findloc
2301 set headline [lindex $commitinfo($id) 0]
2302 set author [lindex $commitinfo($id) 1]
2303 $canv delete match$row
2304 $canv2 delete match$row
2305 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2306 set m [findmatches $headline]
2308 markmatches $canv $row $headline $linehtag($row) $m \
2309 [$canv itemcget $linehtag($row) -font] $row
2312 if {$findloc eq "All fields" || $findloc eq "Author"} {
2313 set m [findmatches $author]
2315 markmatches $canv2 $row $author $linentag($row) $m \
2316 [$canv2 itemcget $linentag($row) -font] $row
2321 proc vrel_change {name ix op} {
2322 global highlight_related
2325 if {$highlight_related ne "None"} {
2330 # prepare for testing whether commits are descendents or ancestors of a
2331 proc rhighlight_sel {a} {
2332 global descendent desc_todo ancestor anc_todo
2333 global highlight_related rhighlights
2335 catch {unset descendent}
2336 set desc_todo [list $a]
2337 catch {unset ancestor}
2338 set anc_todo [list $a]
2339 if {$highlight_related ne "None"} {
2345 proc rhighlight_none {} {
2348 catch {unset rhighlights}
2352 proc is_descendent {a} {
2353 global curview children commitrow descendent desc_todo
2356 set la $commitrow($v,$a)
2360 for {set i 0} {$i < [llength $todo]} {incr i} {
2361 set do [lindex $todo $i]
2362 if {$commitrow($v,$do) < $la} {
2363 lappend leftover $do
2366 foreach nk $children($v,$do) {
2367 if {![info exists descendent($nk)]} {
2368 set descendent($nk) 1
2376 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2380 set descendent($a) 0
2381 set desc_todo $leftover
2384 proc is_ancestor {a} {
2385 global curview parentlist commitrow ancestor anc_todo
2388 set la $commitrow($v,$a)
2392 for {set i 0} {$i < [llength $todo]} {incr i} {
2393 set do [lindex $todo $i]
2394 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2395 lappend leftover $do
2398 foreach np [lindex $parentlist $commitrow($v,$do)] {
2399 if {![info exists ancestor($np)]} {
2408 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2413 set anc_todo $leftover
2416 proc askrelhighlight {row id} {
2417 global descendent highlight_related iddrawn mainfont rhighlights
2418 global selectedline ancestor
2420 if {![info exists selectedline]} return
2422 if {$highlight_related eq "Descendent" ||
2423 $highlight_related eq "Not descendent"} {
2424 if {![info exists descendent($id)]} {
2427 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2430 } elseif {$highlight_related eq "Ancestor" ||
2431 $highlight_related eq "Not ancestor"} {
2432 if {![info exists ancestor($id)]} {
2435 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2439 if {[info exists iddrawn($id)]} {
2440 if {$isbold && ![ishighlighted $row]} {
2441 bolden $row [concat $mainfont bold]
2444 set rhighlights($row) $isbold
2447 proc next_hlcont {} {
2448 global fhl_row fhl_dirn displayorder numcommits
2449 global vhighlights fhighlights nhighlights rhighlights
2450 global hlview filehighlight findstring highlight_related
2452 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2455 if {$row < 0 || $row >= $numcommits} {
2460 set id [lindex $displayorder $row]
2461 if {[info exists hlview]} {
2462 if {![info exists vhighlights($row)]} {
2463 askvhighlight $row $id
2465 if {$vhighlights($row) > 0} break
2467 if {$findstring ne {}} {
2468 if {![info exists nhighlights($row)]} {
2469 askfindhighlight $row $id
2471 if {$nhighlights($row) > 0} break
2473 if {$highlight_related ne "None"} {
2474 if {![info exists rhighlights($row)]} {
2475 askrelhighlight $row $id
2477 if {$rhighlights($row) > 0} break
2479 if {[info exists filehighlight]} {
2480 if {![info exists fhighlights($row)]} {
2481 # ask for a few more while we're at it...
2483 for {set n 0} {$n < 100} {incr n} {
2484 if {![info exists fhighlights($r)]} {
2485 askfilehighlight $r [lindex $displayorder $r]
2488 if {$r < 0 || $r >= $numcommits} break
2492 if {$fhighlights($row) < 0} {
2496 if {$fhighlights($row) > 0} break
2504 proc next_highlight {dirn} {
2505 global selectedline fhl_row fhl_dirn
2506 global hlview filehighlight findstring highlight_related
2508 if {![info exists selectedline]} return
2509 if {!([info exists hlview] || $findstring ne {} ||
2510 $highlight_related ne "None" || [info exists filehighlight])} return
2511 set fhl_row [expr {$selectedline + $dirn}]
2516 proc cancel_next_highlight {} {
2522 # Graph layout functions
2524 proc shortids {ids} {
2527 if {[llength $id] > 1} {
2528 lappend res [shortids $id]
2529 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2530 lappend res [string range $id 0 7]
2538 proc incrange {l x o} {
2541 set e [lindex $l $x]
2543 lset l $x [expr {$e + $o}]
2552 for {} {$n > 0} {incr n -1} {
2558 proc usedinrange {id l1 l2} {
2559 global children commitrow curview
2561 if {[info exists commitrow($curview,$id)]} {
2562 set r $commitrow($curview,$id)
2563 if {$l1 <= $r && $r <= $l2} {
2564 return [expr {$r - $l1 + 1}]
2567 set kids $children($curview,$id)
2569 set r $commitrow($curview,$c)
2570 if {$l1 <= $r && $r <= $l2} {
2571 return [expr {$r - $l1 + 1}]
2577 # Work out where id should go in idlist so that order-token
2578 # values increase from left to right
2579 proc idcol {idlist id {i 0}} {
2580 global ordertok curview
2582 set t $ordertok($curview,$id)
2583 if {$i >= [llength $idlist] ||
2584 $t < $ordertok($curview,[lindex $idlist $i])} {
2585 if {$i > [llength $idlist]} {
2586 set i [llength $idlist]
2588 while {[incr i -1] >= 0 &&
2589 $t < $ordertok($curview,[lindex $idlist $i])} {}
2592 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2593 while {[incr i] < [llength $idlist] &&
2594 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2600 proc makeuparrow {oid y x} {
2601 global rowidlist uparrowlen idrowranges displayorder
2603 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2605 set idl [lindex $rowidlist $y]
2606 set x [idcol $idl $oid $x]
2607 lset rowidlist $y [linsert $idl $x $oid]
2609 lappend idrowranges($oid) [lindex $displayorder $y]
2612 proc initlayout {} {
2613 global rowidlist displayorder commitlisted
2614 global rowlaidout rowoptim
2615 global idinlist rowchk rowrangelist idrowranges
2616 global numcommits canvxmax canv
2619 global colormap rowtextx
2629 catch {unset idinlist}
2630 catch {unset rowchk}
2633 set canvxmax [$canv cget -width]
2634 catch {unset colormap}
2635 catch {unset rowtextx}
2636 catch {unset idrowranges}
2640 proc setcanvscroll {} {
2641 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2643 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2644 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2645 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2646 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2649 proc visiblerows {} {
2650 global canv numcommits linespc
2652 set ymax [lindex [$canv cget -scrollregion] 3]
2653 if {$ymax eq {} || $ymax == 0} return
2655 set y0 [expr {int([lindex $f 0] * $ymax)}]
2656 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2660 set y1 [expr {int([lindex $f 1] * $ymax)}]
2661 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2662 if {$r1 >= $numcommits} {
2663 set r1 [expr {$numcommits - 1}]
2665 return [list $r0 $r1]
2668 proc layoutmore {tmax allread} {
2669 global rowlaidout rowoptim commitidx numcommits optim_delay
2670 global uparrowlen curview rowidlist idinlist
2673 set showdelay $optim_delay
2674 set optdelay [expr {$uparrowlen + 1}]
2676 if {$rowoptim - $showdelay > $numcommits} {
2677 showstuff [expr {$rowoptim - $showdelay}] $showlast
2678 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2679 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2683 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2685 } elseif {$commitidx($curview) > $rowlaidout} {
2686 set nr [expr {$commitidx($curview) - $rowlaidout}]
2687 # may need to increase this threshold if uparrowlen or
2688 # mingaplen are increased...
2693 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2694 if {$rowlaidout == $row} {
2697 } elseif {$allread} {
2699 set nrows $commitidx($curview)
2700 if {[lindex $rowidlist $nrows] ne {} ||
2701 [array names idinlist] ne {}} {
2703 set rowlaidout $commitidx($curview)
2704 } elseif {$rowoptim == $nrows} {
2707 if {$numcommits == $nrows} {
2714 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2720 proc showstuff {canshow last} {
2721 global numcommits commitrow pending_select selectedline curview
2722 global lookingforhead mainheadid displayorder selectfirst
2723 global lastscrollset
2725 if {$numcommits == 0} {
2727 set phase "incrdraw"
2731 set prev $numcommits
2732 set numcommits $canshow
2733 set t [clock clicks -milliseconds]
2734 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2735 set lastscrollset $t
2738 set rows [visiblerows]
2739 set r1 [lindex $rows 1]
2740 if {$r1 >= $canshow} {
2741 set r1 [expr {$canshow - 1}]
2746 if {[info exists pending_select] &&
2747 [info exists commitrow($curview,$pending_select)] &&
2748 $commitrow($curview,$pending_select) < $numcommits} {
2749 selectline $commitrow($curview,$pending_select) 1
2752 if {[info exists selectedline] || [info exists pending_select]} {
2755 set l [first_real_row]
2760 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2761 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2762 set lookingforhead 0
2767 proc doshowlocalchanges {} {
2768 global lookingforhead curview mainheadid phase commitrow
2770 if {[info exists commitrow($curview,$mainheadid)] &&
2771 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2773 } elseif {$phase ne {}} {
2774 set lookingforhead 1
2778 proc dohidelocalchanges {} {
2779 global lookingforhead localfrow localirow lserial
2781 set lookingforhead 0
2782 if {$localfrow >= 0} {
2783 removerow $localfrow
2785 if {$localirow > 0} {
2789 if {$localirow >= 0} {
2790 removerow $localirow
2796 # spawn off a process to do git diff-index --cached HEAD
2797 proc dodiffindex {} {
2798 global localirow localfrow lserial
2803 set fd [open "|git diff-index --cached HEAD" r]
2804 fconfigure $fd -blocking 0
2805 filerun $fd [list readdiffindex $fd $lserial]
2808 proc readdiffindex {fd serial} {
2809 global localirow commitrow mainheadid nullid2 curview
2810 global commitinfo commitdata lserial
2813 if {[gets $fd line] < 0} {
2819 # we only need to see one line and we don't really care what it says...
2822 # now see if there are any local changes not checked in to the index
2823 if {$serial == $lserial} {
2824 set fd [open "|git diff-files" r]
2825 fconfigure $fd -blocking 0
2826 filerun $fd [list readdifffiles $fd $serial]
2829 if {$isdiff && $serial == $lserial && $localirow == -1} {
2830 # add the line for the changes in the index to the graph
2831 set localirow $commitrow($curview,$mainheadid)
2832 set hl "Local changes checked in to index but not committed"
2833 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2834 set commitdata($nullid2) "\n $hl\n"
2835 insertrow $localirow $nullid2
2840 proc readdifffiles {fd serial} {
2841 global localirow localfrow commitrow mainheadid nullid curview
2842 global commitinfo commitdata lserial
2845 if {[gets $fd line] < 0} {
2851 # we only need to see one line and we don't really care what it says...
2854 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2855 # add the line for the local diff to the graph
2856 if {$localirow >= 0} {
2857 set localfrow $localirow
2860 set localfrow $commitrow($curview,$mainheadid)
2862 set hl "Local uncommitted changes, not checked in to index"
2863 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2864 set commitdata($nullid) "\n $hl\n"
2865 insertrow $localfrow $nullid
2870 proc layoutrows {row endrow last} {
2871 global rowidlist displayorder
2872 global uparrowlen downarrowlen maxwidth mingaplen
2873 global children parentlist
2875 global commitidx curview
2876 global idinlist rowchk rowrangelist
2878 set idlist [lindex $rowidlist $row]
2879 while {$row < $endrow} {
2880 set id [lindex $displayorder $row]
2883 set olds [lindex $parentlist $row]
2885 if {![info exists idinlist($p)]} {
2887 } elseif {!$idinlist($p)} {
2891 set nev [expr {[llength $idlist] + [llength $newolds]
2892 + [llength $oldolds] - $maxwidth + 1}]
2893 if {1 || $nev > 0} {
2895 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2896 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2897 set i [lindex $idlist $x]
2898 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2899 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2900 [expr {$row + $uparrowlen + $mingaplen}]]
2902 set idlist [lreplace $idlist $x $x]
2904 set rm1 [expr {$row - 1}]
2905 lappend idrowranges($i) [lindex $displayorder $rm1]
2906 #if {[incr nev -1] <= 0} break
2909 set rowchk($id) [expr {$row + $r}]
2912 lset rowidlist $row $idlist
2914 set col [lsearch -exact $idlist $id]
2916 set col [idcol $idlist $id]
2917 set idlist [linsert $idlist $col $id]
2918 lset rowidlist $row $idlist
2919 if {$children($curview,$id) ne {}} {
2921 makeuparrow $id $row $col
2927 if {[info exists idrowranges($id)]} {
2928 set ranges $idrowranges($id)
2930 unset idrowranges($id)
2932 lappend rowrangelist $ranges
2934 set idlist [lreplace $idlist $col $col]
2936 foreach i $newolds {
2937 set x [idcol $idlist $i $x]
2938 set idlist [linsert $idlist $x $i]
2940 set idrowranges($i) $id
2942 foreach oid $oldolds {
2943 set idinlist($oid) 1
2944 set x [idcol $idlist $oid $x]
2945 set idlist [linsert $idlist $x $oid]
2946 makeuparrow $oid $row $x
2948 lappend rowidlist $idlist
2953 proc addextraid {id row} {
2954 global displayorder commitrow commitinfo
2955 global commitidx commitlisted
2956 global parentlist children curview
2958 incr commitidx($curview)
2959 lappend displayorder $id
2960 lappend commitlisted 0
2961 lappend parentlist {}
2962 set commitrow($curview,$id) $row
2964 if {![info exists commitinfo($id)]} {
2965 set commitinfo($id) {"No commit information available"}
2967 if {![info exists children($curview,$id)]} {
2968 set children($curview,$id) {}
2972 proc layouttail {} {
2973 global rowidlist idinlist commitidx curview
2974 global idrowranges rowrangelist
2976 set row $commitidx($curview)
2977 set idlist [lindex $rowidlist $row]
2978 while {$idlist ne {}} {
2979 set col [expr {[llength $idlist] - 1}]
2980 set id [lindex $idlist $col]
2983 lappend idrowranges($id) $id
2984 lappend rowrangelist $idrowranges($id)
2985 unset idrowranges($id)
2987 set idlist [lreplace $idlist $col $col]
2988 lappend rowidlist $idlist
2991 foreach id [array names idinlist] {
2994 lset rowidlist $row [list $id]
2995 makeuparrow $id $row 0
2996 lappend idrowranges($id) $id
2997 lappend rowrangelist $idrowranges($id)
2998 unset idrowranges($id)
3000 lappend rowidlist {}
3004 proc insert_pad {row col npad} {
3007 set pad [ntimes $npad {}]
3008 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
3011 proc optimize_rows {row col endrow} {
3012 global rowidlist displayorder
3017 set idlist [lindex $rowidlist [expr {$row - 1}]]
3019 set previdlist [lindex $rowidlist [expr {$row - 2}]]
3023 for {} {$row < $endrow} {incr row} {
3024 set pprevidlist $previdlist
3025 set previdlist $idlist
3026 set idlist [lindex $rowidlist $row]
3028 set y0 [expr {$row - 1}]
3029 set ym [expr {$row - 2}]
3032 for {} {$col < [llength $idlist]} {incr col} {
3033 set id [lindex $idlist $col]
3034 if {[lindex $previdlist $col] eq $id} continue
3039 set x0 [lsearch -exact $previdlist $id]
3040 if {$x0 < 0} continue
3041 set z [expr {$x0 - $col}]
3045 set xm [lsearch -exact $pprevidlist $id]
3047 set z0 [expr {$xm - $x0}]
3051 set ranges [rowranges $id]
3052 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3056 # Looking at lines from this row to the previous row,
3057 # make them go straight up if they end in an arrow on
3058 # the previous row; otherwise make them go straight up
3060 if {$z < -1 || ($z < 0 && $isarrow)} {
3061 # Line currently goes left too much;
3062 # insert pads in the previous row, then optimize it
3063 set npad [expr {-1 - $z + $isarrow}]
3064 insert_pad $y0 $x0 $npad
3066 optimize_rows $y0 $x0 $row
3068 set previdlist [lindex $rowidlist $y0]
3069 set x0 [lsearch -exact $previdlist $id]
3070 set z [expr {$x0 - $col}]
3072 set pprevidlist [lindex $rowidlist $ym]
3073 set xm [lsearch -exact $pprevidlist $id]
3074 set z0 [expr {$xm - $x0}]
3076 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3077 # Line currently goes right too much;
3078 # insert pads in this line
3079 set npad [expr {$z - 1 + $isarrow}]
3080 set pad [ntimes $npad {}]
3081 set idlist [eval linsert \$idlist $col $pad]
3083 set z [expr {$x0 - $col}]
3086 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3087 # this line links to its first child on row $row-2
3088 set id [lindex $displayorder $ym]
3089 set xc [lsearch -exact $pprevidlist $id]
3091 set z0 [expr {$xc - $x0}]
3094 # avoid lines jigging left then immediately right
3095 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3096 insert_pad $y0 $x0 1
3098 optimize_rows $y0 $x0 $row
3099 set previdlist [lindex $rowidlist $y0]
3100 set pprevidlist [lindex $rowidlist $ym]
3104 # Find the first column that doesn't have a line going right
3105 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3106 set id [lindex $idlist $col]
3107 if {$id eq {}} break
3108 set x0 [lsearch -exact $previdlist $id]
3110 # check if this is the link to the first child
3111 set ranges [rowranges $id]
3112 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3113 # it is, work out offset to child
3114 set id [lindex $displayorder $y0]
3115 set x0 [lsearch -exact $previdlist $id]
3118 if {$x0 <= $col} break
3120 # Insert a pad at that column as long as it has a line and
3121 # isn't the last column
3122 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3123 set idlist [linsert $idlist $col {}]
3126 lset rowidlist $row $idlist
3132 global canvx0 linespc
3133 return [expr {$canvx0 + $col * $linespc}]
3137 global canvy0 linespc
3138 return [expr {$canvy0 + $row * $linespc}]
3141 proc linewidth {id} {
3142 global thickerline lthickness
3145 if {[info exists thickerline] && $id eq $thickerline} {
3146 set wid [expr {2 * $lthickness}]
3151 proc rowranges {id} {
3152 global phase idrowranges commitrow rowlaidout rowrangelist curview
3156 ([info exists commitrow($curview,$id)]
3157 && $commitrow($curview,$id) < $rowlaidout)} {
3158 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3159 } elseif {[info exists idrowranges($id)]} {
3160 set ranges $idrowranges($id)
3163 foreach rid $ranges {
3164 lappend linenos $commitrow($curview,$rid)
3166 if {$linenos ne {}} {
3167 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3172 # work around tk8.4 refusal to draw arrows on diagonal segments
3173 proc adjarrowhigh {coords} {
3176 set x0 [lindex $coords 0]
3177 set x1 [lindex $coords 2]
3179 set y0 [lindex $coords 1]
3180 set y1 [lindex $coords 3]
3181 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3182 # we have a nearby vertical segment, just trim off the diag bit
3183 set coords [lrange $coords 2 end]
3185 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3186 set xi [expr {$x0 - $slope * $linespc / 2}]
3187 set yi [expr {$y0 - $linespc / 2}]
3188 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3194 proc drawlineseg {id row endrow arrowlow} {
3195 global rowidlist displayorder iddrawn linesegs
3196 global canv colormap linespc curview maxlinelen
3198 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3199 set le [expr {$row + 1}]
3202 set c [lsearch -exact [lindex $rowidlist $le] $id]
3208 set x [lindex $displayorder $le]
3213 if {[info exists iddrawn($x)] || $le == $endrow} {
3214 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3230 if {[info exists linesegs($id)]} {
3231 set lines $linesegs($id)
3233 set r0 [lindex $li 0]
3235 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3245 set li [lindex $lines [expr {$i-1}]]
3246 set r1 [lindex $li 1]
3247 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3252 set x [lindex $cols [expr {$le - $row}]]
3253 set xp [lindex $cols [expr {$le - 1 - $row}]]
3254 set dir [expr {$xp - $x}]
3256 set ith [lindex $lines $i 2]
3257 set coords [$canv coords $ith]
3258 set ah [$canv itemcget $ith -arrow]
3259 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3260 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3261 if {$x2 ne {} && $x - $x2 == $dir} {
3262 set coords [lrange $coords 0 end-2]
3265 set coords [list [xc $le $x] [yc $le]]
3268 set itl [lindex $lines [expr {$i-1}] 2]
3269 set al [$canv itemcget $itl -arrow]
3270 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3271 } elseif {$arrowlow &&
3272 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3275 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3276 for {set y $le} {[incr y -1] > $row} {} {
3278 set xp [lindex $cols [expr {$y - 1 - $row}]]
3279 set ndir [expr {$xp - $x}]
3280 if {$dir != $ndir || $xp < 0} {
3281 lappend coords [xc $y $x] [yc $y]
3287 # join parent line to first child
3288 set ch [lindex $displayorder $row]
3289 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3291 puts "oops: drawlineseg: child $ch not on row $row"
3294 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3295 } elseif {$xc > $x + 1} {
3296 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3300 lappend coords [xc $row $x] [yc $row]
3302 set xn [xc $row $xp]
3304 # work around tk8.4 refusal to draw arrows on diagonal segments
3305 if {$arrowlow && $xn != [lindex $coords end-1]} {
3306 if {[llength $coords] < 4 ||
3307 [lindex $coords end-3] != [lindex $coords end-1] ||
3308 [lindex $coords end] - $yn > 2 * $linespc} {
3309 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3310 set yo [yc [expr {$row + 0.5}]]
3311 lappend coords $xn $yo $xn $yn
3314 lappend coords $xn $yn
3319 set coords [adjarrowhigh $coords]
3322 set t [$canv create line $coords -width [linewidth $id] \
3323 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3326 set lines [linsert $lines $i [list $row $le $t]]
3328 $canv coords $ith $coords
3329 if {$arrow ne $ah} {
3330 $canv itemconf $ith -arrow $arrow
3332 lset lines $i 0 $row
3335 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3336 set ndir [expr {$xo - $xp}]
3337 set clow [$canv coords $itl]
3338 if {$dir == $ndir} {
3339 set clow [lrange $clow 2 end]
3341 set coords [concat $coords $clow]
3343 lset lines [expr {$i-1}] 1 $le
3345 set coords [adjarrowhigh $coords]
3348 # coalesce two pieces
3350 set b [lindex $lines [expr {$i-1}] 0]
3351 set e [lindex $lines $i 1]
3352 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3354 $canv coords $itl $coords
3355 if {$arrow ne $al} {
3356 $canv itemconf $itl -arrow $arrow
3360 set linesegs($id) $lines
3364 proc drawparentlinks {id row} {
3365 global rowidlist canv colormap curview parentlist
3368 set rowids [lindex $rowidlist $row]
3369 set col [lsearch -exact $rowids $id]
3370 if {$col < 0} return
3371 set olds [lindex $parentlist $row]
3372 set row2 [expr {$row + 1}]
3373 set x [xc $row $col]
3376 set ids [lindex $rowidlist $row2]
3377 # rmx = right-most X coord used
3380 set i [lsearch -exact $ids $p]
3382 puts "oops, parent $p of $id not in list"
3385 set x2 [xc $row2 $i]
3389 if {[lsearch -exact $rowids $p] < 0} {
3390 # drawlineseg will do this one for us
3394 # should handle duplicated parents here...
3395 set coords [list $x $y]
3396 if {$i < $col - 1} {
3397 lappend coords [xc $row [expr {$i + 1}]] $y
3398 } elseif {$i > $col + 1} {
3399 lappend coords [xc $row [expr {$i - 1}]] $y
3401 lappend coords $x2 $y2
3402 set t [$canv create line $coords -width [linewidth $p] \
3403 -fill $colormap($p) -tags lines.$p]
3407 if {$rmx > [lindex $idpos($id) 1]} {
3408 lset idpos($id) 1 $rmx
3413 proc drawlines {id} {
3416 $canv itemconf lines.$id -width [linewidth $id]
3419 proc drawcmittext {id row col} {
3420 global linespc canv canv2 canv3 canvy0 fgcolor curview
3421 global commitlisted commitinfo rowidlist parentlist
3422 global rowtextx idpos idtags idheads idotherrefs
3423 global linehtag linentag linedtag
3424 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3426 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3427 set listed [lindex $commitlisted $row]
3428 if {$id eq $nullid} {
3430 } elseif {$id eq $nullid2} {
3433 set ofill [expr {$listed != 0? "blue": "white"}]
3435 set x [xc $row $col]
3437 set orad [expr {$linespc / 3}]
3439 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3440 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3441 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3442 } elseif {$listed == 2} {
3443 # triangle pointing left for left-side commits
3444 set t [$canv create polygon \
3445 [expr {$x - $orad}] $y \
3446 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3447 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3448 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3450 # triangle pointing right for right-side commits
3451 set t [$canv create polygon \
3452 [expr {$x + $orad - 1}] $y \
3453 [expr {$x - $orad}] [expr {$y - $orad}] \
3454 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3455 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3458 $canv bind $t <1> {selcanvline {} %x %y}
3459 set rmx [llength [lindex $rowidlist $row]]
3460 set olds [lindex $parentlist $row]
3462 set nextids [lindex $rowidlist [expr {$row + 1}]]
3464 set i [lsearch -exact $nextids $p]
3470 set xt [xc $row $rmx]
3471 set rowtextx($row) $xt
3472 set idpos($id) [list $x $xt $y]
3473 if {[info exists idtags($id)] || [info exists idheads($id)]
3474 || [info exists idotherrefs($id)]} {
3475 set xt [drawtags $id $x $xt $y]
3477 set headline [lindex $commitinfo($id) 0]
3478 set name [lindex $commitinfo($id) 1]
3479 set date [lindex $commitinfo($id) 2]
3480 set date [formatdate $date]
3483 set isbold [ishighlighted $row]
3485 lappend boldrows $row
3488 lappend boldnamerows $row
3492 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3493 -text $headline -font $font -tags text]
3494 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3495 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3496 -text $name -font $nfont -tags text]
3497 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3498 -text $date -font $mainfont -tags text]
3499 set xr [expr {$xt + [font measure $mainfont $headline]}]
3500 if {$xr > $canvxmax} {
3506 proc drawcmitrow {row} {
3507 global displayorder rowidlist
3508 global iddrawn markingmatches
3509 global commitinfo parentlist numcommits
3510 global filehighlight fhighlights findstring nhighlights
3511 global hlview vhighlights
3512 global highlight_related rhighlights
3514 if {$row >= $numcommits} return
3516 set id [lindex $displayorder $row]
3517 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3518 askvhighlight $row $id
3520 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3521 askfilehighlight $row $id
3523 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3524 askfindhighlight $row $id
3526 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3527 askrelhighlight $row $id
3529 if {![info exists iddrawn($id)]} {
3530 set col [lsearch -exact [lindex $rowidlist $row] $id]
3532 puts "oops, row $row id $id not in list"
3535 if {![info exists commitinfo($id)]} {
3539 drawcmittext $id $row $col
3542 if {$markingmatches} {
3543 markrowmatches $row $id
3547 proc drawcommits {row {endrow {}}} {
3548 global numcommits iddrawn displayorder curview
3549 global parentlist rowidlist
3554 if {$endrow eq {}} {
3557 if {$endrow >= $numcommits} {
3558 set endrow [expr {$numcommits - 1}]
3561 # make the lines join to already-drawn rows either side
3562 set r [expr {$row - 1}]
3563 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3566 set er [expr {$endrow + 1}]
3567 if {$er >= $numcommits ||
3568 ![info exists iddrawn([lindex $displayorder $er])]} {
3571 for {} {$r <= $er} {incr r} {
3572 set id [lindex $displayorder $r]
3573 set wasdrawn [info exists iddrawn($id)]
3575 if {$r == $er} break
3576 set nextid [lindex $displayorder [expr {$r + 1}]]
3577 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3578 catch {unset prevlines}
3581 drawparentlinks $id $r
3583 if {[info exists lineends($r)]} {
3584 foreach lid $lineends($r) {
3585 unset prevlines($lid)
3588 set rowids [lindex $rowidlist $r]
3589 foreach lid $rowids {
3590 if {$lid eq {}} continue
3592 # see if this is the first child of any of its parents
3593 foreach p [lindex $parentlist $r] {
3594 if {[lsearch -exact $rowids $p] < 0} {
3595 # make this line extend up to the child
3596 set le [drawlineseg $p $r $er 0]
3597 lappend lineends($le) $p
3601 } elseif {![info exists prevlines($lid)]} {
3602 set le [drawlineseg $lid $r $er 1]
3603 lappend lineends($le) $lid
3604 set prevlines($lid) 1
3610 proc drawfrac {f0 f1} {
3613 set ymax [lindex [$canv cget -scrollregion] 3]
3614 if {$ymax eq {} || $ymax == 0} return
3615 set y0 [expr {int($f0 * $ymax)}]
3616 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3617 set y1 [expr {int($f1 * $ymax)}]
3618 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3619 drawcommits $row $endrow
3622 proc drawvisible {} {
3624 eval drawfrac [$canv yview]
3627 proc clear_display {} {
3628 global iddrawn linesegs
3629 global vhighlights fhighlights nhighlights rhighlights
3632 catch {unset iddrawn}
3633 catch {unset linesegs}
3634 catch {unset vhighlights}
3635 catch {unset fhighlights}
3636 catch {unset nhighlights}
3637 catch {unset rhighlights}
3640 proc findcrossings {id} {
3641 global rowidlist parentlist numcommits displayorder
3645 foreach {s e} [rowranges $id] {
3646 if {$e >= $numcommits} {
3647 set e [expr {$numcommits - 1}]
3649 if {$e <= $s} continue
3650 for {set row $e} {[incr row -1] >= $s} {} {
3651 set x [lsearch -exact [lindex $rowidlist $row] $id]
3653 set olds [lindex $parentlist $row]
3654 set kid [lindex $displayorder $row]
3655 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3656 if {$kidx < 0} continue
3657 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3659 set px [lsearch -exact $nextrow $p]
3660 if {$px < 0} continue
3661 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3662 if {[lsearch -exact $ccross $p] >= 0} continue
3663 if {$x == $px + ($kidx < $px? -1: 1)} {
3665 } elseif {[lsearch -exact $cross $p] < 0} {
3672 return [concat $ccross {{}} $cross]
3675 proc assigncolor {id} {
3676 global colormap colors nextcolor
3677 global commitrow parentlist children children curview
3679 if {[info exists colormap($id)]} return
3680 set ncolors [llength $colors]
3681 if {[info exists children($curview,$id)]} {
3682 set kids $children($curview,$id)
3686 if {[llength $kids] == 1} {
3687 set child [lindex $kids 0]
3688 if {[info exists colormap($child)]
3689 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3690 set colormap($id) $colormap($child)
3696 foreach x [findcrossings $id] {
3698 # delimiter between corner crossings and other crossings
3699 if {[llength $badcolors] >= $ncolors - 1} break
3700 set origbad $badcolors
3702 if {[info exists colormap($x)]
3703 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3704 lappend badcolors $colormap($x)
3707 if {[llength $badcolors] >= $ncolors} {
3708 set badcolors $origbad
3710 set origbad $badcolors
3711 if {[llength $badcolors] < $ncolors - 1} {
3712 foreach child $kids {
3713 if {[info exists colormap($child)]
3714 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3715 lappend badcolors $colormap($child)
3717 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3718 if {[info exists colormap($p)]
3719 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3720 lappend badcolors $colormap($p)
3724 if {[llength $badcolors] >= $ncolors} {
3725 set badcolors $origbad
3728 for {set i 0} {$i <= $ncolors} {incr i} {
3729 set c [lindex $colors $nextcolor]
3730 if {[incr nextcolor] >= $ncolors} {
3733 if {[lsearch -exact $badcolors $c]} break
3735 set colormap($id) $c
3738 proc bindline {t id} {
3741 $canv bind $t <Enter> "lineenter %x %y $id"
3742 $canv bind $t <Motion> "linemotion %x %y $id"
3743 $canv bind $t <Leave> "lineleave $id"
3744 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3747 proc drawtags {id x xt y1} {
3748 global idtags idheads idotherrefs mainhead
3749 global linespc lthickness
3750 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3755 if {[info exists idtags($id)]} {
3756 set marks $idtags($id)
3757 set ntags [llength $marks]
3759 if {[info exists idheads($id)]} {
3760 set marks [concat $marks $idheads($id)]
3761 set nheads [llength $idheads($id)]
3763 if {[info exists idotherrefs($id)]} {
3764 set marks [concat $marks $idotherrefs($id)]
3770 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3771 set yt [expr {$y1 - 0.5 * $linespc}]
3772 set yb [expr {$yt + $linespc - 1}]
3776 foreach tag $marks {
3778 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3779 set wid [font measure [concat $mainfont bold] $tag]
3781 set wid [font measure $mainfont $tag]
3785 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3787 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3788 -width $lthickness -fill black -tags tag.$id]
3790 foreach tag $marks x $xvals wid $wvals {
3791 set xl [expr {$x + $delta}]
3792 set xr [expr {$x + $delta + $wid + $lthickness}]
3794 if {[incr ntags -1] >= 0} {
3796 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3797 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3798 -width 1 -outline black -fill yellow -tags tag.$id]
3799 $canv bind $t <1> [list showtag $tag 1]
3800 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3802 # draw a head or other ref
3803 if {[incr nheads -1] >= 0} {
3805 if {$tag eq $mainhead} {
3811 set xl [expr {$xl - $delta/2}]
3812 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3813 -width 1 -outline black -fill $col -tags tag.$id
3814 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3815 set rwid [font measure $mainfont $remoteprefix]
3816 set xi [expr {$x + 1}]
3817 set yti [expr {$yt + 1}]
3818 set xri [expr {$x + $rwid}]
3819 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3820 -width 0 -fill "#ffddaa" -tags tag.$id
3823 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3824 -font $font -tags [list tag.$id text]]
3826 $canv bind $t <1> [list showtag $tag 1]
3827 } elseif {$nheads >= 0} {
3828 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3834 proc xcoord {i level ln} {
3835 global canvx0 xspc1 xspc2
3837 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3838 if {$i > 0 && $i == $level} {
3839 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3840 } elseif {$i > $level} {
3841 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3846 proc show_status {msg} {
3847 global canv mainfont fgcolor
3850 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3851 -tags text -fill $fgcolor
3854 # Insert a new commit as the child of the commit on row $row.
3855 # The new commit will be displayed on row $row and the commits
3856 # on that row and below will move down one row.
3857 proc insertrow {row newcmit} {
3858 global displayorder parentlist commitlisted children
3859 global commitrow curview rowidlist numcommits
3860 global rowrangelist rowlaidout rowoptim numcommits
3861 global selectedline rowchk commitidx
3863 if {$row >= $numcommits} {
3864 puts "oops, inserting new row $row but only have $numcommits rows"
3867 set p [lindex $displayorder $row]
3868 set displayorder [linsert $displayorder $row $newcmit]
3869 set parentlist [linsert $parentlist $row $p]
3870 set kids $children($curview,$p)
3871 lappend kids $newcmit
3872 set children($curview,$p) $kids
3873 set children($curview,$newcmit) {}
3874 set commitlisted [linsert $commitlisted $row 1]
3875 set l [llength $displayorder]
3876 for {set r $row} {$r < $l} {incr r} {
3877 set id [lindex $displayorder $r]
3878 set commitrow($curview,$id) $r
3880 incr commitidx($curview)
3882 set idlist [lindex $rowidlist $row]
3883 if {[llength $kids] == 1} {
3884 set col [lsearch -exact $idlist $p]
3885 lset idlist $col $newcmit
3887 set col [llength $idlist]
3888 lappend idlist $newcmit
3890 set rowidlist [linsert $rowidlist $row $idlist]
3892 set rowrangelist [linsert $rowrangelist $row {}]
3893 if {[llength $kids] > 1} {
3894 set rp1 [expr {$row + 1}]
3895 set ranges [lindex $rowrangelist $rp1]
3896 if {$ranges eq {}} {
3897 set ranges [list $newcmit $p]
3898 } elseif {[lindex $ranges end-1] eq $p} {
3899 lset ranges end-1 $newcmit
3901 lset rowrangelist $rp1 $ranges
3904 catch {unset rowchk}
3910 if {[info exists selectedline] && $selectedline >= $row} {
3916 # Remove a commit that was inserted with insertrow on row $row.
3917 proc removerow {row} {
3918 global displayorder parentlist commitlisted children
3919 global commitrow curview rowidlist numcommits
3920 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3921 global linesegends selectedline rowchk commitidx
3923 if {$row >= $numcommits} {
3924 puts "oops, removing row $row but only have $numcommits rows"
3927 set rp1 [expr {$row + 1}]
3928 set id [lindex $displayorder $row]
3929 set p [lindex $parentlist $row]
3930 set displayorder [lreplace $displayorder $row $row]
3931 set parentlist [lreplace $parentlist $row $row]
3932 set commitlisted [lreplace $commitlisted $row $row]
3933 set kids $children($curview,$p)
3934 set i [lsearch -exact $kids $id]
3936 set kids [lreplace $kids $i $i]
3937 set children($curview,$p) $kids
3939 set l [llength $displayorder]
3940 for {set r $row} {$r < $l} {incr r} {
3941 set id [lindex $displayorder $r]
3942 set commitrow($curview,$id) $r
3944 incr commitidx($curview) -1
3946 set rowidlist [lreplace $rowidlist $row $row]
3948 set rowrangelist [lreplace $rowrangelist $row $row]
3949 if {[llength $kids] > 0} {
3950 set ranges [lindex $rowrangelist $row]
3951 if {[lindex $ranges end-1] eq $id} {
3952 set ranges [lreplace $ranges end-1 end]
3953 lset rowrangelist $row $ranges
3957 catch {unset rowchk}
3963 if {[info exists selectedline] && $selectedline > $row} {
3964 incr selectedline -1
3969 # Don't change the text pane cursor if it is currently the hand cursor,
3970 # showing that we are over a sha1 ID link.
3971 proc settextcursor {c} {
3972 global ctext curtextcursor
3974 if {[$ctext cget -cursor] == $curtextcursor} {
3975 $ctext config -cursor $c
3977 set curtextcursor $c
3980 proc nowbusy {what} {
3983 if {[array names isbusy] eq {}} {
3984 . config -cursor watch
3990 proc notbusy {what} {
3991 global isbusy maincursor textcursor
3993 catch {unset isbusy($what)}
3994 if {[array names isbusy] eq {}} {
3995 . config -cursor $maincursor
3996 settextcursor $textcursor
4000 proc findmatches {f} {
4001 global findtype findstring
4002 if {$findtype == "Regexp"} {
4003 set matches [regexp -indices -all -inline $findstring $f]
4006 if {$findtype == "IgnCase"} {
4007 set f [string tolower $f]
4008 set fs [string tolower $fs]
4012 set l [string length $fs]
4013 while {[set j [string first $fs $f $i]] >= 0} {
4014 lappend matches [list $j [expr {$j+$l-1}]]
4015 set i [expr {$j + $l}]
4021 proc dofind {{rev 0}} {
4022 global findstring findstartline findcurline selectedline numcommits
4025 cancel_next_highlight
4027 if {$findstring eq {} || $numcommits == 0} return
4028 if {![info exists selectedline]} {
4029 set findstartline [lindex [visiblerows] $rev]
4031 set findstartline $selectedline
4033 set findcurline $findstartline
4038 if {$findcurline == 0} {
4039 set findcurline $numcommits
4046 proc findnext {restart} {
4048 if {![info exists findcurline]} {
4062 if {![info exists findcurline]} {
4071 global commitdata commitinfo numcommits findstring findpattern findloc
4072 global findstartline findcurline displayorder
4074 set fldtypes {Headline Author Date Committer CDate Comments}
4075 set l [expr {$findcurline + 1}]
4076 if {$l >= $numcommits} {
4079 if {$l <= $findstartline} {
4080 set lim [expr {$findstartline + 1}]
4084 if {$lim - $l > 500} {
4085 set lim [expr {$l + 500}]
4088 for {} {$l < $lim} {incr l} {
4089 set id [lindex $displayorder $l]
4090 # shouldn't happen unless git log doesn't give all the commits...
4091 if {![info exists commitdata($id)]} continue
4092 if {![doesmatch $commitdata($id)]} continue
4093 if {![info exists commitinfo($id)]} {
4096 set info $commitinfo($id)
4097 foreach f $info ty $fldtypes {
4098 if {($findloc eq "All fields" || $findloc eq $ty) &&
4106 if {$l == $findstartline + 1} {
4112 set findcurline [expr {$l - 1}]
4116 proc findmorerev {} {
4117 global commitdata commitinfo numcommits findstring findpattern findloc
4118 global findstartline findcurline displayorder
4120 set fldtypes {Headline Author Date Committer CDate Comments}
4126 if {$l >= $findstartline} {
4127 set lim [expr {$findstartline - 1}]
4131 if {$l - $lim > 500} {
4132 set lim [expr {$l - 500}]
4135 for {} {$l > $lim} {incr l -1} {
4136 set id [lindex $displayorder $l]
4137 if {![doesmatch $commitdata($id)]} continue
4138 if {![info exists commitinfo($id)]} {
4141 set info $commitinfo($id)
4142 foreach f $info ty $fldtypes {
4143 if {($findloc eq "All fields" || $findloc eq $ty) &&
4157 set findcurline [expr {$l + 1}]
4161 proc findselectline {l} {
4162 global findloc commentend ctext findcurline markingmatches
4164 set markingmatches 1
4167 if {$findloc == "All fields" || $findloc == "Comments"} {
4168 # highlight the matches in the comments
4169 set f [$ctext get 1.0 $commentend]
4170 set matches [findmatches $f]
4171 foreach match $matches {
4172 set start [lindex $match 0]
4173 set end [expr {[lindex $match 1] + 1}]
4174 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4180 # mark the bits of a headline or author that match a find string
4181 proc markmatches {canv l str tag matches font row} {
4184 set bbox [$canv bbox $tag]
4185 set x0 [lindex $bbox 0]
4186 set y0 [lindex $bbox 1]
4187 set y1 [lindex $bbox 3]
4188 foreach match $matches {
4189 set start [lindex $match 0]
4190 set end [lindex $match 1]
4191 if {$start > $end} continue
4192 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4193 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4194 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4195 [expr {$x0+$xlen+2}] $y1 \
4196 -outline {} -tags [list match$l matches] -fill yellow]
4198 if {[info exists selectedline] && $row == $selectedline} {
4199 $canv raise $t secsel
4204 proc unmarkmatches {} {
4205 global findids markingmatches findcurline
4207 allcanvs delete matches
4208 catch {unset findids}
4209 set markingmatches 0
4210 catch {unset findcurline}
4213 proc selcanvline {w x y} {
4214 global canv canvy0 ctext linespc
4216 set ymax [lindex [$canv cget -scrollregion] 3]
4217 if {$ymax == {}} return
4218 set yfrac [lindex [$canv yview] 0]
4219 set y [expr {$y + $yfrac * $ymax}]
4220 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4225 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4231 proc commit_descriptor {p} {
4233 if {![info exists commitinfo($p)]} {
4237 if {[llength $commitinfo($p)] > 1} {
4238 set l [lindex $commitinfo($p) 0]
4243 # append some text to the ctext widget, and make any SHA1 ID
4244 # that we know about be a clickable link.
4245 proc appendwithlinks {text tags} {
4246 global ctext commitrow linknum curview
4248 set start [$ctext index "end - 1c"]
4249 $ctext insert end $text $tags
4250 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4254 set linkid [string range $text $s $e]
4255 if {![info exists commitrow($curview,$linkid)]} continue
4257 $ctext tag add link "$start + $s c" "$start + $e c"
4258 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4259 $ctext tag bind link$linknum <1> \
4260 [list selectline $commitrow($curview,$linkid) 1]
4263 $ctext tag conf link -foreground blue -underline 1
4264 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4265 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4268 proc viewnextline {dir} {
4272 set ymax [lindex [$canv cget -scrollregion] 3]
4273 set wnow [$canv yview]
4274 set wtop [expr {[lindex $wnow 0] * $ymax}]
4275 set newtop [expr {$wtop + $dir * $linespc}]
4278 } elseif {$newtop > $ymax} {
4281 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4284 # add a list of tag or branch names at position pos
4285 # returns the number of names inserted
4286 proc appendrefs {pos ids var} {
4287 global ctext commitrow linknum curview $var maxrefs
4289 if {[catch {$ctext index $pos}]} {
4292 $ctext conf -state normal
4293 $ctext delete $pos "$pos lineend"
4296 foreach tag [set $var\($id\)] {
4297 lappend tags [list $tag $id]
4300 if {[llength $tags] > $maxrefs} {
4301 $ctext insert $pos "many ([llength $tags])"
4303 set tags [lsort -index 0 -decreasing $tags]
4306 set id [lindex $ti 1]
4309 $ctext tag delete $lk
4310 $ctext insert $pos $sep
4311 $ctext insert $pos [lindex $ti 0] $lk
4312 if {[info exists commitrow($curview,$id)]} {
4313 $ctext tag conf $lk -foreground blue
4314 $ctext tag bind $lk <1> \
4315 [list selectline $commitrow($curview,$id) 1]
4316 $ctext tag conf $lk -underline 1
4317 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4318 $ctext tag bind $lk <Leave> \
4319 { %W configure -cursor $curtextcursor }
4324 $ctext conf -state disabled
4325 return [llength $tags]
4328 # called when we have finished computing the nearby tags
4329 proc dispneartags {delay} {
4330 global selectedline currentid showneartags tagphase
4332 if {![info exists selectedline] || !$showneartags} return
4333 after cancel dispnexttag
4335 after 200 dispnexttag
4338 after idle dispnexttag
4343 proc dispnexttag {} {
4344 global selectedline currentid showneartags tagphase ctext
4346 if {![info exists selectedline] || !$showneartags} return
4347 switch -- $tagphase {
4349 set dtags [desctags $currentid]
4351 appendrefs precedes $dtags idtags
4355 set atags [anctags $currentid]
4357 appendrefs follows $atags idtags
4361 set dheads [descheads $currentid]
4362 if {$dheads ne {}} {
4363 if {[appendrefs branch $dheads idheads] > 1
4364 && [$ctext get "branch -3c"] eq "h"} {
4365 # turn "Branch" into "Branches"
4366 $ctext conf -state normal
4367 $ctext insert "branch -2c" "es"
4368 $ctext conf -state disabled
4373 if {[incr tagphase] <= 2} {
4374 after idle dispnexttag
4378 proc selectline {l isnew} {
4379 global canv canv2 canv3 ctext commitinfo selectedline
4380 global displayorder linehtag linentag linedtag
4381 global canvy0 linespc parentlist children curview
4382 global currentid sha1entry
4383 global commentend idtags linknum
4384 global mergemax numcommits pending_select
4385 global cmitmode showneartags allcommits
4387 catch {unset pending_select}
4390 cancel_next_highlight
4391 if {$l < 0 || $l >= $numcommits} return
4392 set y [expr {$canvy0 + $l * $linespc}]
4393 set ymax [lindex [$canv cget -scrollregion] 3]
4394 set ytop [expr {$y - $linespc - 1}]
4395 set ybot [expr {$y + $linespc + 1}]
4396 set wnow [$canv yview]
4397 set wtop [expr {[lindex $wnow 0] * $ymax}]
4398 set wbot [expr {[lindex $wnow 1] * $ymax}]
4399 set wh [expr {$wbot - $wtop}]
4401 if {$ytop < $wtop} {
4402 if {$ybot < $wtop} {
4403 set newtop [expr {$y - $wh / 2.0}]
4406 if {$newtop > $wtop - $linespc} {
4407 set newtop [expr {$wtop - $linespc}]
4410 } elseif {$ybot > $wbot} {
4411 if {$ytop > $wbot} {
4412 set newtop [expr {$y - $wh / 2.0}]
4414 set newtop [expr {$ybot - $wh}]
4415 if {$newtop < $wtop + $linespc} {
4416 set newtop [expr {$wtop + $linespc}]
4420 if {$newtop != $wtop} {
4424 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4428 if {![info exists linehtag($l)]} return
4430 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4431 -tags secsel -fill [$canv cget -selectbackground]]
4433 $canv2 delete secsel
4434 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4435 -tags secsel -fill [$canv2 cget -selectbackground]]
4437 $canv3 delete secsel
4438 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4439 -tags secsel -fill [$canv3 cget -selectbackground]]
4443 addtohistory [list selectline $l 0]
4448 set id [lindex $displayorder $l]
4450 $sha1entry delete 0 end
4451 $sha1entry insert 0 $id
4452 $sha1entry selection from 0
4453 $sha1entry selection to end
4456 $ctext conf -state normal
4459 set info $commitinfo($id)
4460 set date [formatdate [lindex $info 2]]
4461 $ctext insert end "Author: [lindex $info 1] $date\n"
4462 set date [formatdate [lindex $info 4]]
4463 $ctext insert end "Committer: [lindex $info 3] $date\n"
4464 if {[info exists idtags($id)]} {
4465 $ctext insert end "Tags:"
4466 foreach tag $idtags($id) {
4467 $ctext insert end " $tag"
4469 $ctext insert end "\n"
4473 set olds [lindex $parentlist $l]
4474 if {[llength $olds] > 1} {
4477 if {$np >= $mergemax} {
4482 $ctext insert end "Parent: " $tag
4483 appendwithlinks [commit_descriptor $p] {}
4488 append headers "Parent: [commit_descriptor $p]"
4492 foreach c $children($curview,$id) {
4493 append headers "Child: [commit_descriptor $c]"
4496 # make anything that looks like a SHA1 ID be a clickable link
4497 appendwithlinks $headers {}
4498 if {$showneartags} {
4499 if {![info exists allcommits]} {
4502 $ctext insert end "Branch: "
4503 $ctext mark set branch "end -1c"
4504 $ctext mark gravity branch left
4505 $ctext insert end "\nFollows: "
4506 $ctext mark set follows "end -1c"
4507 $ctext mark gravity follows left
4508 $ctext insert end "\nPrecedes: "
4509 $ctext mark set precedes "end -1c"
4510 $ctext mark gravity precedes left
4511 $ctext insert end "\n"
4514 $ctext insert end "\n"
4515 set comment [lindex $info 5]
4516 if {[string first "\r" $comment] >= 0} {
4517 set comment [string map {"\r" "\n "} $comment]
4519 appendwithlinks $comment {comment}
4521 $ctext tag remove found 1.0 end
4522 $ctext conf -state disabled
4523 set commentend [$ctext index "end - 1c"]
4525 init_flist "Comments"
4526 if {$cmitmode eq "tree"} {
4528 } elseif {[llength $olds] <= 1} {
4535 proc selfirstline {} {
4540 proc sellastline {} {
4543 set l [expr {$numcommits - 1}]
4547 proc selnextline {dir} {
4549 if {![info exists selectedline]} return
4550 set l [expr {$selectedline + $dir}]
4555 proc selnextpage {dir} {
4556 global canv linespc selectedline numcommits
4558 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4562 allcanvs yview scroll [expr {$dir * $lpp}] units
4564 if {![info exists selectedline]} return
4565 set l [expr {$selectedline + $dir * $lpp}]
4568 } elseif {$l >= $numcommits} {
4569 set l [expr $numcommits - 1]
4575 proc unselectline {} {
4576 global selectedline currentid
4578 catch {unset selectedline}
4579 catch {unset currentid}
4580 allcanvs delete secsel
4582 cancel_next_highlight
4585 proc reselectline {} {
4588 if {[info exists selectedline]} {
4589 selectline $selectedline 0
4593 proc addtohistory {cmd} {
4594 global history historyindex curview
4596 set elt [list $curview $cmd]
4597 if {$historyindex > 0
4598 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4602 if {$historyindex < [llength $history]} {
4603 set history [lreplace $history $historyindex end $elt]
4605 lappend history $elt
4608 if {$historyindex > 1} {
4609 .tf.bar.leftbut conf -state normal
4611 .tf.bar.leftbut conf -state disabled
4613 .tf.bar.rightbut conf -state disabled
4619 set view [lindex $elt 0]
4620 set cmd [lindex $elt 1]
4621 if {$curview != $view} {
4628 global history historyindex
4630 if {$historyindex > 1} {
4631 incr historyindex -1
4632 godo [lindex $history [expr {$historyindex - 1}]]
4633 .tf.bar.rightbut conf -state normal
4635 if {$historyindex <= 1} {
4636 .tf.bar.leftbut conf -state disabled
4641 global history historyindex
4643 if {$historyindex < [llength $history]} {
4644 set cmd [lindex $history $historyindex]
4647 .tf.bar.leftbut conf -state normal
4649 if {$historyindex >= [llength $history]} {
4650 .tf.bar.rightbut conf -state disabled
4655 global treefilelist treeidlist diffids diffmergeid treepending
4656 global nullid nullid2
4659 catch {unset diffmergeid}
4660 if {![info exists treefilelist($id)]} {
4661 if {![info exists treepending]} {
4662 if {$id eq $nullid} {
4663 set cmd [list | git ls-files]
4664 } elseif {$id eq $nullid2} {
4665 set cmd [list | git ls-files --stage -t]
4667 set cmd [list | git ls-tree -r $id]
4669 if {[catch {set gtf [open $cmd r]}]} {
4673 set treefilelist($id) {}
4674 set treeidlist($id) {}
4675 fconfigure $gtf -blocking 0
4676 filerun $gtf [list gettreeline $gtf $id]
4683 proc gettreeline {gtf id} {
4684 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4687 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4688 if {$diffids eq $nullid} {
4691 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4692 set i [string first "\t" $line]
4693 if {$i < 0} continue
4694 set sha1 [lindex $line 2]
4695 set fname [string range $line [expr {$i+1}] end]
4696 if {[string index $fname 0] eq "\""} {
4697 set fname [lindex $fname 0]
4699 lappend treeidlist($id) $sha1
4701 lappend treefilelist($id) $fname
4704 return [expr {$nl >= 1000? 2: 1}]
4708 if {$cmitmode ne "tree"} {
4709 if {![info exists diffmergeid]} {
4710 gettreediffs $diffids
4712 } elseif {$id ne $diffids} {
4721 global treefilelist treeidlist diffids nullid nullid2
4722 global ctext commentend
4724 set i [lsearch -exact $treefilelist($diffids) $f]
4726 puts "oops, $f not in list for id $diffids"
4729 if {$diffids eq $nullid} {
4730 if {[catch {set bf [open $f r]} err]} {
4731 puts "oops, can't read $f: $err"
4735 set blob [lindex $treeidlist($diffids) $i]
4736 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4737 puts "oops, error reading blob $blob: $err"
4741 fconfigure $bf -blocking 0
4742 filerun $bf [list getblobline $bf $diffids]
4743 $ctext config -state normal
4744 clear_ctext $commentend
4745 $ctext insert end "\n"
4746 $ctext insert end "$f\n" filesep
4747 $ctext config -state disabled
4748 $ctext yview $commentend
4751 proc getblobline {bf id} {
4752 global diffids cmitmode ctext
4754 if {$id ne $diffids || $cmitmode ne "tree"} {
4758 $ctext config -state normal
4760 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4761 $ctext insert end "$line\n"
4764 # delete last newline
4765 $ctext delete "end - 2c" "end - 1c"
4769 $ctext config -state disabled
4770 return [expr {$nl >= 1000? 2: 1}]
4773 proc mergediff {id l} {
4774 global diffmergeid diffopts mdifffd
4780 # this doesn't seem to actually affect anything...
4781 set env(GIT_DIFF_OPTS) $diffopts
4782 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4783 if {[catch {set mdf [open $cmd r]} err]} {
4784 error_popup "Error getting merge diffs: $err"
4787 fconfigure $mdf -blocking 0
4788 set mdifffd($id) $mdf
4789 set np [llength [lindex $parentlist $l]]
4790 filerun $mdf [list getmergediffline $mdf $id $np]
4793 proc getmergediffline {mdf id np} {
4794 global diffmergeid ctext cflist mergemax
4795 global difffilestart mdifffd
4797 $ctext conf -state normal
4799 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4800 if {![info exists diffmergeid] || $id != $diffmergeid
4801 || $mdf != $mdifffd($id)} {
4805 if {[regexp {^diff --cc (.*)} $line match fname]} {
4806 # start of a new file
4807 $ctext insert end "\n"
4808 set here [$ctext index "end - 1c"]
4809 lappend difffilestart $here
4810 add_flist [list $fname]
4811 set l [expr {(78 - [string length $fname]) / 2}]
4812 set pad [string range "----------------------------------------" 1 $l]
4813 $ctext insert end "$pad $fname $pad\n" filesep
4814 } elseif {[regexp {^@@} $line]} {
4815 $ctext insert end "$line\n" hunksep
4816 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4819 # parse the prefix - one ' ', '-' or '+' for each parent
4824 for {set j 0} {$j < $np} {incr j} {
4825 set c [string range $line $j $j]
4828 } elseif {$c == "-"} {
4830 } elseif {$c == "+"} {
4839 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4840 # line doesn't appear in result, parents in $minuses have the line
4841 set num [lindex $minuses 0]
4842 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4843 # line appears in result, parents in $pluses don't have the line
4844 lappend tags mresult
4845 set num [lindex $spaces 0]
4848 if {$num >= $mergemax} {
4853 $ctext insert end "$line\n" $tags
4856 $ctext conf -state disabled
4861 return [expr {$nr >= 1000? 2: 1}]
4864 proc startdiff {ids} {
4865 global treediffs diffids treepending diffmergeid nullid nullid2
4868 catch {unset diffmergeid}
4869 if {![info exists treediffs($ids)] ||
4870 [lsearch -exact $ids $nullid] >= 0 ||
4871 [lsearch -exact $ids $nullid2] >= 0} {
4872 if {![info exists treepending]} {
4880 proc addtocflist {ids} {
4881 global treediffs cflist
4882 add_flist $treediffs($ids)
4886 proc diffcmd {ids flags} {
4887 global nullid nullid2
4889 set i [lsearch -exact $ids $nullid]
4890 set j [lsearch -exact $ids $nullid2]
4892 if {[llength $ids] > 1 && $j < 0} {
4893 # comparing working directory with some specific revision
4894 set cmd [concat | git diff-index $flags]
4896 lappend cmd -R [lindex $ids 1]
4898 lappend cmd [lindex $ids 0]
4901 # comparing working directory with index
4902 set cmd [concat | git diff-files $flags]
4907 } elseif {$j >= 0} {
4908 set cmd [concat | git diff-index --cached $flags]
4909 if {[llength $ids] > 1} {
4910 # comparing index with specific revision
4912 lappend cmd -R [lindex $ids 1]
4914 lappend cmd [lindex $ids 0]
4917 # comparing index with HEAD
4921 set cmd [concat | git diff-tree -r $flags $ids]
4926 proc gettreediffs {ids} {
4927 global treediff treepending
4929 set treepending $ids
4931 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4932 fconfigure $gdtf -blocking 0
4933 filerun $gdtf [list gettreediffline $gdtf $ids]
4936 proc gettreediffline {gdtf ids} {
4937 global treediff treediffs treepending diffids diffmergeid
4941 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4942 set i [string first "\t" $line]
4944 set file [string range $line [expr {$i+1}] end]
4945 if {[string index $file 0] eq "\""} {
4946 set file [lindex $file 0]
4948 lappend treediff $file
4952 return [expr {$nr >= 1000? 2: 1}]
4955 set treediffs($ids) $treediff
4957 if {$cmitmode eq "tree"} {
4959 } elseif {$ids != $diffids} {
4960 if {![info exists diffmergeid]} {
4961 gettreediffs $diffids
4969 proc getblobdiffs {ids} {
4970 global diffopts blobdifffd diffids env
4971 global diffinhdr treediffs
4973 set env(GIT_DIFF_OPTS) $diffopts
4974 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4975 puts "error getting diffs: $err"
4979 fconfigure $bdf -blocking 0
4980 set blobdifffd($ids) $bdf
4981 filerun $bdf [list getblobdiffline $bdf $diffids]
4984 proc setinlist {var i val} {
4987 while {[llength [set $var]] < $i} {
4990 if {[llength [set $var]] == $i} {
4997 proc makediffhdr {fname ids} {
4998 global ctext curdiffstart treediffs
5000 set i [lsearch -exact $treediffs($ids) $fname]
5002 setinlist difffilestart $i $curdiffstart
5004 set l [expr {(78 - [string length $fname]) / 2}]
5005 set pad [string range "----------------------------------------" 1 $l]
5006 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5009 proc getblobdiffline {bdf ids} {
5010 global diffids blobdifffd ctext curdiffstart
5011 global diffnexthead diffnextnote difffilestart
5012 global diffinhdr treediffs
5015 $ctext conf -state normal
5016 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5017 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5021 if {![string compare -length 11 "diff --git " $line]} {
5022 # trim off "diff --git "
5023 set line [string range $line 11 end]
5025 # start of a new file
5026 $ctext insert end "\n"
5027 set curdiffstart [$ctext index "end - 1c"]
5028 $ctext insert end "\n" filesep
5029 # If the name hasn't changed the length will be odd,
5030 # the middle char will be a space, and the two bits either
5031 # side will be a/name and b/name, or "a/name" and "b/name".
5032 # If the name has changed we'll get "rename from" and
5033 # "rename to" lines following this, and we'll use them
5034 # to get the filenames.
5035 # This complexity is necessary because spaces in the filename(s)
5036 # don't get escaped.
5037 set l [string length $line]
5038 set i [expr {$l / 2}]
5039 if {!(($l & 1) && [string index $line $i] eq " " &&
5040 [string range $line 2 [expr {$i - 1}]] eq \
5041 [string range $line [expr {$i + 3}] end])} {
5044 # unescape if quoted and chop off the a/ from the front
5045 if {[string index $line 0] eq "\""} {
5046 set fname [string range [lindex $line 0] 2 end]
5048 set fname [string range $line 2 [expr {$i - 1}]]
5050 makediffhdr $fname $ids
5052 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5053 $line match f1l f1c f2l f2c rest]} {
5054 $ctext insert end "$line\n" hunksep
5057 } elseif {$diffinhdr} {
5058 if {![string compare -length 12 "rename from " $line]} {
5059 set fname [string range $line 12 end]
5060 if {[string index $fname 0] eq "\""} {
5061 set fname [lindex $fname 0]
5063 set i [lsearch -exact $treediffs($ids) $fname]
5065 setinlist difffilestart $i $curdiffstart
5067 } elseif {![string compare -length 10 $line "rename to "]} {
5068 set fname [string range $line 10 end]
5069 if {[string index $fname 0] eq "\""} {
5070 set fname [lindex $fname 0]
5072 makediffhdr $fname $ids
5073 } elseif {[string compare -length 3 $line "---"] == 0} {
5076 } elseif {[string compare -length 3 $line "+++"] == 0} {
5080 $ctext insert end "$line\n" filesep
5083 set x [string range $line 0 0]
5084 if {$x == "-" || $x == "+"} {
5085 set tag [expr {$x == "+"}]
5086 $ctext insert end "$line\n" d$tag
5087 } elseif {$x == " "} {
5088 $ctext insert end "$line\n"
5090 # "\ No newline at end of file",
5091 # or something else we don't recognize
5092 $ctext insert end "$line\n" hunksep
5096 $ctext conf -state disabled
5101 return [expr {$nr >= 1000? 2: 1}]
5104 proc changediffdisp {} {
5105 global ctext diffelide
5107 $ctext tag conf d0 -elide [lindex $diffelide 0]
5108 $ctext tag conf d1 -elide [lindex $diffelide 1]
5112 global difffilestart ctext
5113 set prev [lindex $difffilestart 0]
5114 set here [$ctext index @0,0]
5115 foreach loc $difffilestart {
5116 if {[$ctext compare $loc >= $here]} {
5126 global difffilestart ctext
5127 set here [$ctext index @0,0]
5128 foreach loc $difffilestart {
5129 if {[$ctext compare $loc > $here]} {
5136 proc clear_ctext {{first 1.0}} {
5137 global ctext smarktop smarkbot
5139 set l [lindex [split $first .] 0]
5140 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5143 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5146 $ctext delete $first end
5149 proc incrsearch {name ix op} {
5150 global ctext searchstring searchdirn
5152 $ctext tag remove found 1.0 end
5153 if {[catch {$ctext index anchor}]} {
5154 # no anchor set, use start of selection, or of visible area
5155 set sel [$ctext tag ranges sel]
5157 $ctext mark set anchor [lindex $sel 0]
5158 } elseif {$searchdirn eq "-forwards"} {
5159 $ctext mark set anchor @0,0
5161 $ctext mark set anchor @0,[winfo height $ctext]
5164 if {$searchstring ne {}} {
5165 set here [$ctext search $searchdirn -- $searchstring anchor]
5174 global sstring ctext searchstring searchdirn
5177 $sstring icursor end
5178 set searchdirn -forwards
5179 if {$searchstring ne {}} {
5180 set sel [$ctext tag ranges sel]
5182 set start "[lindex $sel 0] + 1c"
5183 } elseif {[catch {set start [$ctext index anchor]}]} {
5186 set match [$ctext search -count mlen -- $searchstring $start]
5187 $ctext tag remove sel 1.0 end
5193 set mend "$match + $mlen c"
5194 $ctext tag add sel $match $mend
5195 $ctext mark unset anchor
5199 proc dosearchback {} {
5200 global sstring ctext searchstring searchdirn
5203 $sstring icursor end
5204 set searchdirn -backwards
5205 if {$searchstring ne {}} {
5206 set sel [$ctext tag ranges sel]
5208 set start [lindex $sel 0]
5209 } elseif {[catch {set start [$ctext index anchor]}]} {
5210 set start @0,[winfo height $ctext]
5212 set match [$ctext search -backwards -count ml -- $searchstring $start]
5213 $ctext tag remove sel 1.0 end
5219 set mend "$match + $ml c"
5220 $ctext tag add sel $match $mend
5221 $ctext mark unset anchor
5225 proc searchmark {first last} {
5226 global ctext searchstring
5230 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5231 if {$match eq {}} break
5232 set mend "$match + $mlen c"
5233 $ctext tag add found $match $mend
5237 proc searchmarkvisible {doall} {
5238 global ctext smarktop smarkbot
5240 set topline [lindex [split [$ctext index @0,0] .] 0]
5241 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5242 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5243 # no overlap with previous
5244 searchmark $topline $botline
5245 set smarktop $topline
5246 set smarkbot $botline
5248 if {$topline < $smarktop} {
5249 searchmark $topline [expr {$smarktop-1}]
5250 set smarktop $topline
5252 if {$botline > $smarkbot} {
5253 searchmark [expr {$smarkbot+1}] $botline
5254 set smarkbot $botline
5259 proc scrolltext {f0 f1} {
5262 .bleft.sb set $f0 $f1
5263 if {$searchstring ne {}} {
5269 global linespc charspc canvx0 canvy0 mainfont
5270 global xspc1 xspc2 lthickness
5272 set linespc [font metrics $mainfont -linespace]
5273 set charspc [font measure $mainfont "m"]
5274 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5275 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5276 set lthickness [expr {int($linespc / 9) + 1}]
5277 set xspc1(0) $linespc
5285 set ymax [lindex [$canv cget -scrollregion] 3]
5286 if {$ymax eq {} || $ymax == 0} return
5287 set span [$canv yview]
5290 allcanvs yview moveto [lindex $span 0]
5292 if {[info exists selectedline]} {
5293 selectline $selectedline 0
5294 allcanvs yview moveto [lindex $span 0]
5298 proc incrfont {inc} {
5299 global mainfont textfont ctext canv phase cflist
5300 global charspc tabstop
5301 global stopped entries
5303 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5304 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5306 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5307 $cflist conf -font $textfont
5308 $ctext tag conf filesep -font [concat $textfont bold]
5309 foreach e $entries {
5310 $e conf -font $mainfont
5312 if {$phase eq "getcommits"} {
5313 $canv itemconf textitems -font $mainfont
5319 global sha1entry sha1string
5320 if {[string length $sha1string] == 40} {
5321 $sha1entry delete 0 end
5325 proc sha1change {n1 n2 op} {
5326 global sha1string currentid sha1but
5327 if {$sha1string == {}
5328 || ([info exists currentid] && $sha1string == $currentid)} {
5333 if {[$sha1but cget -state] == $state} return
5334 if {$state == "normal"} {
5335 $sha1but conf -state normal -relief raised -text "Goto: "
5337 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5341 proc gotocommit {} {
5342 global sha1string currentid commitrow tagids headids
5343 global displayorder numcommits curview
5345 if {$sha1string == {}
5346 || ([info exists currentid] && $sha1string == $currentid)} return
5347 if {[info exists tagids($sha1string)]} {
5348 set id $tagids($sha1string)
5349 } elseif {[info exists headids($sha1string)]} {
5350 set id $headids($sha1string)
5352 set id [string tolower $sha1string]
5353 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5355 foreach i $displayorder {
5356 if {[string match $id* $i]} {
5360 if {$matches ne {}} {
5361 if {[llength $matches] > 1} {
5362 error_popup "Short SHA1 id $id is ambiguous"
5365 set id [lindex $matches 0]
5369 if {[info exists commitrow($curview,$id)]} {
5370 selectline $commitrow($curview,$id) 1
5373 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5378 error_popup "$type $sha1string is not known"
5381 proc lineenter {x y id} {
5382 global hoverx hovery hoverid hovertimer
5383 global commitinfo canv
5385 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5389 if {[info exists hovertimer]} {
5390 after cancel $hovertimer
5392 set hovertimer [after 500 linehover]
5396 proc linemotion {x y id} {
5397 global hoverx hovery hoverid hovertimer
5399 if {[info exists hoverid] && $id == $hoverid} {
5402 if {[info exists hovertimer]} {
5403 after cancel $hovertimer
5405 set hovertimer [after 500 linehover]
5409 proc lineleave {id} {
5410 global hoverid hovertimer canv
5412 if {[info exists hoverid] && $id == $hoverid} {
5414 if {[info exists hovertimer]} {
5415 after cancel $hovertimer
5423 global hoverx hovery hoverid hovertimer
5424 global canv linespc lthickness
5425 global commitinfo mainfont
5427 set text [lindex $commitinfo($hoverid) 0]
5428 set ymax [lindex [$canv cget -scrollregion] 3]
5429 if {$ymax == {}} return
5430 set yfrac [lindex [$canv yview] 0]
5431 set x [expr {$hoverx + 2 * $linespc}]
5432 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5433 set x0 [expr {$x - 2 * $lthickness}]
5434 set y0 [expr {$y - 2 * $lthickness}]
5435 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5436 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5437 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5438 -fill \#ffff80 -outline black -width 1 -tags hover]
5440 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5445 proc clickisonarrow {id y} {
5448 set ranges [rowranges $id]
5449 set thresh [expr {2 * $lthickness + 6}]
5450 set n [expr {[llength $ranges] - 1}]
5451 for {set i 1} {$i < $n} {incr i} {
5452 set row [lindex $ranges $i]
5453 if {abs([yc $row] - $y) < $thresh} {
5460 proc arrowjump {id n y} {
5463 # 1 <-> 2, 3 <-> 4, etc...
5464 set n [expr {(($n - 1) ^ 1) + 1}]
5465 set row [lindex [rowranges $id] $n]
5467 set ymax [lindex [$canv cget -scrollregion] 3]
5468 if {$ymax eq {} || $ymax <= 0} return
5469 set view [$canv yview]
5470 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5471 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5475 allcanvs yview moveto $yfrac
5478 proc lineclick {x y id isnew} {
5479 global ctext commitinfo children canv thickerline curview
5481 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5486 # draw this line thicker than normal
5490 set ymax [lindex [$canv cget -scrollregion] 3]
5491 if {$ymax eq {}} return
5492 set yfrac [lindex [$canv yview] 0]
5493 set y [expr {$y + $yfrac * $ymax}]
5495 set dirn [clickisonarrow $id $y]
5497 arrowjump $id $dirn $y
5502 addtohistory [list lineclick $x $y $id 0]
5504 # fill the details pane with info about this line
5505 $ctext conf -state normal
5507 $ctext tag conf link -foreground blue -underline 1
5508 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5509 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5510 $ctext insert end "Parent:\t"
5511 $ctext insert end $id [list link link0]
5512 $ctext tag bind link0 <1> [list selbyid $id]
5513 set info $commitinfo($id)
5514 $ctext insert end "\n\t[lindex $info 0]\n"
5515 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5516 set date [formatdate [lindex $info 2]]
5517 $ctext insert end "\tDate:\t$date\n"
5518 set kids $children($curview,$id)
5520 $ctext insert end "\nChildren:"
5522 foreach child $kids {
5524 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5525 set info $commitinfo($child)
5526 $ctext insert end "\n\t"
5527 $ctext insert end $child [list link link$i]
5528 $ctext tag bind link$i <1> [list selbyid $child]
5529 $ctext insert end "\n\t[lindex $info 0]"
5530 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5531 set date [formatdate [lindex $info 2]]
5532 $ctext insert end "\n\tDate:\t$date\n"
5535 $ctext conf -state disabled
5539 proc normalline {} {
5541 if {[info exists thickerline]} {
5549 global commitrow curview
5550 if {[info exists commitrow($curview,$id)]} {
5551 selectline $commitrow($curview,$id) 1
5557 if {![info exists startmstime]} {
5558 set startmstime [clock clicks -milliseconds]
5560 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5563 proc rowmenu {x y id} {
5564 global rowctxmenu commitrow selectedline rowmenuid curview
5565 global nullid nullid2 fakerowmenu mainhead
5568 if {![info exists selectedline]
5569 || $commitrow($curview,$id) eq $selectedline} {
5574 if {$id ne $nullid && $id ne $nullid2} {
5575 set menu $rowctxmenu
5576 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5578 set menu $fakerowmenu
5580 $menu entryconfigure "Diff this*" -state $state
5581 $menu entryconfigure "Diff selected*" -state $state
5582 $menu entryconfigure "Make patch" -state $state
5583 tk_popup $menu $x $y
5586 proc diffvssel {dirn} {
5587 global rowmenuid selectedline displayorder
5589 if {![info exists selectedline]} return
5591 set oldid [lindex $displayorder $selectedline]
5592 set newid $rowmenuid
5594 set oldid $rowmenuid
5595 set newid [lindex $displayorder $selectedline]
5597 addtohistory [list doseldiff $oldid $newid]
5598 doseldiff $oldid $newid
5601 proc doseldiff {oldid newid} {
5605 $ctext conf -state normal
5608 $ctext insert end "From "
5609 $ctext tag conf link -foreground blue -underline 1
5610 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5611 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5612 $ctext tag bind link0 <1> [list selbyid $oldid]
5613 $ctext insert end $oldid [list link link0]
5614 $ctext insert end "\n "
5615 $ctext insert end [lindex $commitinfo($oldid) 0]
5616 $ctext insert end "\n\nTo "
5617 $ctext tag bind link1 <1> [list selbyid $newid]
5618 $ctext insert end $newid [list link link1]
5619 $ctext insert end "\n "
5620 $ctext insert end [lindex $commitinfo($newid) 0]
5621 $ctext insert end "\n"
5622 $ctext conf -state disabled
5623 $ctext tag remove found 1.0 end
5624 startdiff [list $oldid $newid]
5628 global rowmenuid currentid commitinfo patchtop patchnum
5630 if {![info exists currentid]} return
5631 set oldid $currentid
5632 set oldhead [lindex $commitinfo($oldid) 0]
5633 set newid $rowmenuid
5634 set newhead [lindex $commitinfo($newid) 0]
5637 catch {destroy $top}
5639 label $top.title -text "Generate patch"
5640 grid $top.title - -pady 10
5641 label $top.from -text "From:"
5642 entry $top.fromsha1 -width 40 -relief flat
5643 $top.fromsha1 insert 0 $oldid
5644 $top.fromsha1 conf -state readonly
5645 grid $top.from $top.fromsha1 -sticky w
5646 entry $top.fromhead -width 60 -relief flat
5647 $top.fromhead insert 0 $oldhead
5648 $top.fromhead conf -state readonly
5649 grid x $top.fromhead -sticky w
5650 label $top.to -text "To:"
5651 entry $top.tosha1 -width 40 -relief flat
5652 $top.tosha1 insert 0 $newid
5653 $top.tosha1 conf -state readonly
5654 grid $top.to $top.tosha1 -sticky w
5655 entry $top.tohead -width 60 -relief flat
5656 $top.tohead insert 0 $newhead
5657 $top.tohead conf -state readonly
5658 grid x $top.tohead -sticky w
5659 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5660 grid $top.rev x -pady 10
5661 label $top.flab -text "Output file:"
5662 entry $top.fname -width 60
5663 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5665 grid $top.flab $top.fname -sticky w
5667 button $top.buts.gen -text "Generate" -command mkpatchgo
5668 button $top.buts.can -text "Cancel" -command mkpatchcan
5669 grid $top.buts.gen $top.buts.can
5670 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5671 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5672 grid $top.buts - -pady 10 -sticky ew
5676 proc mkpatchrev {} {
5679 set oldid [$patchtop.fromsha1 get]
5680 set oldhead [$patchtop.fromhead get]
5681 set newid [$patchtop.tosha1 get]
5682 set newhead [$patchtop.tohead get]
5683 foreach e [list fromsha1 fromhead tosha1 tohead] \
5684 v [list $newid $newhead $oldid $oldhead] {
5685 $patchtop.$e conf -state normal
5686 $patchtop.$e delete 0 end
5687 $patchtop.$e insert 0 $v
5688 $patchtop.$e conf -state readonly
5693 global patchtop nullid nullid2
5695 set oldid [$patchtop.fromsha1 get]
5696 set newid [$patchtop.tosha1 get]
5697 set fname [$patchtop.fname get]
5698 set cmd [diffcmd [list $oldid $newid] -p]
5699 lappend cmd >$fname &
5700 if {[catch {eval exec $cmd} err]} {
5701 error_popup "Error creating patch: $err"
5703 catch {destroy $patchtop}
5707 proc mkpatchcan {} {
5710 catch {destroy $patchtop}
5715 global rowmenuid mktagtop commitinfo
5719 catch {destroy $top}
5721 label $top.title -text "Create tag"
5722 grid $top.title - -pady 10
5723 label $top.id -text "ID:"
5724 entry $top.sha1 -width 40 -relief flat
5725 $top.sha1 insert 0 $rowmenuid
5726 $top.sha1 conf -state readonly
5727 grid $top.id $top.sha1 -sticky w
5728 entry $top.head -width 60 -relief flat
5729 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5730 $top.head conf -state readonly
5731 grid x $top.head -sticky w
5732 label $top.tlab -text "Tag name:"
5733 entry $top.tag -width 60
5734 grid $top.tlab $top.tag -sticky w
5736 button $top.buts.gen -text "Create" -command mktaggo
5737 button $top.buts.can -text "Cancel" -command mktagcan
5738 grid $top.buts.gen $top.buts.can
5739 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5740 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5741 grid $top.buts - -pady 10 -sticky ew
5746 global mktagtop env tagids idtags
5748 set id [$mktagtop.sha1 get]
5749 set tag [$mktagtop.tag get]
5751 error_popup "No tag name specified"
5754 if {[info exists tagids($tag)]} {
5755 error_popup "Tag \"$tag\" already exists"
5760 set fname [file join $dir "refs/tags" $tag]
5761 set f [open $fname w]
5765 error_popup "Error creating tag: $err"
5769 set tagids($tag) $id
5770 lappend idtags($id) $tag
5775 proc redrawtags {id} {
5776 global canv linehtag commitrow idpos selectedline curview
5777 global mainfont canvxmax iddrawn
5779 if {![info exists commitrow($curview,$id)]} return
5780 if {![info exists iddrawn($id)]} return
5781 drawcommits $commitrow($curview,$id)
5782 $canv delete tag.$id
5783 set xt [eval drawtags $id $idpos($id)]
5784 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5785 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5786 set xr [expr {$xt + [font measure $mainfont $text]}]
5787 if {$xr > $canvxmax} {
5791 if {[info exists selectedline]
5792 && $selectedline == $commitrow($curview,$id)} {
5793 selectline $selectedline 0
5800 catch {destroy $mktagtop}
5809 proc writecommit {} {
5810 global rowmenuid wrcomtop commitinfo wrcomcmd
5812 set top .writecommit
5814 catch {destroy $top}
5816 label $top.title -text "Write commit to file"
5817 grid $top.title - -pady 10
5818 label $top.id -text "ID:"
5819 entry $top.sha1 -width 40 -relief flat
5820 $top.sha1 insert 0 $rowmenuid
5821 $top.sha1 conf -state readonly
5822 grid $top.id $top.sha1 -sticky w
5823 entry $top.head -width 60 -relief flat
5824 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5825 $top.head conf -state readonly
5826 grid x $top.head -sticky w
5827 label $top.clab -text "Command:"
5828 entry $top.cmd -width 60 -textvariable wrcomcmd
5829 grid $top.clab $top.cmd -sticky w -pady 10
5830 label $top.flab -text "Output file:"
5831 entry $top.fname -width 60
5832 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5833 grid $top.flab $top.fname -sticky w
5835 button $top.buts.gen -text "Write" -command wrcomgo
5836 button $top.buts.can -text "Cancel" -command wrcomcan
5837 grid $top.buts.gen $top.buts.can
5838 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5839 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5840 grid $top.buts - -pady 10 -sticky ew
5847 set id [$wrcomtop.sha1 get]
5848 set cmd "echo $id | [$wrcomtop.cmd get]"
5849 set fname [$wrcomtop.fname get]
5850 if {[catch {exec sh -c $cmd >$fname &} err]} {
5851 error_popup "Error writing commit: $err"
5853 catch {destroy $wrcomtop}
5860 catch {destroy $wrcomtop}
5865 global rowmenuid mkbrtop
5868 catch {destroy $top}
5870 label $top.title -text "Create new branch"
5871 grid $top.title - -pady 10
5872 label $top.id -text "ID:"
5873 entry $top.sha1 -width 40 -relief flat
5874 $top.sha1 insert 0 $rowmenuid
5875 $top.sha1 conf -state readonly
5876 grid $top.id $top.sha1 -sticky w
5877 label $top.nlab -text "Name:"
5878 entry $top.name -width 40
5879 grid $top.nlab $top.name -sticky w
5881 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5882 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5883 grid $top.buts.go $top.buts.can
5884 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5885 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5886 grid $top.buts - -pady 10 -sticky ew
5891 global headids idheads
5893 set name [$top.name get]
5894 set id [$top.sha1 get]
5896 error_popup "Please specify a name for the new branch"
5899 catch {destroy $top}
5903 exec git branch $name $id
5908 set headids($name) $id
5909 lappend idheads($id) $name
5917 proc cherrypick {} {
5918 global rowmenuid curview commitrow
5921 set oldhead [exec git rev-parse HEAD]
5922 set dheads [descheads $rowmenuid]
5923 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5924 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5925 included in branch $mainhead -- really re-apply it?"]
5930 # Unfortunately git-cherry-pick writes stuff to stderr even when
5931 # no error occurs, and exec takes that as an indication of error...
5932 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5937 set newhead [exec git rev-parse HEAD]
5938 if {$newhead eq $oldhead} {
5940 error_popup "No changes committed"
5943 addnewchild $newhead $oldhead
5944 if {[info exists commitrow($curview,$oldhead)]} {
5945 insertrow $commitrow($curview,$oldhead) $newhead
5946 if {$mainhead ne {}} {
5947 movehead $newhead $mainhead
5948 movedhead $newhead $mainhead
5957 global mainheadid mainhead rowmenuid confirm_ok resettype
5958 global showlocalchanges
5961 set w ".confirmreset"
5964 wm title $w "Confirm reset"
5965 message $w.m -text \
5966 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5967 -justify center -aspect 1000
5968 pack $w.m -side top -fill x -padx 20 -pady 20
5969 frame $w.f -relief sunken -border 2
5970 message $w.f.rt -text "Reset type:" -aspect 1000
5971 grid $w.f.rt -sticky w
5973 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5974 -text "Soft: Leave working tree and index untouched"
5975 grid $w.f.soft -sticky w
5976 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5977 -text "Mixed: Leave working tree untouched, reset index"
5978 grid $w.f.mixed -sticky w
5979 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5980 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5981 grid $w.f.hard -sticky w
5982 pack $w.f -side top -fill x
5983 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5984 pack $w.ok -side left -fill x -padx 20 -pady 20
5985 button $w.cancel -text Cancel -command "destroy $w"
5986 pack $w.cancel -side right -fill x -padx 20 -pady 20
5987 bind $w <Visibility> "grab $w; focus $w"
5989 if {!$confirm_ok} return
5990 if {[catch {set fd [open \
5991 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5995 set w ".resetprogress"
5996 filerun $fd [list readresetstat $fd $w]
5999 wm title $w "Reset progress"
6000 message $w.m -text "Reset in progress, please wait..." \
6001 -justify center -aspect 1000
6002 pack $w.m -side top -fill x -padx 20 -pady 5
6003 canvas $w.c -width 150 -height 20 -bg white
6004 $w.c create rect 0 0 0 20 -fill green -tags rect
6005 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6010 proc readresetstat {fd w} {
6011 global mainhead mainheadid showlocalchanges
6013 if {[gets $fd line] >= 0} {
6014 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6015 set x [expr {($m * 150) / $n}]
6016 $w.c coords rect 0 0 $x 20
6022 if {[catch {close $fd} err]} {
6025 set oldhead $mainheadid
6026 set newhead [exec git rev-parse HEAD]
6027 if {$newhead ne $oldhead} {
6028 movehead $newhead $mainhead
6029 movedhead $newhead $mainhead
6030 set mainheadid $newhead
6034 if {$showlocalchanges} {
6040 # context menu for a head
6041 proc headmenu {x y id head} {
6042 global headmenuid headmenuhead headctxmenu mainhead
6045 set headmenuhead $head
6047 if {$head eq $mainhead} {
6050 $headctxmenu entryconfigure 0 -state $state
6051 $headctxmenu entryconfigure 1 -state $state
6052 tk_popup $headctxmenu $x $y
6056 global headmenuid headmenuhead mainhead headids
6057 global showlocalchanges mainheadid
6059 # check the tree is clean first??
6060 set oldmainhead $mainhead
6065 exec git checkout -q $headmenuhead
6071 set mainhead $headmenuhead
6072 set mainheadid $headmenuid
6073 if {[info exists headids($oldmainhead)]} {
6074 redrawtags $headids($oldmainhead)
6076 redrawtags $headmenuid
6078 if {$showlocalchanges} {
6084 global headmenuid headmenuhead mainhead
6085 global headids idheads
6087 set head $headmenuhead
6089 # this check shouldn't be needed any more...
6090 if {$head eq $mainhead} {
6091 error_popup "Cannot delete the currently checked-out branch"
6094 set dheads [descheads $id]
6095 if {$dheads eq $headids($head)} {
6096 # the stuff on this branch isn't on any other branch
6097 if {![confirm_popup "The commits on branch $head aren't on any other\
6098 branch.\nReally delete branch $head?"]} return
6102 if {[catch {exec git branch -D $head} err]} {
6107 removehead $id $head
6108 removedhead $id $head
6114 # Stuff for finding nearby tags
6115 proc getallcommits {} {
6116 global allcommits allids nbmp nextarc seeds
6126 # Called when the graph might have changed
6127 proc regetallcommits {} {
6128 global allcommits seeds
6130 set cmd [concat | git rev-list --all --parents]
6134 set fd [open $cmd r]
6135 fconfigure $fd -blocking 0
6138 filerun $fd [list getallclines $fd]
6141 # Since most commits have 1 parent and 1 child, we group strings of
6142 # such commits into "arcs" joining branch/merge points (BMPs), which
6143 # are commits that either don't have 1 parent or don't have 1 child.
6145 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6146 # arcout(id) - outgoing arcs for BMP
6147 # arcids(a) - list of IDs on arc including end but not start
6148 # arcstart(a) - BMP ID at start of arc
6149 # arcend(a) - BMP ID at end of arc
6150 # growing(a) - arc a is still growing
6151 # arctags(a) - IDs out of arcids (excluding end) that have tags
6152 # archeads(a) - IDs out of arcids (excluding end) that have heads
6153 # The start of an arc is at the descendent end, so "incoming" means
6154 # coming from descendents, and "outgoing" means going towards ancestors.
6156 proc getallclines {fd} {
6157 global allids allparents allchildren idtags idheads nextarc nbmp
6158 global arcnos arcids arctags arcout arcend arcstart archeads growing
6159 global seeds allcommits
6162 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6163 set id [lindex $line 0]
6164 if {[info exists allparents($id)]} {
6169 set olds [lrange $line 1 end]
6170 set allparents($id) $olds
6171 if {![info exists allchildren($id)]} {
6172 set allchildren($id) {}
6177 if {[llength $olds] == 1 && [llength $a] == 1} {
6178 lappend arcids($a) $id
6179 if {[info exists idtags($id)]} {
6180 lappend arctags($a) $id
6182 if {[info exists idheads($id)]} {
6183 lappend archeads($a) $id
6185 if {[info exists allparents($olds)]} {
6186 # seen parent already
6187 if {![info exists arcout($olds)]} {
6190 lappend arcids($a) $olds
6191 set arcend($a) $olds
6194 lappend allchildren($olds) $id
6195 lappend arcnos($olds) $a
6200 foreach a $arcnos($id) {
6201 lappend arcids($a) $id
6208 lappend allchildren($p) $id
6209 set a [incr nextarc]
6210 set arcstart($a) $id
6217 if {[info exists allparents($p)]} {
6218 # seen it already, may need to make a new branch
6219 if {![info exists arcout($p)]} {
6222 lappend arcids($a) $p
6226 lappend arcnos($p) $a
6231 global cached_dheads cached_dtags cached_atags
6232 catch {unset cached_dheads}
6233 catch {unset cached_dtags}
6234 catch {unset cached_atags}
6237 return [expr {$nid >= 1000? 2: 1}]
6240 if {[incr allcommits -1] == 0} {
6247 proc recalcarc {a} {
6248 global arctags archeads arcids idtags idheads
6252 foreach id [lrange $arcids($a) 0 end-1] {
6253 if {[info exists idtags($id)]} {
6256 if {[info exists idheads($id)]} {
6261 set archeads($a) $ah
6265 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6266 global arcstart arcend arcout allparents growing
6269 if {[llength $a] != 1} {
6270 puts "oops splitarc called but [llength $a] arcs already"
6274 set i [lsearch -exact $arcids($a) $p]
6276 puts "oops splitarc $p not in arc $a"
6279 set na [incr nextarc]
6280 if {[info exists arcend($a)]} {
6281 set arcend($na) $arcend($a)
6283 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6284 set j [lsearch -exact $arcnos($l) $a]
6285 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6287 set tail [lrange $arcids($a) [expr {$i+1}] end]
6288 set arcids($a) [lrange $arcids($a) 0 $i]
6290 set arcstart($na) $p
6292 set arcids($na) $tail
6293 if {[info exists growing($a)]} {
6300 if {[llength $arcnos($id)] == 1} {
6303 set j [lsearch -exact $arcnos($id) $a]
6304 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6308 # reconstruct tags and heads lists
6309 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6314 set archeads($na) {}
6318 # Update things for a new commit added that is a child of one
6319 # existing commit. Used when cherry-picking.
6320 proc addnewchild {id p} {
6321 global allids allparents allchildren idtags nextarc nbmp
6322 global arcnos arcids arctags arcout arcend arcstart archeads growing
6326 set allparents($id) [list $p]
6327 set allchildren($id) {}
6331 lappend allchildren($p) $id
6332 set a [incr nextarc]
6333 set arcstart($a) $id
6336 set arcids($a) [list $p]
6338 if {![info exists arcout($p)]} {
6341 lappend arcnos($p) $a
6342 set arcout($id) [list $a]
6345 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6346 # or 0 if neither is true.
6347 proc anc_or_desc {a b} {
6348 global arcout arcstart arcend arcnos cached_isanc
6350 if {$arcnos($a) eq $arcnos($b)} {
6351 # Both are on the same arc(s); either both are the same BMP,
6352 # or if one is not a BMP, the other is also not a BMP or is
6353 # the BMP at end of the arc (and it only has 1 incoming arc).
6354 # Or both can be BMPs with no incoming arcs.
6355 if {$a eq $b || $arcnos($a) eq {}} {
6358 # assert {[llength $arcnos($a)] == 1}
6359 set arc [lindex $arcnos($a) 0]
6360 set i [lsearch -exact $arcids($arc) $a]
6361 set j [lsearch -exact $arcids($arc) $b]
6362 if {$i < 0 || $i > $j} {
6369 if {![info exists arcout($a)]} {
6370 set arc [lindex $arcnos($a) 0]
6371 if {[info exists arcend($arc)]} {
6372 set aend $arcend($arc)
6376 set a $arcstart($arc)
6380 if {![info exists arcout($b)]} {
6381 set arc [lindex $arcnos($b) 0]
6382 if {[info exists arcend($arc)]} {
6383 set bend $arcend($arc)
6387 set b $arcstart($arc)
6397 if {[info exists cached_isanc($a,$bend)]} {
6398 if {$cached_isanc($a,$bend)} {
6402 if {[info exists cached_isanc($b,$aend)]} {
6403 if {$cached_isanc($b,$aend)} {
6406 if {[info exists cached_isanc($a,$bend)]} {
6411 set todo [list $a $b]
6414 for {set i 0} {$i < [llength $todo]} {incr i} {
6415 set x [lindex $todo $i]
6416 if {$anc($x) eq {}} {
6419 foreach arc $arcnos($x) {
6420 set xd $arcstart($arc)
6422 set cached_isanc($a,$bend) 1
6423 set cached_isanc($b,$aend) 0
6425 } elseif {$xd eq $aend} {
6426 set cached_isanc($b,$aend) 1
6427 set cached_isanc($a,$bend) 0
6430 if {![info exists anc($xd)]} {
6431 set anc($xd) $anc($x)
6433 } elseif {$anc($xd) ne $anc($x)} {
6438 set cached_isanc($a,$bend) 0
6439 set cached_isanc($b,$aend) 0
6443 # This identifies whether $desc has an ancestor that is
6444 # a growing tip of the graph and which is not an ancestor of $anc
6445 # and returns 0 if so and 1 if not.
6446 # If we subsequently discover a tag on such a growing tip, and that
6447 # turns out to be a descendent of $anc (which it could, since we
6448 # don't necessarily see children before parents), then $desc
6449 # isn't a good choice to display as a descendent tag of
6450 # $anc (since it is the descendent of another tag which is
6451 # a descendent of $anc). Similarly, $anc isn't a good choice to
6452 # display as a ancestor tag of $desc.
6454 proc is_certain {desc anc} {
6455 global arcnos arcout arcstart arcend growing problems
6458 if {[llength $arcnos($anc)] == 1} {
6459 # tags on the same arc are certain
6460 if {$arcnos($desc) eq $arcnos($anc)} {
6463 if {![info exists arcout($anc)]} {
6464 # if $anc is partway along an arc, use the start of the arc instead
6465 set a [lindex $arcnos($anc) 0]
6466 set anc $arcstart($a)
6469 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6472 set a [lindex $arcnos($desc) 0]
6478 set anclist [list $x]
6482 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6483 set x [lindex $anclist $i]
6488 foreach a $arcout($x) {
6489 if {[info exists growing($a)]} {
6490 if {![info exists growanc($x)] && $dl($x)} {
6496 if {[info exists dl($y)]} {
6500 if {![info exists done($y)]} {
6503 if {[info exists growanc($x)]} {
6507 for {set k 0} {$k < [llength $xl]} {incr k} {
6508 set z [lindex $xl $k]
6509 foreach c $arcout($z) {
6510 if {[info exists arcend($c)]} {
6512 if {[info exists dl($v)] && $dl($v)} {
6514 if {![info exists done($v)]} {
6517 if {[info exists growanc($v)]} {
6527 } elseif {$y eq $anc || !$dl($x)} {
6538 foreach x [array names growanc] {
6547 proc validate_arctags {a} {
6548 global arctags idtags
6552 foreach id $arctags($a) {
6554 if {![info exists idtags($id)]} {
6555 set na [lreplace $na $i $i]
6562 proc validate_archeads {a} {
6563 global archeads idheads
6566 set na $archeads($a)
6567 foreach id $archeads($a) {
6569 if {![info exists idheads($id)]} {
6570 set na [lreplace $na $i $i]
6574 set archeads($a) $na
6577 # Return the list of IDs that have tags that are descendents of id,
6578 # ignoring IDs that are descendents of IDs already reported.
6579 proc desctags {id} {
6580 global arcnos arcstart arcids arctags idtags allparents
6581 global growing cached_dtags
6583 if {![info exists allparents($id)]} {
6586 set t1 [clock clicks -milliseconds]
6588 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6589 # part-way along an arc; check that arc first
6590 set a [lindex $arcnos($id) 0]
6591 if {$arctags($a) ne {}} {
6593 set i [lsearch -exact $arcids($a) $id]
6595 foreach t $arctags($a) {
6596 set j [lsearch -exact $arcids($a) $t]
6604 set id $arcstart($a)
6605 if {[info exists idtags($id)]} {
6609 if {[info exists cached_dtags($id)]} {
6610 return $cached_dtags($id)
6617 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6618 set id [lindex $todo $i]
6620 set ta [info exists hastaggedancestor($id)]
6624 # ignore tags on starting node
6625 if {!$ta && $i > 0} {
6626 if {[info exists idtags($id)]} {
6629 } elseif {[info exists cached_dtags($id)]} {
6630 set tagloc($id) $cached_dtags($id)
6634 foreach a $arcnos($id) {
6636 if {!$ta && $arctags($a) ne {}} {
6638 if {$arctags($a) ne {}} {
6639 lappend tagloc($id) [lindex $arctags($a) end]
6642 if {$ta || $arctags($a) ne {}} {
6643 set tomark [list $d]
6644 for {set j 0} {$j < [llength $tomark]} {incr j} {
6645 set dd [lindex $tomark $j]
6646 if {![info exists hastaggedancestor($dd)]} {
6647 if {[info exists done($dd)]} {
6648 foreach b $arcnos($dd) {
6649 lappend tomark $arcstart($b)
6651 if {[info exists tagloc($dd)]} {
6654 } elseif {[info exists queued($dd)]} {
6657 set hastaggedancestor($dd) 1
6661 if {![info exists queued($d)]} {
6664 if {![info exists hastaggedancestor($d)]} {
6671 foreach id [array names tagloc] {
6672 if {![info exists hastaggedancestor($id)]} {
6673 foreach t $tagloc($id) {
6674 if {[lsearch -exact $tags $t] < 0} {
6680 set t2 [clock clicks -milliseconds]
6683 # remove tags that are descendents of other tags
6684 for {set i 0} {$i < [llength $tags]} {incr i} {
6685 set a [lindex $tags $i]
6686 for {set j 0} {$j < $i} {incr j} {
6687 set b [lindex $tags $j]
6688 set r [anc_or_desc $a $b]
6690 set tags [lreplace $tags $j $j]
6693 } elseif {$r == -1} {
6694 set tags [lreplace $tags $i $i]
6701 if {[array names growing] ne {}} {
6702 # graph isn't finished, need to check if any tag could get
6703 # eclipsed by another tag coming later. Simply ignore any
6704 # tags that could later get eclipsed.
6707 if {[is_certain $t $origid]} {
6711 if {$tags eq $ctags} {
6712 set cached_dtags($origid) $tags
6717 set cached_dtags($origid) $tags
6719 set t3 [clock clicks -milliseconds]
6720 if {0 && $t3 - $t1 >= 100} {
6721 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6722 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6728 global arcnos arcids arcout arcend arctags idtags allparents
6729 global growing cached_atags
6731 if {![info exists allparents($id)]} {
6734 set t1 [clock clicks -milliseconds]
6736 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6737 # part-way along an arc; check that arc first
6738 set a [lindex $arcnos($id) 0]
6739 if {$arctags($a) ne {}} {
6741 set i [lsearch -exact $arcids($a) $id]
6742 foreach t $arctags($a) {
6743 set j [lsearch -exact $arcids($a) $t]
6749 if {![info exists arcend($a)]} {
6753 if {[info exists idtags($id)]} {
6757 if {[info exists cached_atags($id)]} {
6758 return $cached_atags($id)
6766 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6767 set id [lindex $todo $i]
6769 set td [info exists hastaggeddescendent($id)]
6773 # ignore tags on starting node
6774 if {!$td && $i > 0} {
6775 if {[info exists idtags($id)]} {
6778 } elseif {[info exists cached_atags($id)]} {
6779 set tagloc($id) $cached_atags($id)
6783 foreach a $arcout($id) {
6784 if {!$td && $arctags($a) ne {}} {
6786 if {$arctags($a) ne {}} {
6787 lappend tagloc($id) [lindex $arctags($a) 0]
6790 if {![info exists arcend($a)]} continue
6792 if {$td || $arctags($a) ne {}} {
6793 set tomark [list $d]
6794 for {set j 0} {$j < [llength $tomark]} {incr j} {
6795 set dd [lindex $tomark $j]
6796 if {![info exists hastaggeddescendent($dd)]} {
6797 if {[info exists done($dd)]} {
6798 foreach b $arcout($dd) {
6799 if {[info exists arcend($b)]} {
6800 lappend tomark $arcend($b)
6803 if {[info exists tagloc($dd)]} {
6806 } elseif {[info exists queued($dd)]} {
6809 set hastaggeddescendent($dd) 1
6813 if {![info exists queued($d)]} {
6816 if {![info exists hastaggeddescendent($d)]} {
6822 set t2 [clock clicks -milliseconds]
6825 foreach id [array names tagloc] {
6826 if {![info exists hastaggeddescendent($id)]} {
6827 foreach t $tagloc($id) {
6828 if {[lsearch -exact $tags $t] < 0} {
6835 # remove tags that are ancestors of other tags
6836 for {set i 0} {$i < [llength $tags]} {incr i} {
6837 set a [lindex $tags $i]
6838 for {set j 0} {$j < $i} {incr j} {
6839 set b [lindex $tags $j]
6840 set r [anc_or_desc $a $b]
6842 set tags [lreplace $tags $j $j]
6845 } elseif {$r == 1} {
6846 set tags [lreplace $tags $i $i]
6853 if {[array names growing] ne {}} {
6854 # graph isn't finished, need to check if any tag could get
6855 # eclipsed by another tag coming later. Simply ignore any
6856 # tags that could later get eclipsed.
6859 if {[is_certain $origid $t]} {
6863 if {$tags eq $ctags} {
6864 set cached_atags($origid) $tags
6869 set cached_atags($origid) $tags
6871 set t3 [clock clicks -milliseconds]
6872 if {0 && $t3 - $t1 >= 100} {
6873 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6874 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6879 # Return the list of IDs that have heads that are descendents of id,
6880 # including id itself if it has a head.
6881 proc descheads {id} {
6882 global arcnos arcstart arcids archeads idheads cached_dheads
6885 if {![info exists allparents($id)]} {
6889 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6890 # part-way along an arc; check it first
6891 set a [lindex $arcnos($id) 0]
6892 if {$archeads($a) ne {}} {
6893 validate_archeads $a
6894 set i [lsearch -exact $arcids($a) $id]
6895 foreach t $archeads($a) {
6896 set j [lsearch -exact $arcids($a) $t]
6901 set id $arcstart($a)
6907 for {set i 0} {$i < [llength $todo]} {incr i} {
6908 set id [lindex $todo $i]
6909 if {[info exists cached_dheads($id)]} {
6910 set ret [concat $ret $cached_dheads($id)]
6912 if {[info exists idheads($id)]} {
6915 foreach a $arcnos($id) {
6916 if {$archeads($a) ne {}} {
6917 validate_archeads $a
6918 if {$archeads($a) ne {}} {
6919 set ret [concat $ret $archeads($a)]
6923 if {![info exists seen($d)]} {
6930 set ret [lsort -unique $ret]
6931 set cached_dheads($origid) $ret
6932 return [concat $ret $aret]
6935 proc addedtag {id} {
6936 global arcnos arcout cached_dtags cached_atags
6938 if {![info exists arcnos($id)]} return
6939 if {![info exists arcout($id)]} {
6940 recalcarc [lindex $arcnos($id) 0]
6942 catch {unset cached_dtags}
6943 catch {unset cached_atags}
6946 proc addedhead {hid head} {
6947 global arcnos arcout cached_dheads
6949 if {![info exists arcnos($hid)]} return
6950 if {![info exists arcout($hid)]} {
6951 recalcarc [lindex $arcnos($hid) 0]
6953 catch {unset cached_dheads}
6956 proc removedhead {hid head} {
6957 global cached_dheads
6959 catch {unset cached_dheads}
6962 proc movedhead {hid head} {
6963 global arcnos arcout cached_dheads
6965 if {![info exists arcnos($hid)]} return
6966 if {![info exists arcout($hid)]} {
6967 recalcarc [lindex $arcnos($hid) 0]
6969 catch {unset cached_dheads}
6972 proc changedrefs {} {
6973 global cached_dheads cached_dtags cached_atags
6974 global arctags archeads arcnos arcout idheads idtags
6976 foreach id [concat [array names idheads] [array names idtags]] {
6977 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6978 set a [lindex $arcnos($id) 0]
6979 if {![info exists donearc($a)]} {
6985 catch {unset cached_dtags}
6986 catch {unset cached_atags}
6987 catch {unset cached_dheads}
6990 proc rereadrefs {} {
6991 global idtags idheads idotherrefs mainhead
6993 set refids [concat [array names idtags] \
6994 [array names idheads] [array names idotherrefs]]
6995 foreach id $refids {
6996 if {![info exists ref($id)]} {
6997 set ref($id) [listrefs $id]
7000 set oldmainhead $mainhead
7003 set refids [lsort -unique [concat $refids [array names idtags] \
7004 [array names idheads] [array names idotherrefs]]]
7005 foreach id $refids {
7006 set v [listrefs $id]
7007 if {![info exists ref($id)] || $ref($id) != $v ||
7008 ($id eq $oldmainhead && $id ne $mainhead) ||
7009 ($id eq $mainhead && $id ne $oldmainhead)} {
7015 proc listrefs {id} {
7016 global idtags idheads idotherrefs
7019 if {[info exists idtags($id)]} {
7023 if {[info exists idheads($id)]} {
7027 if {[info exists idotherrefs($id)]} {
7028 set z $idotherrefs($id)
7030 return [list $x $y $z]
7033 proc showtag {tag isnew} {
7034 global ctext tagcontents tagids linknum tagobjid
7037 addtohistory [list showtag $tag 0]
7039 $ctext conf -state normal
7042 if {![info exists tagcontents($tag)]} {
7044 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7047 if {[info exists tagcontents($tag)]} {
7048 set text $tagcontents($tag)
7050 set text "Tag: $tag\nId: $tagids($tag)"
7052 appendwithlinks $text {}
7053 $ctext conf -state disabled
7065 global maxwidth maxgraphpct diffopts
7066 global oldprefs prefstop showneartags showlocalchanges
7067 global bgcolor fgcolor ctext diffcolors selectbgcolor
7068 global uifont tabstop
7072 if {[winfo exists $top]} {
7076 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7077 set oldprefs($v) [set $v]
7080 wm title $top "Gitk preferences"
7081 label $top.ldisp -text "Commit list display options"
7082 $top.ldisp configure -font $uifont
7083 grid $top.ldisp - -sticky w -pady 10
7084 label $top.spacer -text " "
7085 label $top.maxwidthl -text "Maximum graph width (lines)" \
7087 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7088 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7089 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7091 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7092 grid x $top.maxpctl $top.maxpct -sticky w
7093 frame $top.showlocal
7094 label $top.showlocal.l -text "Show local changes" -font optionfont
7095 checkbutton $top.showlocal.b -variable showlocalchanges
7096 pack $top.showlocal.b $top.showlocal.l -side left
7097 grid x $top.showlocal -sticky w
7099 label $top.ddisp -text "Diff display options"
7100 $top.ddisp configure -font $uifont
7101 grid $top.ddisp - -sticky w -pady 10
7102 label $top.diffoptl -text "Options for diff program" \
7104 entry $top.diffopt -width 20 -textvariable diffopts
7105 grid x $top.diffoptl $top.diffopt -sticky w
7107 label $top.ntag.l -text "Display nearby tags" -font optionfont
7108 checkbutton $top.ntag.b -variable showneartags
7109 pack $top.ntag.b $top.ntag.l -side left
7110 grid x $top.ntag -sticky w
7111 label $top.tabstopl -text "tabstop" -font optionfont
7112 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7113 grid x $top.tabstopl $top.tabstop -sticky w
7115 label $top.cdisp -text "Colors: press to choose"
7116 $top.cdisp configure -font $uifont
7117 grid $top.cdisp - -sticky w -pady 10
7118 label $top.bg -padx 40 -relief sunk -background $bgcolor
7119 button $top.bgbut -text "Background" -font optionfont \
7120 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7121 grid x $top.bgbut $top.bg -sticky w
7122 label $top.fg -padx 40 -relief sunk -background $fgcolor
7123 button $top.fgbut -text "Foreground" -font optionfont \
7124 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7125 grid x $top.fgbut $top.fg -sticky w
7126 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7127 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7128 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7129 [list $ctext tag conf d0 -foreground]]
7130 grid x $top.diffoldbut $top.diffold -sticky w
7131 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7132 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7133 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7134 [list $ctext tag conf d1 -foreground]]
7135 grid x $top.diffnewbut $top.diffnew -sticky w
7136 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7137 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7138 -command [list choosecolor diffcolors 2 $top.hunksep \
7139 "diff hunk header" \
7140 [list $ctext tag conf hunksep -foreground]]
7141 grid x $top.hunksepbut $top.hunksep -sticky w
7142 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7143 button $top.selbgbut -text "Select bg" -font optionfont \
7144 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7145 grid x $top.selbgbut $top.selbgsep -sticky w
7148 button $top.buts.ok -text "OK" -command prefsok -default active
7149 $top.buts.ok configure -font $uifont
7150 button $top.buts.can -text "Cancel" -command prefscan -default normal
7151 $top.buts.can configure -font $uifont
7152 grid $top.buts.ok $top.buts.can
7153 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7154 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7155 grid $top.buts - - -pady 10 -sticky ew
7156 bind $top <Visibility> "focus $top.buts.ok"
7159 proc choosecolor {v vi w x cmd} {
7162 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7163 -title "Gitk: choose color for $x"]
7164 if {$c eq {}} return
7165 $w conf -background $c
7171 global bglist cflist
7173 $w configure -selectbackground $c
7175 $cflist tag configure highlight \
7176 -background [$cflist cget -selectbackground]
7177 allcanvs itemconf secsel -fill $c
7184 $w conf -background $c
7192 $w conf -foreground $c
7194 allcanvs itemconf text -fill $c
7195 $canv itemconf circle -outline $c
7199 global maxwidth maxgraphpct diffopts
7200 global oldprefs prefstop showneartags showlocalchanges
7202 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7203 set $v $oldprefs($v)
7205 catch {destroy $prefstop}
7210 global maxwidth maxgraphpct
7211 global oldprefs prefstop showneartags showlocalchanges
7212 global charspc ctext tabstop
7214 catch {destroy $prefstop}
7216 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7217 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7218 if {$showlocalchanges} {
7224 if {$maxwidth != $oldprefs(maxwidth)
7225 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7227 } elseif {$showneartags != $oldprefs(showneartags)} {
7232 proc formatdate {d} {
7234 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7239 # This list of encoding names and aliases is distilled from
7240 # http://www.iana.org/assignments/character-sets.
7241 # Not all of them are supported by Tcl.
7242 set encoding_aliases {
7243 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7244 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7245 { ISO-10646-UTF-1 csISO10646UTF1 }
7246 { ISO_646.basic:1983 ref csISO646basic1983 }
7247 { INVARIANT csINVARIANT }
7248 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7249 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7250 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7251 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7252 { NATS-DANO iso-ir-9-1 csNATSDANO }
7253 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7254 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7255 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7256 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7257 { ISO-2022-KR csISO2022KR }
7259 { ISO-2022-JP csISO2022JP }
7260 { ISO-2022-JP-2 csISO2022JP2 }
7261 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7263 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7264 { IT iso-ir-15 ISO646-IT csISO15Italian }
7265 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7266 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7267 { greek7-old iso-ir-18 csISO18Greek7Old }
7268 { latin-greek iso-ir-19 csISO19LatinGreek }
7269 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7270 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7271 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7272 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7273 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7274 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7275 { INIS iso-ir-49 csISO49INIS }
7276 { INIS-8 iso-ir-50 csISO50INIS8 }
7277 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7278 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7279 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7280 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7281 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7282 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7284 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7285 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7286 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7287 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7288 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7289 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7290 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7291 { greek7 iso-ir-88 csISO88Greek7 }
7292 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7293 { iso-ir-90 csISO90 }
7294 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7295 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7296 csISO92JISC62991984b }
7297 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7298 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7299 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7300 csISO95JIS62291984handadd }
7301 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7302 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7303 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7304 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7306 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7307 { T.61-7bit iso-ir-102 csISO102T617bit }
7308 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7309 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7310 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7311 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7312 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7313 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7314 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7315 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7316 arabic csISOLatinArabic }
7317 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7318 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7319 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7320 greek greek8 csISOLatinGreek }
7321 { T.101-G2 iso-ir-128 csISO128T101G2 }
7322 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7324 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7325 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7326 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7327 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7328 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7329 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7330 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7331 csISOLatinCyrillic }
7332 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7333 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7334 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7335 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7336 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7337 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7338 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7339 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7340 { ISO_10367-box iso-ir-155 csISO10367Box }
7341 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7342 { latin-lap lap iso-ir-158 csISO158Lap }
7343 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7344 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7347 { JIS_X0201 X0201 csHalfWidthKatakana }
7348 { KSC5636 ISO646-KR csKSC5636 }
7349 { ISO-10646-UCS-2 csUnicode }
7350 { ISO-10646-UCS-4 csUCS4 }
7351 { DEC-MCS dec csDECMCS }
7352 { hp-roman8 roman8 r8 csHPRoman8 }
7353 { macintosh mac csMacintosh }
7354 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7356 { IBM038 EBCDIC-INT cp038 csIBM038 }
7357 { IBM273 CP273 csIBM273 }
7358 { IBM274 EBCDIC-BE CP274 csIBM274 }
7359 { IBM275 EBCDIC-BR cp275 csIBM275 }
7360 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7361 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7362 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7363 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7364 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7365 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7366 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7367 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7368 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7369 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7370 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7371 { IBM437 cp437 437 csPC8CodePage437 }
7372 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7373 { IBM775 cp775 csPC775Baltic }
7374 { IBM850 cp850 850 csPC850Multilingual }
7375 { IBM851 cp851 851 csIBM851 }
7376 { IBM852 cp852 852 csPCp852 }
7377 { IBM855 cp855 855 csIBM855 }
7378 { IBM857 cp857 857 csIBM857 }
7379 { IBM860 cp860 860 csIBM860 }
7380 { IBM861 cp861 861 cp-is csIBM861 }
7381 { IBM862 cp862 862 csPC862LatinHebrew }
7382 { IBM863 cp863 863 csIBM863 }
7383 { IBM864 cp864 csIBM864 }
7384 { IBM865 cp865 865 csIBM865 }
7385 { IBM866 cp866 866 csIBM866 }
7386 { IBM868 CP868 cp-ar csIBM868 }
7387 { IBM869 cp869 869 cp-gr csIBM869 }
7388 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7389 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7390 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7391 { IBM891 cp891 csIBM891 }
7392 { IBM903 cp903 csIBM903 }
7393 { IBM904 cp904 904 csIBBM904 }
7394 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7395 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7396 { IBM1026 CP1026 csIBM1026 }
7397 { EBCDIC-AT-DE csIBMEBCDICATDE }
7398 { EBCDIC-AT-DE-A csEBCDICATDEA }
7399 { EBCDIC-CA-FR csEBCDICCAFR }
7400 { EBCDIC-DK-NO csEBCDICDKNO }
7401 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7402 { EBCDIC-FI-SE csEBCDICFISE }
7403 { EBCDIC-FI-SE-A csEBCDICFISEA }
7404 { EBCDIC-FR csEBCDICFR }
7405 { EBCDIC-IT csEBCDICIT }
7406 { EBCDIC-PT csEBCDICPT }
7407 { EBCDIC-ES csEBCDICES }
7408 { EBCDIC-ES-A csEBCDICESA }
7409 { EBCDIC-ES-S csEBCDICESS }
7410 { EBCDIC-UK csEBCDICUK }
7411 { EBCDIC-US csEBCDICUS }
7412 { UNKNOWN-8BIT csUnknown8BiT }
7413 { MNEMONIC csMnemonic }
7418 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7419 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7420 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7421 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7422 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7423 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7424 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7425 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7426 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7427 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7428 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7429 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7430 { IBM1047 IBM-1047 }
7431 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7432 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7433 { UNICODE-1-1 csUnicode11 }
7436 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7437 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7439 { ISO-8859-15 ISO_8859-15 Latin-9 }
7440 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7441 { GBK CP936 MS936 windows-936 }
7442 { JIS_Encoding csJISEncoding }
7443 { Shift_JIS MS_Kanji csShiftJIS }
7444 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7446 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7447 { ISO-10646-UCS-Basic csUnicodeASCII }
7448 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7449 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7450 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7451 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7452 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7453 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7454 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7455 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7456 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7457 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7458 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7459 { Ventura-US csVenturaUS }
7460 { Ventura-International csVenturaInternational }
7461 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7462 { PC8-Turkish csPC8Turkish }
7463 { IBM-Symbols csIBMSymbols }
7464 { IBM-Thai csIBMThai }
7465 { HP-Legal csHPLegal }
7466 { HP-Pi-font csHPPiFont }
7467 { HP-Math8 csHPMath8 }
7468 { Adobe-Symbol-Encoding csHPPSMath }
7469 { HP-DeskTop csHPDesktop }
7470 { Ventura-Math csVenturaMath }
7471 { Microsoft-Publishing csMicrosoftPublishing }
7472 { Windows-31J csWindows31J }
7477 proc tcl_encoding {enc} {
7478 global encoding_aliases
7479 set names [encoding names]
7480 set lcnames [string tolower $names]
7481 set enc [string tolower $enc]
7482 set i [lsearch -exact $lcnames $enc]
7484 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7485 if {[regsub {^iso[-_]} $enc iso encx]} {
7486 set i [lsearch -exact $lcnames $encx]
7490 foreach l $encoding_aliases {
7491 set ll [string tolower $l]
7492 if {[lsearch -exact $ll $enc] < 0} continue
7493 # look through the aliases for one that tcl knows about
7495 set i [lsearch -exact $lcnames $e]
7497 if {[regsub {^iso[-_]} $e iso ex]} {
7498 set i [lsearch -exact $lcnames $ex]
7507 return [lindex $names $i]
7514 set diffopts "-U 5 -p"
7515 set wrcomcmd "git diff-tree --stdin -p --pretty"
7519 set gitencoding [exec git config --get i18n.commitencoding]
7521 if {$gitencoding == ""} {
7522 set gitencoding "utf-8"
7524 set tclencoding [tcl_encoding $gitencoding]
7525 if {$tclencoding == {}} {
7526 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7529 set mainfont {Helvetica 9}
7530 set textfont {Courier 9}
7531 set uifont {Helvetica 9 bold}
7533 set findmergefiles 0
7541 set cmitmode "patch"
7542 set wrapcomment "none"
7546 set showlocalchanges 1
7548 set colors {green red blue magenta darkgrey brown orange}
7551 set diffcolors {red "#00a000" blue}
7552 set selectbgcolor gray85
7554 catch {source ~/.gitk}
7556 font create optionfont -family sans-serif -size -12
7558 # check that we can find a .git directory somewhere...
7560 if {![file isdirectory $gitdir]} {
7561 show_error {} . "Cannot find the git directory \"$gitdir\"."
7566 set cmdline_files {}
7571 "-d" { set datemode 1 }
7573 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7577 lappend revtreeargs $arg
7583 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7584 # no -- on command line, but some arguments (other than -d)
7586 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7587 set cmdline_files [split $f "\n"]
7588 set n [llength $cmdline_files]
7589 set revtreeargs [lrange $revtreeargs 0 end-$n]
7590 # Unfortunately git rev-parse doesn't produce an error when
7591 # something is both a revision and a filename. To be consistent
7592 # with git log and git rev-list, check revtreeargs for filenames.
7593 foreach arg $revtreeargs {
7594 if {[file exists $arg]} {
7595 show_error {} . "Ambiguous argument '$arg': both revision\
7601 # unfortunately we get both stdout and stderr in $err,
7602 # so look for "fatal:".
7603 set i [string first "fatal:" $err]
7605 set err [string range $err [expr {$i + 6}] end]
7607 show_error {} . "Bad arguments to gitk:\n$err"
7612 set nullid "0000000000000000000000000000000000000000"
7613 set nullid2 "0000000000000000000000000000000000000001"
7621 set highlight_paths {}
7622 set searchdirn -forwards
7626 set markingmatches 0
7633 set selectedhlview None
7642 set lookingforhead 0
7648 # wait for the window to become visible
7650 wm title . "[file tail $argv0]: [file tail [pwd]]"
7653 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7654 # create a view for the files/dirs specified on the command line
7658 set viewname(1) "Command line"
7659 set viewfiles(1) $cmdline_files
7660 set viewargs(1) $revtreeargs
7663 .bar.view entryconf Edit* -state normal
7664 .bar.view entryconf Delete* -state normal
7667 if {[info exists permviews]} {
7668 foreach v $permviews {
7671 set viewname($n) [lindex $v 0]
7672 set viewfiles($n) [lindex $v 1]
7673 set viewargs($n) [lindex $v 2]