gitk: Make it possible to lay out all the rows we have received so far
[git.git] / gitk
bloba042efe260bd62ac0f8d36e4d35dbe870ab7a2d5
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
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.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
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.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
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} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc dorunq {} {
51 global isonrunq runq
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
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]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
76 if {$runq ne {}} {
77 after idle dorunq
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx viewcomplete vnextroot
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set viewcomplete($view) 0
91 set vnextroot($view) 0
92 set order "--topo-order"
93 if {$datemode} {
94 set order "--date-order"
96 if {[catch {
97 set fd [open [concat | git log -z --pretty=raw $order --parents \
98 --boundary $viewargs($view) "--" $viewfiles($view)] r]
99 } err]} {
100 error_popup "Error executing git rev-list: $err"
101 exit 1
103 set commfd($view) $fd
104 set leftover($view) {}
105 set lookingforhead $showlocalchanges
106 fconfigure $fd -blocking 0 -translation lf -eofchar {}
107 if {$tclencoding != {}} {
108 fconfigure $fd -encoding $tclencoding
110 filerun $fd [list getcommitlines $fd $view]
111 nowbusy $view
114 proc stop_rev_list {} {
115 global commfd curview
117 if {![info exists commfd($curview)]} return
118 set fd $commfd($curview)
119 catch {
120 set pid [pid $fd]
121 exec kill $pid
123 catch {close $fd}
124 unset commfd($curview)
127 proc getcommits {} {
128 global phase canv mainfont curview
130 set phase getcommits
131 initlayout
132 start_rev_list $curview
133 show_status "Reading commits..."
136 # This makes a string representation of a positive integer which
137 # sorts as a string in numerical order
138 proc strrep {n} {
139 if {$n < 16} {
140 return [format "%x" $n]
141 } elseif {$n < 256} {
142 return [format "x%.2x" $n]
143 } elseif {$n < 65536} {
144 return [format "y%.4x" $n]
146 return [format "z%.8x" $n]
149 proc getcommitlines {fd view} {
150 global commitlisted
151 global leftover commfd
152 global displayorder commitidx viewcomplete commitrow commitdata
153 global parentlist children curview hlview
154 global vparentlist vdisporder vcmitlisted
155 global ordertok vnextroot idpending
157 set stuff [read $fd 500000]
158 # git log doesn't terminate the last commit with a null...
159 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
160 set stuff "\0"
162 if {$stuff == {}} {
163 if {![eof $fd]} {
164 return 1
166 # Check if we have seen any ids listed as parents that haven't
167 # appeared in the list
168 foreach vid [array names idpending "$view,*"] {
169 # should only get here if git log is buggy
170 set id [lindex [split $vid ","] 1]
171 set commitrow($vid) $commitidx($view)
172 incr commitidx($view)
173 if {$view == $curview} {
174 lappend parentlist {}
175 lappend displayorder $id
176 lappend commitlisted 0
177 } else {
178 lappend vparentlist($view) {}
179 lappend vdisporder($view) $id
180 lappend vcmitlisted($view) 0
183 set viewcomplete($view) 1
184 global viewname
185 unset commfd($view)
186 notbusy $view
187 # set it blocking so we wait for the process to terminate
188 fconfigure $fd -blocking 1
189 if {[catch {close $fd} err]} {
190 set fv {}
191 if {$view != $curview} {
192 set fv " for the \"$viewname($view)\" view"
194 if {[string range $err 0 4] == "usage"} {
195 set err "Gitk: error reading commits$fv:\
196 bad arguments to git rev-list."
197 if {$viewname($view) eq "Command line"} {
198 append err \
199 " (Note: arguments to gitk are passed to git rev-list\
200 to allow selection of commits to be displayed.)"
202 } else {
203 set err "Error reading commits$fv: $err"
205 error_popup $err
207 if {$view == $curview} {
208 run chewcommits $view
210 return 0
212 set start 0
213 set gotsome 0
214 while 1 {
215 set i [string first "\0" $stuff $start]
216 if {$i < 0} {
217 append leftover($view) [string range $stuff $start end]
218 break
220 if {$start == 0} {
221 set cmit $leftover($view)
222 append cmit [string range $stuff 0 [expr {$i - 1}]]
223 set leftover($view) {}
224 } else {
225 set cmit [string range $stuff $start [expr {$i - 1}]]
227 set start [expr {$i + 1}]
228 set j [string first "\n" $cmit]
229 set ok 0
230 set listed 1
231 if {$j >= 0 && [string match "commit *" $cmit]} {
232 set ids [string range $cmit 7 [expr {$j - 1}]]
233 if {[string match {[-<>]*} $ids]} {
234 switch -- [string index $ids 0] {
235 "-" {set listed 0}
236 "<" {set listed 2}
237 ">" {set listed 3}
239 set ids [string range $ids 1 end]
241 set ok 1
242 foreach id $ids {
243 if {[string length $id] != 40} {
244 set ok 0
245 break
249 if {!$ok} {
250 set shortcmit $cmit
251 if {[string length $shortcmit] > 80} {
252 set shortcmit "[string range $shortcmit 0 80]..."
254 error_popup "Can't parse git log output: {$shortcmit}"
255 exit 1
257 set id [lindex $ids 0]
258 if {![info exists ordertok($view,$id)]} {
259 set otok "o[strrep $vnextroot($view)]"
260 incr vnextroot($view)
261 set ordertok($view,$id) $otok
262 } else {
263 set otok $ordertok($view,$id)
264 unset idpending($view,$id)
266 if {$listed} {
267 set olds [lrange $ids 1 end]
268 if {[llength $olds] == 1} {
269 set p [lindex $olds 0]
270 lappend children($view,$p) $id
271 if {![info exists ordertok($view,$p)]} {
272 set ordertok($view,$p) $ordertok($view,$id)
273 set idpending($view,$p) 1
275 } else {
276 set i 0
277 foreach p $olds {
278 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
279 lappend children($view,$p) $id
281 if {![info exists ordertok($view,$p)]} {
282 set ordertok($view,$p) "$otok[strrep $i]]"
283 set idpending($view,$p) 1
285 incr i
288 } else {
289 set olds {}
291 if {![info exists children($view,$id)]} {
292 set children($view,$id) {}
294 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
295 set commitrow($view,$id) $commitidx($view)
296 incr commitidx($view)
297 if {$view == $curview} {
298 lappend parentlist $olds
299 lappend displayorder $id
300 lappend commitlisted $listed
301 } else {
302 lappend vparentlist($view) $olds
303 lappend vdisporder($view) $id
304 lappend vcmitlisted($view) $listed
306 set gotsome 1
308 if {$gotsome} {
309 run chewcommits $view
311 return 2
314 proc chewcommits {view} {
315 global curview hlview viewcomplete
316 global selectedline pending_select
318 if {$view == $curview} {
319 layoutmore
320 if {$viewcomplete($view)} {
321 global displayorder commitidx phase
322 global numcommits startmsecs
324 if {[info exists pending_select]} {
325 set row [first_real_row]
326 selectline $row 1
328 if {$commitidx($curview) > 0} {
329 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
330 #puts "overall $ms ms for $numcommits commits"
331 } else {
332 show_status "No commits selected"
334 notbusy layout
335 set phase {}
338 if {[info exists hlview] && $view == $hlview} {
339 vhighlightmore
341 return 0
344 proc readcommit {id} {
345 if {[catch {set contents [exec git cat-file commit $id]}]} return
346 parsecommit $id $contents 0
349 proc updatecommits {} {
350 global viewdata curview phase displayorder ordertok idpending
351 global children commitrow selectedline thickerline showneartags
353 if {$phase ne {}} {
354 stop_rev_list
355 set phase {}
357 set n $curview
358 foreach id $displayorder {
359 catch {unset children($n,$id)}
360 catch {unset commitrow($n,$id)}
361 catch {unset ordertok($n,$id)}
363 foreach vid [array names idpending "$n,*"] {
364 unset idpending($vid)
366 set curview -1
367 catch {unset selectedline}
368 catch {unset thickerline}
369 catch {unset viewdata($n)}
370 readrefs
371 changedrefs
372 if {$showneartags} {
373 getallcommits
375 showview $n
378 proc parsecommit {id contents listed} {
379 global commitinfo cdate
381 set inhdr 1
382 set comment {}
383 set headline {}
384 set auname {}
385 set audate {}
386 set comname {}
387 set comdate {}
388 set hdrend [string first "\n\n" $contents]
389 if {$hdrend < 0} {
390 # should never happen...
391 set hdrend [string length $contents]
393 set header [string range $contents 0 [expr {$hdrend - 1}]]
394 set comment [string range $contents [expr {$hdrend + 2}] end]
395 foreach line [split $header "\n"] {
396 set tag [lindex $line 0]
397 if {$tag == "author"} {
398 set audate [lindex $line end-1]
399 set auname [lrange $line 1 end-2]
400 } elseif {$tag == "committer"} {
401 set comdate [lindex $line end-1]
402 set comname [lrange $line 1 end-2]
405 set headline {}
406 # take the first non-blank line of the comment as the headline
407 set headline [string trimleft $comment]
408 set i [string first "\n" $headline]
409 if {$i >= 0} {
410 set headline [string range $headline 0 $i]
412 set headline [string trimright $headline]
413 set i [string first "\r" $headline]
414 if {$i >= 0} {
415 set headline [string trimright [string range $headline 0 $i]]
417 if {!$listed} {
418 # git rev-list indents the comment by 4 spaces;
419 # if we got this via git cat-file, add the indentation
420 set newcomment {}
421 foreach line [split $comment "\n"] {
422 append newcomment " "
423 append newcomment $line
424 append newcomment "\n"
426 set comment $newcomment
428 if {$comdate != {}} {
429 set cdate($id) $comdate
431 set commitinfo($id) [list $headline $auname $audate \
432 $comname $comdate $comment]
435 proc getcommit {id} {
436 global commitdata commitinfo
438 if {[info exists commitdata($id)]} {
439 parsecommit $id $commitdata($id) 1
440 } else {
441 readcommit $id
442 if {![info exists commitinfo($id)]} {
443 set commitinfo($id) {"No commit information available"}
446 return 1
449 proc readrefs {} {
450 global tagids idtags headids idheads tagobjid
451 global otherrefids idotherrefs mainhead mainheadid
453 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
454 catch {unset $v}
456 set refd [open [list | git show-ref -d] r]
457 while {[gets $refd line] >= 0} {
458 if {[string index $line 40] ne " "} continue
459 set id [string range $line 0 39]
460 set ref [string range $line 41 end]
461 if {![string match "refs/*" $ref]} continue
462 set name [string range $ref 5 end]
463 if {[string match "remotes/*" $name]} {
464 if {![string match "*/HEAD" $name]} {
465 set headids($name) $id
466 lappend idheads($id) $name
468 } elseif {[string match "heads/*" $name]} {
469 set name [string range $name 6 end]
470 set headids($name) $id
471 lappend idheads($id) $name
472 } elseif {[string match "tags/*" $name]} {
473 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
474 # which is what we want since the former is the commit ID
475 set name [string range $name 5 end]
476 if {[string match "*^{}" $name]} {
477 set name [string range $name 0 end-3]
478 } else {
479 set tagobjid($name) $id
481 set tagids($name) $id
482 lappend idtags($id) $name
483 } else {
484 set otherrefids($name) $id
485 lappend idotherrefs($id) $name
488 catch {close $refd}
489 set mainhead {}
490 set mainheadid {}
491 catch {
492 set thehead [exec git symbolic-ref HEAD]
493 if {[string match "refs/heads/*" $thehead]} {
494 set mainhead [string range $thehead 11 end]
495 if {[info exists headids($mainhead)]} {
496 set mainheadid $headids($mainhead)
502 # skip over fake commits
503 proc first_real_row {} {
504 global nullid nullid2 displayorder numcommits
506 for {set row 0} {$row < $numcommits} {incr row} {
507 set id [lindex $displayorder $row]
508 if {$id ne $nullid && $id ne $nullid2} {
509 break
512 return $row
515 # update things for a head moved to a child of its previous location
516 proc movehead {id name} {
517 global headids idheads
519 removehead $headids($name) $name
520 set headids($name) $id
521 lappend idheads($id) $name
524 # update things when a head has been removed
525 proc removehead {id name} {
526 global headids idheads
528 if {$idheads($id) eq $name} {
529 unset idheads($id)
530 } else {
531 set i [lsearch -exact $idheads($id) $name]
532 if {$i >= 0} {
533 set idheads($id) [lreplace $idheads($id) $i $i]
536 unset headids($name)
539 proc show_error {w top msg} {
540 message $w.m -text $msg -justify center -aspect 400
541 pack $w.m -side top -fill x -padx 20 -pady 20
542 button $w.ok -text OK -command "destroy $top"
543 pack $w.ok -side bottom -fill x
544 bind $top <Visibility> "grab $top; focus $top"
545 bind $top <Key-Return> "destroy $top"
546 tkwait window $top
549 proc error_popup msg {
550 set w .error
551 toplevel $w
552 wm transient $w .
553 show_error $w $w $msg
556 proc confirm_popup msg {
557 global confirm_ok
558 set confirm_ok 0
559 set w .confirm
560 toplevel $w
561 wm transient $w .
562 message $w.m -text $msg -justify center -aspect 400
563 pack $w.m -side top -fill x -padx 20 -pady 20
564 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
565 pack $w.ok -side left -fill x
566 button $w.cancel -text Cancel -command "destroy $w"
567 pack $w.cancel -side right -fill x
568 bind $w <Visibility> "grab $w; focus $w"
569 tkwait window $w
570 return $confirm_ok
573 proc makewindow {} {
574 global canv canv2 canv3 linespc charspc ctext cflist
575 global textfont mainfont uifont tabstop
576 global findtype findtypemenu findloc findstring fstring geometry
577 global entries sha1entry sha1string sha1but
578 global diffcontextstring diffcontext
579 global maincursor textcursor curtextcursor
580 global rowctxmenu fakerowmenu mergemax wrapcomment
581 global highlight_files gdttype
582 global searchstring sstring
583 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
584 global headctxmenu
586 menu .bar
587 .bar add cascade -label "File" -menu .bar.file
588 .bar configure -font $uifont
589 menu .bar.file
590 .bar.file add command -label "Update" -command updatecommits
591 .bar.file add command -label "Reread references" -command rereadrefs
592 .bar.file add command -label "List references" -command showrefs
593 .bar.file add command -label "Quit" -command doquit
594 .bar.file configure -font $uifont
595 menu .bar.edit
596 .bar add cascade -label "Edit" -menu .bar.edit
597 .bar.edit add command -label "Preferences" -command doprefs
598 .bar.edit configure -font $uifont
600 menu .bar.view -font $uifont
601 .bar add cascade -label "View" -menu .bar.view
602 .bar.view add command -label "New view..." -command {newview 0}
603 .bar.view add command -label "Edit view..." -command editview \
604 -state disabled
605 .bar.view add command -label "Delete view" -command delview -state disabled
606 .bar.view add separator
607 .bar.view add radiobutton -label "All files" -command {showview 0} \
608 -variable selectedview -value 0
610 menu .bar.help
611 .bar add cascade -label "Help" -menu .bar.help
612 .bar.help add command -label "About gitk" -command about
613 .bar.help add command -label "Key bindings" -command keys
614 .bar.help configure -font $uifont
615 . configure -menu .bar
617 # the gui has upper and lower half, parts of a paned window.
618 panedwindow .ctop -orient vertical
620 # possibly use assumed geometry
621 if {![info exists geometry(pwsash0)]} {
622 set geometry(topheight) [expr {15 * $linespc}]
623 set geometry(topwidth) [expr {80 * $charspc}]
624 set geometry(botheight) [expr {15 * $linespc}]
625 set geometry(botwidth) [expr {50 * $charspc}]
626 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
627 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
630 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
631 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
632 frame .tf.histframe
633 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
635 # create three canvases
636 set cscroll .tf.histframe.csb
637 set canv .tf.histframe.pwclist.canv
638 canvas $canv \
639 -selectbackground $selectbgcolor \
640 -background $bgcolor -bd 0 \
641 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
642 .tf.histframe.pwclist add $canv
643 set canv2 .tf.histframe.pwclist.canv2
644 canvas $canv2 \
645 -selectbackground $selectbgcolor \
646 -background $bgcolor -bd 0 -yscrollincr $linespc
647 .tf.histframe.pwclist add $canv2
648 set canv3 .tf.histframe.pwclist.canv3
649 canvas $canv3 \
650 -selectbackground $selectbgcolor \
651 -background $bgcolor -bd 0 -yscrollincr $linespc
652 .tf.histframe.pwclist add $canv3
653 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
654 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
656 # a scroll bar to rule them
657 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
658 pack $cscroll -side right -fill y
659 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
660 lappend bglist $canv $canv2 $canv3
661 pack .tf.histframe.pwclist -fill both -expand 1 -side left
663 # we have two button bars at bottom of top frame. Bar 1
664 frame .tf.bar
665 frame .tf.lbar -height 15
667 set sha1entry .tf.bar.sha1
668 set entries $sha1entry
669 set sha1but .tf.bar.sha1label
670 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
671 -command gotocommit -width 8 -font $uifont
672 $sha1but conf -disabledforeground [$sha1but cget -foreground]
673 pack .tf.bar.sha1label -side left
674 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
675 trace add variable sha1string write sha1change
676 pack $sha1entry -side left -pady 2
678 image create bitmap bm-left -data {
679 #define left_width 16
680 #define left_height 16
681 static unsigned char left_bits[] = {
682 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
683 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
684 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
686 image create bitmap bm-right -data {
687 #define right_width 16
688 #define right_height 16
689 static unsigned char right_bits[] = {
690 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
691 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
692 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
694 button .tf.bar.leftbut -image bm-left -command goback \
695 -state disabled -width 26
696 pack .tf.bar.leftbut -side left -fill y
697 button .tf.bar.rightbut -image bm-right -command goforw \
698 -state disabled -width 26
699 pack .tf.bar.rightbut -side left -fill y
701 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
702 pack .tf.bar.findbut -side left
703 set findstring {}
704 set fstring .tf.bar.findstring
705 lappend entries $fstring
706 entry $fstring -width 30 -font $textfont -textvariable findstring
707 trace add variable findstring write find_change
708 pack $fstring -side left -expand 1 -fill x -in .tf.bar
709 set findtype Exact
710 set findtypemenu [tk_optionMenu .tf.bar.findtype \
711 findtype Exact IgnCase Regexp]
712 trace add variable findtype write find_change
713 .tf.bar.findtype configure -font $uifont
714 .tf.bar.findtype.menu configure -font $uifont
715 set findloc "All fields"
716 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
717 Comments Author Committer
718 trace add variable findloc write find_change
719 .tf.bar.findloc configure -font $uifont
720 .tf.bar.findloc.menu configure -font $uifont
721 pack .tf.bar.findloc -side right
722 pack .tf.bar.findtype -side right
724 # build up the bottom bar of upper window
725 label .tf.lbar.flabel -text "Highlight: Commits " \
726 -font $uifont
727 pack .tf.lbar.flabel -side left -fill y
728 set gdttype "touching paths:"
729 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
730 "adding/removing string:"]
731 trace add variable gdttype write hfiles_change
732 $gm conf -font $uifont
733 .tf.lbar.gdttype conf -font $uifont
734 pack .tf.lbar.gdttype -side left -fill y
735 entry .tf.lbar.fent -width 25 -font $textfont \
736 -textvariable highlight_files
737 trace add variable highlight_files write hfiles_change
738 lappend entries .tf.lbar.fent
739 pack .tf.lbar.fent -side left -fill x -expand 1
740 label .tf.lbar.vlabel -text " OR in view" -font $uifont
741 pack .tf.lbar.vlabel -side left -fill y
742 global viewhlmenu selectedhlview
743 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
744 $viewhlmenu entryconf None -command delvhighlight
745 $viewhlmenu conf -font $uifont
746 .tf.lbar.vhl conf -font $uifont
747 pack .tf.lbar.vhl -side left -fill y
748 label .tf.lbar.rlabel -text " OR " -font $uifont
749 pack .tf.lbar.rlabel -side left -fill y
750 global highlight_related
751 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
752 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
753 $m conf -font $uifont
754 .tf.lbar.relm conf -font $uifont
755 trace add variable highlight_related write vrel_change
756 pack .tf.lbar.relm -side left -fill y
758 # Finish putting the upper half of the viewer together
759 pack .tf.lbar -in .tf -side bottom -fill x
760 pack .tf.bar -in .tf -side bottom -fill x
761 pack .tf.histframe -fill both -side top -expand 1
762 .ctop add .tf
763 .ctop paneconfigure .tf -height $geometry(topheight)
764 .ctop paneconfigure .tf -width $geometry(topwidth)
766 # now build up the bottom
767 panedwindow .pwbottom -orient horizontal
769 # lower left, a text box over search bar, scroll bar to the right
770 # if we know window height, then that will set the lower text height, otherwise
771 # we set lower text height which will drive window height
772 if {[info exists geometry(main)]} {
773 frame .bleft -width $geometry(botwidth)
774 } else {
775 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
777 frame .bleft.top
778 frame .bleft.mid
780 button .bleft.top.search -text "Search" -command dosearch \
781 -font $uifont
782 pack .bleft.top.search -side left -padx 5
783 set sstring .bleft.top.sstring
784 entry $sstring -width 20 -font $textfont -textvariable searchstring
785 lappend entries $sstring
786 trace add variable searchstring write incrsearch
787 pack $sstring -side left -expand 1 -fill x
788 radiobutton .bleft.mid.diff -text "Diff" \
789 -command changediffdisp -variable diffelide -value {0 0}
790 radiobutton .bleft.mid.old -text "Old version" \
791 -command changediffdisp -variable diffelide -value {0 1}
792 radiobutton .bleft.mid.new -text "New version" \
793 -command changediffdisp -variable diffelide -value {1 0}
794 label .bleft.mid.labeldiffcontext -text " Lines of context: " \
795 -font $uifont
796 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
797 spinbox .bleft.mid.diffcontext -width 5 -font $textfont \
798 -from 1 -increment 1 -to 10000000 \
799 -validate all -validatecommand "diffcontextvalidate %P" \
800 -textvariable diffcontextstring
801 .bleft.mid.diffcontext set $diffcontext
802 trace add variable diffcontextstring write diffcontextchange
803 lappend entries .bleft.mid.diffcontext
804 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
805 set ctext .bleft.ctext
806 text $ctext -background $bgcolor -foreground $fgcolor \
807 -tabs "[expr {$tabstop * $charspc}]" \
808 -state disabled -font $textfont \
809 -yscrollcommand scrolltext -wrap none
810 scrollbar .bleft.sb -command "$ctext yview"
811 pack .bleft.top -side top -fill x
812 pack .bleft.mid -side top -fill x
813 pack .bleft.sb -side right -fill y
814 pack $ctext -side left -fill both -expand 1
815 lappend bglist $ctext
816 lappend fglist $ctext
818 $ctext tag conf comment -wrap $wrapcomment
819 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
820 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
821 $ctext tag conf d0 -fore [lindex $diffcolors 0]
822 $ctext tag conf d1 -fore [lindex $diffcolors 1]
823 $ctext tag conf m0 -fore red
824 $ctext tag conf m1 -fore blue
825 $ctext tag conf m2 -fore green
826 $ctext tag conf m3 -fore purple
827 $ctext tag conf m4 -fore brown
828 $ctext tag conf m5 -fore "#009090"
829 $ctext tag conf m6 -fore magenta
830 $ctext tag conf m7 -fore "#808000"
831 $ctext tag conf m8 -fore "#009000"
832 $ctext tag conf m9 -fore "#ff0080"
833 $ctext tag conf m10 -fore cyan
834 $ctext tag conf m11 -fore "#b07070"
835 $ctext tag conf m12 -fore "#70b0f0"
836 $ctext tag conf m13 -fore "#70f0b0"
837 $ctext tag conf m14 -fore "#f0b070"
838 $ctext tag conf m15 -fore "#ff70b0"
839 $ctext tag conf mmax -fore darkgrey
840 set mergemax 16
841 $ctext tag conf mresult -font [concat $textfont bold]
842 $ctext tag conf msep -font [concat $textfont bold]
843 $ctext tag conf found -back yellow
845 .pwbottom add .bleft
846 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
848 # lower right
849 frame .bright
850 frame .bright.mode
851 radiobutton .bright.mode.patch -text "Patch" \
852 -command reselectline -variable cmitmode -value "patch"
853 .bright.mode.patch configure -font $uifont
854 radiobutton .bright.mode.tree -text "Tree" \
855 -command reselectline -variable cmitmode -value "tree"
856 .bright.mode.tree configure -font $uifont
857 grid .bright.mode.patch .bright.mode.tree -sticky ew
858 pack .bright.mode -side top -fill x
859 set cflist .bright.cfiles
860 set indent [font measure $mainfont "nn"]
861 text $cflist \
862 -selectbackground $selectbgcolor \
863 -background $bgcolor -foreground $fgcolor \
864 -font $mainfont \
865 -tabs [list $indent [expr {2 * $indent}]] \
866 -yscrollcommand ".bright.sb set" \
867 -cursor [. cget -cursor] \
868 -spacing1 1 -spacing3 1
869 lappend bglist $cflist
870 lappend fglist $cflist
871 scrollbar .bright.sb -command "$cflist yview"
872 pack .bright.sb -side right -fill y
873 pack $cflist -side left -fill both -expand 1
874 $cflist tag configure highlight \
875 -background [$cflist cget -selectbackground]
876 $cflist tag configure bold -font [concat $mainfont bold]
878 .pwbottom add .bright
879 .ctop add .pwbottom
881 # restore window position if known
882 if {[info exists geometry(main)]} {
883 wm geometry . "$geometry(main)"
886 if {[tk windowingsystem] eq {aqua}} {
887 set M1B M1
888 } else {
889 set M1B Control
892 bind .pwbottom <Configure> {resizecdetpanes %W %w}
893 pack .ctop -fill both -expand 1
894 bindall <1> {selcanvline %W %x %y}
895 #bindall <B1-Motion> {selcanvline %W %x %y}
896 if {[tk windowingsystem] == "win32"} {
897 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
898 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
899 } else {
900 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
901 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
903 bindall <2> "canvscan mark %W %x %y"
904 bindall <B2-Motion> "canvscan dragto %W %x %y"
905 bindkey <Home> selfirstline
906 bindkey <End> sellastline
907 bind . <Key-Up> "selnextline -1"
908 bind . <Key-Down> "selnextline 1"
909 bind . <Shift-Key-Up> "next_highlight -1"
910 bind . <Shift-Key-Down> "next_highlight 1"
911 bindkey <Key-Right> "goforw"
912 bindkey <Key-Left> "goback"
913 bind . <Key-Prior> "selnextpage -1"
914 bind . <Key-Next> "selnextpage 1"
915 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
916 bind . <$M1B-End> "allcanvs yview moveto 1.0"
917 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
918 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
919 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
920 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
921 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
922 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
923 bindkey <Key-space> "$ctext yview scroll 1 pages"
924 bindkey p "selnextline -1"
925 bindkey n "selnextline 1"
926 bindkey z "goback"
927 bindkey x "goforw"
928 bindkey i "selnextline -1"
929 bindkey k "selnextline 1"
930 bindkey j "goback"
931 bindkey l "goforw"
932 bindkey b "$ctext yview scroll -1 pages"
933 bindkey d "$ctext yview scroll 18 units"
934 bindkey u "$ctext yview scroll -18 units"
935 bindkey / {findnext 1}
936 bindkey <Key-Return> {findnext 0}
937 bindkey ? findprev
938 bindkey f nextfile
939 bindkey <F5> updatecommits
940 bind . <$M1B-q> doquit
941 bind . <$M1B-f> dofind
942 bind . <$M1B-g> {findnext 0}
943 bind . <$M1B-r> dosearchback
944 bind . <$M1B-s> dosearch
945 bind . <$M1B-equal> {incrfont 1}
946 bind . <$M1B-KP_Add> {incrfont 1}
947 bind . <$M1B-minus> {incrfont -1}
948 bind . <$M1B-KP_Subtract> {incrfont -1}
949 wm protocol . WM_DELETE_WINDOW doquit
950 bind . <Button-1> "click %W"
951 bind $fstring <Key-Return> dofind
952 bind $sha1entry <Key-Return> gotocommit
953 bind $sha1entry <<PasteSelection>> clearsha1
954 bind $cflist <1> {sel_flist %W %x %y; break}
955 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
956 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
957 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
959 set maincursor [. cget -cursor]
960 set textcursor [$ctext cget -cursor]
961 set curtextcursor $textcursor
963 set rowctxmenu .rowctxmenu
964 menu $rowctxmenu -tearoff 0
965 $rowctxmenu add command -label "Diff this -> selected" \
966 -command {diffvssel 0}
967 $rowctxmenu add command -label "Diff selected -> this" \
968 -command {diffvssel 1}
969 $rowctxmenu add command -label "Make patch" -command mkpatch
970 $rowctxmenu add command -label "Create tag" -command mktag
971 $rowctxmenu add command -label "Write commit to file" -command writecommit
972 $rowctxmenu add command -label "Create new branch" -command mkbranch
973 $rowctxmenu add command -label "Cherry-pick this commit" \
974 -command cherrypick
975 $rowctxmenu add command -label "Reset HEAD branch to here" \
976 -command resethead
978 set fakerowmenu .fakerowmenu
979 menu $fakerowmenu -tearoff 0
980 $fakerowmenu add command -label "Diff this -> selected" \
981 -command {diffvssel 0}
982 $fakerowmenu add command -label "Diff selected -> this" \
983 -command {diffvssel 1}
984 $fakerowmenu add command -label "Make patch" -command mkpatch
985 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
986 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
987 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
989 set headctxmenu .headctxmenu
990 menu $headctxmenu -tearoff 0
991 $headctxmenu add command -label "Check out this branch" \
992 -command cobranch
993 $headctxmenu add command -label "Remove this branch" \
994 -command rmbranch
996 global flist_menu
997 set flist_menu .flistctxmenu
998 menu $flist_menu -tearoff 0
999 $flist_menu add command -label "Highlight this too" \
1000 -command {flist_hl 0}
1001 $flist_menu add command -label "Highlight this only" \
1002 -command {flist_hl 1}
1005 # Windows sends all mouse wheel events to the current focused window, not
1006 # the one where the mouse hovers, so bind those events here and redirect
1007 # to the correct window
1008 proc windows_mousewheel_redirector {W X Y D} {
1009 global canv canv2 canv3
1010 set w [winfo containing -displayof $W $X $Y]
1011 if {$w ne ""} {
1012 set u [expr {$D < 0 ? 5 : -5}]
1013 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1014 allcanvs yview scroll $u units
1015 } else {
1016 catch {
1017 $w yview scroll $u units
1023 # mouse-2 makes all windows scan vertically, but only the one
1024 # the cursor is in scans horizontally
1025 proc canvscan {op w x y} {
1026 global canv canv2 canv3
1027 foreach c [list $canv $canv2 $canv3] {
1028 if {$c == $w} {
1029 $c scan $op $x $y
1030 } else {
1031 $c scan $op 0 $y
1036 proc scrollcanv {cscroll f0 f1} {
1037 $cscroll set $f0 $f1
1038 drawfrac $f0 $f1
1039 flushhighlights
1042 # when we make a key binding for the toplevel, make sure
1043 # it doesn't get triggered when that key is pressed in the
1044 # find string entry widget.
1045 proc bindkey {ev script} {
1046 global entries
1047 bind . $ev $script
1048 set escript [bind Entry $ev]
1049 if {$escript == {}} {
1050 set escript [bind Entry <Key>]
1052 foreach e $entries {
1053 bind $e $ev "$escript; break"
1057 # set the focus back to the toplevel for any click outside
1058 # the entry widgets
1059 proc click {w} {
1060 global ctext entries
1061 foreach e [concat $entries $ctext] {
1062 if {$w == $e} return
1064 focus .
1067 proc savestuff {w} {
1068 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
1069 global stuffsaved findmergefiles maxgraphpct
1070 global maxwidth showneartags showlocalchanges
1071 global viewname viewfiles viewargs viewperm nextviewnum
1072 global cmitmode wrapcomment datetimeformat
1073 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1075 if {$stuffsaved} return
1076 if {![winfo viewable .]} return
1077 catch {
1078 set f [open "~/.gitk-new" w]
1079 puts $f [list set mainfont $mainfont]
1080 puts $f [list set textfont $textfont]
1081 puts $f [list set uifont $uifont]
1082 puts $f [list set tabstop $tabstop]
1083 puts $f [list set findmergefiles $findmergefiles]
1084 puts $f [list set maxgraphpct $maxgraphpct]
1085 puts $f [list set maxwidth $maxwidth]
1086 puts $f [list set cmitmode $cmitmode]
1087 puts $f [list set wrapcomment $wrapcomment]
1088 puts $f [list set showneartags $showneartags]
1089 puts $f [list set showlocalchanges $showlocalchanges]
1090 puts $f [list set datetimeformat $datetimeformat]
1091 puts $f [list set bgcolor $bgcolor]
1092 puts $f [list set fgcolor $fgcolor]
1093 puts $f [list set colors $colors]
1094 puts $f [list set diffcolors $diffcolors]
1095 puts $f [list set diffcontext $diffcontext]
1096 puts $f [list set selectbgcolor $selectbgcolor]
1098 puts $f "set geometry(main) [wm geometry .]"
1099 puts $f "set geometry(topwidth) [winfo width .tf]"
1100 puts $f "set geometry(topheight) [winfo height .tf]"
1101 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1102 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1103 puts $f "set geometry(botwidth) [winfo width .bleft]"
1104 puts $f "set geometry(botheight) [winfo height .bleft]"
1106 puts -nonewline $f "set permviews {"
1107 for {set v 0} {$v < $nextviewnum} {incr v} {
1108 if {$viewperm($v)} {
1109 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1112 puts $f "}"
1113 close $f
1114 file rename -force "~/.gitk-new" "~/.gitk"
1116 set stuffsaved 1
1119 proc resizeclistpanes {win w} {
1120 global oldwidth
1121 if {[info exists oldwidth($win)]} {
1122 set s0 [$win sash coord 0]
1123 set s1 [$win sash coord 1]
1124 if {$w < 60} {
1125 set sash0 [expr {int($w/2 - 2)}]
1126 set sash1 [expr {int($w*5/6 - 2)}]
1127 } else {
1128 set factor [expr {1.0 * $w / $oldwidth($win)}]
1129 set sash0 [expr {int($factor * [lindex $s0 0])}]
1130 set sash1 [expr {int($factor * [lindex $s1 0])}]
1131 if {$sash0 < 30} {
1132 set sash0 30
1134 if {$sash1 < $sash0 + 20} {
1135 set sash1 [expr {$sash0 + 20}]
1137 if {$sash1 > $w - 10} {
1138 set sash1 [expr {$w - 10}]
1139 if {$sash0 > $sash1 - 20} {
1140 set sash0 [expr {$sash1 - 20}]
1144 $win sash place 0 $sash0 [lindex $s0 1]
1145 $win sash place 1 $sash1 [lindex $s1 1]
1147 set oldwidth($win) $w
1150 proc resizecdetpanes {win w} {
1151 global oldwidth
1152 if {[info exists oldwidth($win)]} {
1153 set s0 [$win sash coord 0]
1154 if {$w < 60} {
1155 set sash0 [expr {int($w*3/4 - 2)}]
1156 } else {
1157 set factor [expr {1.0 * $w / $oldwidth($win)}]
1158 set sash0 [expr {int($factor * [lindex $s0 0])}]
1159 if {$sash0 < 45} {
1160 set sash0 45
1162 if {$sash0 > $w - 15} {
1163 set sash0 [expr {$w - 15}]
1166 $win sash place 0 $sash0 [lindex $s0 1]
1168 set oldwidth($win) $w
1171 proc allcanvs args {
1172 global canv canv2 canv3
1173 eval $canv $args
1174 eval $canv2 $args
1175 eval $canv3 $args
1178 proc bindall {event action} {
1179 global canv canv2 canv3
1180 bind $canv $event $action
1181 bind $canv2 $event $action
1182 bind $canv3 $event $action
1185 proc about {} {
1186 global uifont
1187 set w .about
1188 if {[winfo exists $w]} {
1189 raise $w
1190 return
1192 toplevel $w
1193 wm title $w "About gitk"
1194 message $w.m -text {
1195 Gitk - a commit viewer for git
1197 Copyright © 2005-2006 Paul Mackerras
1199 Use and redistribute under the terms of the GNU General Public License} \
1200 -justify center -aspect 400 -border 2 -bg white -relief groove
1201 pack $w.m -side top -fill x -padx 2 -pady 2
1202 $w.m configure -font $uifont
1203 button $w.ok -text Close -command "destroy $w" -default active
1204 pack $w.ok -side bottom
1205 $w.ok configure -font $uifont
1206 bind $w <Visibility> "focus $w.ok"
1207 bind $w <Key-Escape> "destroy $w"
1208 bind $w <Key-Return> "destroy $w"
1211 proc keys {} {
1212 global uifont
1213 set w .keys
1214 if {[winfo exists $w]} {
1215 raise $w
1216 return
1218 if {[tk windowingsystem] eq {aqua}} {
1219 set M1T Cmd
1220 } else {
1221 set M1T Ctrl
1223 toplevel $w
1224 wm title $w "Gitk key bindings"
1225 message $w.m -text "
1226 Gitk key bindings:
1228 <$M1T-Q> Quit
1229 <Home> Move to first commit
1230 <End> Move to last commit
1231 <Up>, p, i Move up one commit
1232 <Down>, n, k Move down one commit
1233 <Left>, z, j Go back in history list
1234 <Right>, x, l Go forward in history list
1235 <PageUp> Move up one page in commit list
1236 <PageDown> Move down one page in commit list
1237 <$M1T-Home> Scroll to top of commit list
1238 <$M1T-End> Scroll to bottom of commit list
1239 <$M1T-Up> Scroll commit list up one line
1240 <$M1T-Down> Scroll commit list down one line
1241 <$M1T-PageUp> Scroll commit list up one page
1242 <$M1T-PageDown> Scroll commit list down one page
1243 <Shift-Up> Move to previous highlighted line
1244 <Shift-Down> Move to next highlighted line
1245 <Delete>, b Scroll diff view up one page
1246 <Backspace> Scroll diff view up one page
1247 <Space> Scroll diff view down one page
1248 u Scroll diff view up 18 lines
1249 d Scroll diff view down 18 lines
1250 <$M1T-F> Find
1251 <$M1T-G> Move to next find hit
1252 <Return> Move to next find hit
1253 / Move to next find hit, or redo find
1254 ? Move to previous find hit
1255 f Scroll diff view to next file
1256 <$M1T-S> Search for next hit in diff view
1257 <$M1T-R> Search for previous hit in diff view
1258 <$M1T-KP+> Increase font size
1259 <$M1T-plus> Increase font size
1260 <$M1T-KP-> Decrease font size
1261 <$M1T-minus> Decrease font size
1262 <F5> Update
1264 -justify left -bg white -border 2 -relief groove
1265 pack $w.m -side top -fill both -padx 2 -pady 2
1266 $w.m configure -font $uifont
1267 button $w.ok -text Close -command "destroy $w" -default active
1268 pack $w.ok -side bottom
1269 $w.ok configure -font $uifont
1270 bind $w <Visibility> "focus $w.ok"
1271 bind $w <Key-Escape> "destroy $w"
1272 bind $w <Key-Return> "destroy $w"
1275 # Procedures for manipulating the file list window at the
1276 # bottom right of the overall window.
1278 proc treeview {w l openlevs} {
1279 global treecontents treediropen treeheight treeparent treeindex
1281 set ix 0
1282 set treeindex() 0
1283 set lev 0
1284 set prefix {}
1285 set prefixend -1
1286 set prefendstack {}
1287 set htstack {}
1288 set ht 0
1289 set treecontents() {}
1290 $w conf -state normal
1291 foreach f $l {
1292 while {[string range $f 0 $prefixend] ne $prefix} {
1293 if {$lev <= $openlevs} {
1294 $w mark set e:$treeindex($prefix) "end -1c"
1295 $w mark gravity e:$treeindex($prefix) left
1297 set treeheight($prefix) $ht
1298 incr ht [lindex $htstack end]
1299 set htstack [lreplace $htstack end end]
1300 set prefixend [lindex $prefendstack end]
1301 set prefendstack [lreplace $prefendstack end end]
1302 set prefix [string range $prefix 0 $prefixend]
1303 incr lev -1
1305 set tail [string range $f [expr {$prefixend+1}] end]
1306 while {[set slash [string first "/" $tail]] >= 0} {
1307 lappend htstack $ht
1308 set ht 0
1309 lappend prefendstack $prefixend
1310 incr prefixend [expr {$slash + 1}]
1311 set d [string range $tail 0 $slash]
1312 lappend treecontents($prefix) $d
1313 set oldprefix $prefix
1314 append prefix $d
1315 set treecontents($prefix) {}
1316 set treeindex($prefix) [incr ix]
1317 set treeparent($prefix) $oldprefix
1318 set tail [string range $tail [expr {$slash+1}] end]
1319 if {$lev <= $openlevs} {
1320 set ht 1
1321 set treediropen($prefix) [expr {$lev < $openlevs}]
1322 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1323 $w mark set d:$ix "end -1c"
1324 $w mark gravity d:$ix left
1325 set str "\n"
1326 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1327 $w insert end $str
1328 $w image create end -align center -image $bm -padx 1 \
1329 -name a:$ix
1330 $w insert end $d [highlight_tag $prefix]
1331 $w mark set s:$ix "end -1c"
1332 $w mark gravity s:$ix left
1334 incr lev
1336 if {$tail ne {}} {
1337 if {$lev <= $openlevs} {
1338 incr ht
1339 set str "\n"
1340 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1341 $w insert end $str
1342 $w insert end $tail [highlight_tag $f]
1344 lappend treecontents($prefix) $tail
1347 while {$htstack ne {}} {
1348 set treeheight($prefix) $ht
1349 incr ht [lindex $htstack end]
1350 set htstack [lreplace $htstack end end]
1351 set prefixend [lindex $prefendstack end]
1352 set prefendstack [lreplace $prefendstack end end]
1353 set prefix [string range $prefix 0 $prefixend]
1355 $w conf -state disabled
1358 proc linetoelt {l} {
1359 global treeheight treecontents
1361 set y 2
1362 set prefix {}
1363 while {1} {
1364 foreach e $treecontents($prefix) {
1365 if {$y == $l} {
1366 return "$prefix$e"
1368 set n 1
1369 if {[string index $e end] eq "/"} {
1370 set n $treeheight($prefix$e)
1371 if {$y + $n > $l} {
1372 append prefix $e
1373 incr y
1374 break
1377 incr y $n
1382 proc highlight_tree {y prefix} {
1383 global treeheight treecontents cflist
1385 foreach e $treecontents($prefix) {
1386 set path $prefix$e
1387 if {[highlight_tag $path] ne {}} {
1388 $cflist tag add bold $y.0 "$y.0 lineend"
1390 incr y
1391 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1392 set y [highlight_tree $y $path]
1395 return $y
1398 proc treeclosedir {w dir} {
1399 global treediropen treeheight treeparent treeindex
1401 set ix $treeindex($dir)
1402 $w conf -state normal
1403 $w delete s:$ix e:$ix
1404 set treediropen($dir) 0
1405 $w image configure a:$ix -image tri-rt
1406 $w conf -state disabled
1407 set n [expr {1 - $treeheight($dir)}]
1408 while {$dir ne {}} {
1409 incr treeheight($dir) $n
1410 set dir $treeparent($dir)
1414 proc treeopendir {w dir} {
1415 global treediropen treeheight treeparent treecontents treeindex
1417 set ix $treeindex($dir)
1418 $w conf -state normal
1419 $w image configure a:$ix -image tri-dn
1420 $w mark set e:$ix s:$ix
1421 $w mark gravity e:$ix right
1422 set lev 0
1423 set str "\n"
1424 set n [llength $treecontents($dir)]
1425 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1426 incr lev
1427 append str "\t"
1428 incr treeheight($x) $n
1430 foreach e $treecontents($dir) {
1431 set de $dir$e
1432 if {[string index $e end] eq "/"} {
1433 set iy $treeindex($de)
1434 $w mark set d:$iy e:$ix
1435 $w mark gravity d:$iy left
1436 $w insert e:$ix $str
1437 set treediropen($de) 0
1438 $w image create e:$ix -align center -image tri-rt -padx 1 \
1439 -name a:$iy
1440 $w insert e:$ix $e [highlight_tag $de]
1441 $w mark set s:$iy e:$ix
1442 $w mark gravity s:$iy left
1443 set treeheight($de) 1
1444 } else {
1445 $w insert e:$ix $str
1446 $w insert e:$ix $e [highlight_tag $de]
1449 $w mark gravity e:$ix left
1450 $w conf -state disabled
1451 set treediropen($dir) 1
1452 set top [lindex [split [$w index @0,0] .] 0]
1453 set ht [$w cget -height]
1454 set l [lindex [split [$w index s:$ix] .] 0]
1455 if {$l < $top} {
1456 $w yview $l.0
1457 } elseif {$l + $n + 1 > $top + $ht} {
1458 set top [expr {$l + $n + 2 - $ht}]
1459 if {$l < $top} {
1460 set top $l
1462 $w yview $top.0
1466 proc treeclick {w x y} {
1467 global treediropen cmitmode ctext cflist cflist_top
1469 if {$cmitmode ne "tree"} return
1470 if {![info exists cflist_top]} return
1471 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1472 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1473 $cflist tag add highlight $l.0 "$l.0 lineend"
1474 set cflist_top $l
1475 if {$l == 1} {
1476 $ctext yview 1.0
1477 return
1479 set e [linetoelt $l]
1480 if {[string index $e end] ne "/"} {
1481 showfile $e
1482 } elseif {$treediropen($e)} {
1483 treeclosedir $w $e
1484 } else {
1485 treeopendir $w $e
1489 proc setfilelist {id} {
1490 global treefilelist cflist
1492 treeview $cflist $treefilelist($id) 0
1495 image create bitmap tri-rt -background black -foreground blue -data {
1496 #define tri-rt_width 13
1497 #define tri-rt_height 13
1498 static unsigned char tri-rt_bits[] = {
1499 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1500 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1501 0x00, 0x00};
1502 } -maskdata {
1503 #define tri-rt-mask_width 13
1504 #define tri-rt-mask_height 13
1505 static unsigned char tri-rt-mask_bits[] = {
1506 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1507 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1508 0x08, 0x00};
1510 image create bitmap tri-dn -background black -foreground blue -data {
1511 #define tri-dn_width 13
1512 #define tri-dn_height 13
1513 static unsigned char tri-dn_bits[] = {
1514 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1515 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1516 0x00, 0x00};
1517 } -maskdata {
1518 #define tri-dn-mask_width 13
1519 #define tri-dn-mask_height 13
1520 static unsigned char tri-dn-mask_bits[] = {
1521 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1522 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1523 0x00, 0x00};
1526 image create bitmap reficon-T -background black -foreground yellow -data {
1527 #define tagicon_width 13
1528 #define tagicon_height 9
1529 static unsigned char tagicon_bits[] = {
1530 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1531 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1532 } -maskdata {
1533 #define tagicon-mask_width 13
1534 #define tagicon-mask_height 9
1535 static unsigned char tagicon-mask_bits[] = {
1536 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1537 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1539 set rectdata {
1540 #define headicon_width 13
1541 #define headicon_height 9
1542 static unsigned char headicon_bits[] = {
1543 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1544 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1546 set rectmask {
1547 #define headicon-mask_width 13
1548 #define headicon-mask_height 9
1549 static unsigned char headicon-mask_bits[] = {
1550 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1551 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1553 image create bitmap reficon-H -background black -foreground green \
1554 -data $rectdata -maskdata $rectmask
1555 image create bitmap reficon-o -background black -foreground "#ddddff" \
1556 -data $rectdata -maskdata $rectmask
1558 proc init_flist {first} {
1559 global cflist cflist_top selectedline difffilestart
1561 $cflist conf -state normal
1562 $cflist delete 0.0 end
1563 if {$first ne {}} {
1564 $cflist insert end $first
1565 set cflist_top 1
1566 $cflist tag add highlight 1.0 "1.0 lineend"
1567 } else {
1568 catch {unset cflist_top}
1570 $cflist conf -state disabled
1571 set difffilestart {}
1574 proc highlight_tag {f} {
1575 global highlight_paths
1577 foreach p $highlight_paths {
1578 if {[string match $p $f]} {
1579 return "bold"
1582 return {}
1585 proc highlight_filelist {} {
1586 global cmitmode cflist
1588 $cflist conf -state normal
1589 if {$cmitmode ne "tree"} {
1590 set end [lindex [split [$cflist index end] .] 0]
1591 for {set l 2} {$l < $end} {incr l} {
1592 set line [$cflist get $l.0 "$l.0 lineend"]
1593 if {[highlight_tag $line] ne {}} {
1594 $cflist tag add bold $l.0 "$l.0 lineend"
1597 } else {
1598 highlight_tree 2 {}
1600 $cflist conf -state disabled
1603 proc unhighlight_filelist {} {
1604 global cflist
1606 $cflist conf -state normal
1607 $cflist tag remove bold 1.0 end
1608 $cflist conf -state disabled
1611 proc add_flist {fl} {
1612 global cflist
1614 $cflist conf -state normal
1615 foreach f $fl {
1616 $cflist insert end "\n"
1617 $cflist insert end $f [highlight_tag $f]
1619 $cflist conf -state disabled
1622 proc sel_flist {w x y} {
1623 global ctext difffilestart cflist cflist_top cmitmode
1625 if {$cmitmode eq "tree"} return
1626 if {![info exists cflist_top]} return
1627 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1628 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1629 $cflist tag add highlight $l.0 "$l.0 lineend"
1630 set cflist_top $l
1631 if {$l == 1} {
1632 $ctext yview 1.0
1633 } else {
1634 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1638 proc pop_flist_menu {w X Y x y} {
1639 global ctext cflist cmitmode flist_menu flist_menu_file
1640 global treediffs diffids
1642 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1643 if {$l <= 1} return
1644 if {$cmitmode eq "tree"} {
1645 set e [linetoelt $l]
1646 if {[string index $e end] eq "/"} return
1647 } else {
1648 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1650 set flist_menu_file $e
1651 tk_popup $flist_menu $X $Y
1654 proc flist_hl {only} {
1655 global flist_menu_file highlight_files
1657 set x [shellquote $flist_menu_file]
1658 if {$only || $highlight_files eq {}} {
1659 set highlight_files $x
1660 } else {
1661 append highlight_files " " $x
1665 # Functions for adding and removing shell-type quoting
1667 proc shellquote {str} {
1668 if {![string match "*\['\"\\ \t]*" $str]} {
1669 return $str
1671 if {![string match "*\['\"\\]*" $str]} {
1672 return "\"$str\""
1674 if {![string match "*'*" $str]} {
1675 return "'$str'"
1677 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1680 proc shellarglist {l} {
1681 set str {}
1682 foreach a $l {
1683 if {$str ne {}} {
1684 append str " "
1686 append str [shellquote $a]
1688 return $str
1691 proc shelldequote {str} {
1692 set ret {}
1693 set used -1
1694 while {1} {
1695 incr used
1696 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1697 append ret [string range $str $used end]
1698 set used [string length $str]
1699 break
1701 set first [lindex $first 0]
1702 set ch [string index $str $first]
1703 if {$first > $used} {
1704 append ret [string range $str $used [expr {$first - 1}]]
1705 set used $first
1707 if {$ch eq " " || $ch eq "\t"} break
1708 incr used
1709 if {$ch eq "'"} {
1710 set first [string first "'" $str $used]
1711 if {$first < 0} {
1712 error "unmatched single-quote"
1714 append ret [string range $str $used [expr {$first - 1}]]
1715 set used $first
1716 continue
1718 if {$ch eq "\\"} {
1719 if {$used >= [string length $str]} {
1720 error "trailing backslash"
1722 append ret [string index $str $used]
1723 continue
1725 # here ch == "\""
1726 while {1} {
1727 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1728 error "unmatched double-quote"
1730 set first [lindex $first 0]
1731 set ch [string index $str $first]
1732 if {$first > $used} {
1733 append ret [string range $str $used [expr {$first - 1}]]
1734 set used $first
1736 if {$ch eq "\""} break
1737 incr used
1738 append ret [string index $str $used]
1739 incr used
1742 return [list $used $ret]
1745 proc shellsplit {str} {
1746 set l {}
1747 while {1} {
1748 set str [string trimleft $str]
1749 if {$str eq {}} break
1750 set dq [shelldequote $str]
1751 set n [lindex $dq 0]
1752 set word [lindex $dq 1]
1753 set str [string range $str $n end]
1754 lappend l $word
1756 return $l
1759 # Code to implement multiple views
1761 proc newview {ishighlight} {
1762 global nextviewnum newviewname newviewperm uifont newishighlight
1763 global newviewargs revtreeargs
1765 set newishighlight $ishighlight
1766 set top .gitkview
1767 if {[winfo exists $top]} {
1768 raise $top
1769 return
1771 set newviewname($nextviewnum) "View $nextviewnum"
1772 set newviewperm($nextviewnum) 0
1773 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1774 vieweditor $top $nextviewnum "Gitk view definition"
1777 proc editview {} {
1778 global curview
1779 global viewname viewperm newviewname newviewperm
1780 global viewargs newviewargs
1782 set top .gitkvedit-$curview
1783 if {[winfo exists $top]} {
1784 raise $top
1785 return
1787 set newviewname($curview) $viewname($curview)
1788 set newviewperm($curview) $viewperm($curview)
1789 set newviewargs($curview) [shellarglist $viewargs($curview)]
1790 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1793 proc vieweditor {top n title} {
1794 global newviewname newviewperm viewfiles
1795 global uifont
1797 toplevel $top
1798 wm title $top $title
1799 label $top.nl -text "Name" -font $uifont
1800 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1801 grid $top.nl $top.name -sticky w -pady 5
1802 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1803 -font $uifont
1804 grid $top.perm - -pady 5 -sticky w
1805 message $top.al -aspect 1000 -font $uifont \
1806 -text "Commits to include (arguments to git rev-list):"
1807 grid $top.al - -sticky w -pady 5
1808 entry $top.args -width 50 -textvariable newviewargs($n) \
1809 -background white -font $uifont
1810 grid $top.args - -sticky ew -padx 5
1811 message $top.l -aspect 1000 -font $uifont \
1812 -text "Enter files and directories to include, one per line:"
1813 grid $top.l - -sticky w
1814 text $top.t -width 40 -height 10 -background white -font $uifont
1815 if {[info exists viewfiles($n)]} {
1816 foreach f $viewfiles($n) {
1817 $top.t insert end $f
1818 $top.t insert end "\n"
1820 $top.t delete {end - 1c} end
1821 $top.t mark set insert 0.0
1823 grid $top.t - -sticky ew -padx 5
1824 frame $top.buts
1825 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1826 -font $uifont
1827 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1828 -font $uifont
1829 grid $top.buts.ok $top.buts.can
1830 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1831 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1832 grid $top.buts - -pady 10 -sticky ew
1833 focus $top.t
1836 proc doviewmenu {m first cmd op argv} {
1837 set nmenu [$m index end]
1838 for {set i $first} {$i <= $nmenu} {incr i} {
1839 if {[$m entrycget $i -command] eq $cmd} {
1840 eval $m $op $i $argv
1841 break
1846 proc allviewmenus {n op args} {
1847 global viewhlmenu
1849 doviewmenu .bar.view 5 [list showview $n] $op $args
1850 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1853 proc newviewok {top n} {
1854 global nextviewnum newviewperm newviewname newishighlight
1855 global viewname viewfiles viewperm selectedview curview
1856 global viewargs newviewargs viewhlmenu
1858 if {[catch {
1859 set newargs [shellsplit $newviewargs($n)]
1860 } err]} {
1861 error_popup "Error in commit selection arguments: $err"
1862 wm raise $top
1863 focus $top
1864 return
1866 set files {}
1867 foreach f [split [$top.t get 0.0 end] "\n"] {
1868 set ft [string trim $f]
1869 if {$ft ne {}} {
1870 lappend files $ft
1873 if {![info exists viewfiles($n)]} {
1874 # creating a new view
1875 incr nextviewnum
1876 set viewname($n) $newviewname($n)
1877 set viewperm($n) $newviewperm($n)
1878 set viewfiles($n) $files
1879 set viewargs($n) $newargs
1880 addviewmenu $n
1881 if {!$newishighlight} {
1882 run showview $n
1883 } else {
1884 run addvhighlight $n
1886 } else {
1887 # editing an existing view
1888 set viewperm($n) $newviewperm($n)
1889 if {$newviewname($n) ne $viewname($n)} {
1890 set viewname($n) $newviewname($n)
1891 doviewmenu .bar.view 5 [list showview $n] \
1892 entryconf [list -label $viewname($n)]
1893 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1894 entryconf [list -label $viewname($n) -value $viewname($n)]
1896 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1897 set viewfiles($n) $files
1898 set viewargs($n) $newargs
1899 if {$curview == $n} {
1900 run updatecommits
1904 catch {destroy $top}
1907 proc delview {} {
1908 global curview viewdata viewperm hlview selectedhlview
1910 if {$curview == 0} return
1911 if {[info exists hlview] && $hlview == $curview} {
1912 set selectedhlview None
1913 unset hlview
1915 allviewmenus $curview delete
1916 set viewdata($curview) {}
1917 set viewperm($curview) 0
1918 showview 0
1921 proc addviewmenu {n} {
1922 global viewname viewhlmenu
1924 .bar.view add radiobutton -label $viewname($n) \
1925 -command [list showview $n] -variable selectedview -value $n
1926 $viewhlmenu add radiobutton -label $viewname($n) \
1927 -command [list addvhighlight $n] -variable selectedhlview
1930 proc flatten {var} {
1931 global $var
1933 set ret {}
1934 foreach i [array names $var] {
1935 lappend ret $i [set $var\($i\)]
1937 return $ret
1940 proc unflatten {var l} {
1941 global $var
1943 catch {unset $var}
1944 foreach {i v} $l {
1945 set $var\($i\) $v
1949 proc showview {n} {
1950 global curview viewdata viewfiles
1951 global displayorder parentlist rowidlist rowisopt rowfinal
1952 global colormap rowtextx commitrow nextcolor canvxmax
1953 global numcommits commitlisted
1954 global selectedline currentid canv canvy0
1955 global treediffs
1956 global pending_select phase
1957 global commitidx
1958 global commfd
1959 global selectedview selectfirst
1960 global vparentlist vdisporder vcmitlisted
1961 global hlview selectedhlview commitinterest
1963 if {$n == $curview} return
1964 set selid {}
1965 if {[info exists selectedline]} {
1966 set selid $currentid
1967 set y [yc $selectedline]
1968 set ymax [lindex [$canv cget -scrollregion] 3]
1969 set span [$canv yview]
1970 set ytop [expr {[lindex $span 0] * $ymax}]
1971 set ybot [expr {[lindex $span 1] * $ymax}]
1972 if {$ytop < $y && $y < $ybot} {
1973 set yscreen [expr {$y - $ytop}]
1974 } else {
1975 set yscreen [expr {($ybot - $ytop) / 2}]
1977 } elseif {[info exists pending_select]} {
1978 set selid $pending_select
1979 unset pending_select
1981 unselectline
1982 normalline
1983 if {$curview >= 0} {
1984 set vparentlist($curview) $parentlist
1985 set vdisporder($curview) $displayorder
1986 set vcmitlisted($curview) $commitlisted
1987 if {$phase ne {} ||
1988 ![info exists viewdata($curview)] ||
1989 [lindex $viewdata($curview) 0] ne {}} {
1990 set viewdata($curview) \
1991 [list $phase $rowidlist $rowisopt $rowfinal]
1994 catch {unset treediffs}
1995 clear_display
1996 if {[info exists hlview] && $hlview == $n} {
1997 unset hlview
1998 set selectedhlview None
2000 catch {unset commitinterest}
2002 set curview $n
2003 set selectedview $n
2004 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2005 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2007 run refill_reflist
2008 if {![info exists viewdata($n)]} {
2009 if {$selid ne {}} {
2010 set pending_select $selid
2012 getcommits
2013 return
2016 set v $viewdata($n)
2017 set phase [lindex $v 0]
2018 set displayorder $vdisporder($n)
2019 set parentlist $vparentlist($n)
2020 set commitlisted $vcmitlisted($n)
2021 set rowidlist [lindex $v 1]
2022 set rowisopt [lindex $v 2]
2023 set rowfinal [lindex $v 3]
2024 set numcommits $commitidx($n)
2026 catch {unset colormap}
2027 catch {unset rowtextx}
2028 set nextcolor 0
2029 set canvxmax [$canv cget -width]
2030 set curview $n
2031 set row 0
2032 setcanvscroll
2033 set yf 0
2034 set row {}
2035 set selectfirst 0
2036 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2037 set row $commitrow($n,$selid)
2038 # try to get the selected row in the same position on the screen
2039 set ymax [lindex [$canv cget -scrollregion] 3]
2040 set ytop [expr {[yc $row] - $yscreen}]
2041 if {$ytop < 0} {
2042 set ytop 0
2044 set yf [expr {$ytop * 1.0 / $ymax}]
2046 allcanvs yview moveto $yf
2047 drawvisible
2048 if {$row ne {}} {
2049 selectline $row 0
2050 } elseif {$selid ne {}} {
2051 set pending_select $selid
2052 } else {
2053 set row [first_real_row]
2054 if {$row < $numcommits} {
2055 selectline $row 0
2056 } else {
2057 set selectfirst 1
2060 if {$phase ne {}} {
2061 if {$phase eq "getcommits"} {
2062 show_status "Reading commits..."
2064 run chewcommits $n
2065 } elseif {$numcommits == 0} {
2066 show_status "No commits selected"
2070 # Stuff relating to the highlighting facility
2072 proc ishighlighted {row} {
2073 global vhighlights fhighlights nhighlights rhighlights
2075 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2076 return $nhighlights($row)
2078 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2079 return $vhighlights($row)
2081 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2082 return $fhighlights($row)
2084 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2085 return $rhighlights($row)
2087 return 0
2090 proc bolden {row font} {
2091 global canv linehtag selectedline boldrows
2093 lappend boldrows $row
2094 $canv itemconf $linehtag($row) -font $font
2095 if {[info exists selectedline] && $row == $selectedline} {
2096 $canv delete secsel
2097 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2098 -outline {{}} -tags secsel \
2099 -fill [$canv cget -selectbackground]]
2100 $canv lower $t
2104 proc bolden_name {row font} {
2105 global canv2 linentag selectedline boldnamerows
2107 lappend boldnamerows $row
2108 $canv2 itemconf $linentag($row) -font $font
2109 if {[info exists selectedline] && $row == $selectedline} {
2110 $canv2 delete secsel
2111 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2112 -outline {{}} -tags secsel \
2113 -fill [$canv2 cget -selectbackground]]
2114 $canv2 lower $t
2118 proc unbolden {} {
2119 global mainfont boldrows
2121 set stillbold {}
2122 foreach row $boldrows {
2123 if {![ishighlighted $row]} {
2124 bolden $row $mainfont
2125 } else {
2126 lappend stillbold $row
2129 set boldrows $stillbold
2132 proc addvhighlight {n} {
2133 global hlview curview viewdata vhl_done vhighlights commitidx
2135 if {[info exists hlview]} {
2136 delvhighlight
2138 set hlview $n
2139 if {$n != $curview && ![info exists viewdata($n)]} {
2140 set viewdata($n) [list getcommits {{}} 0 0 0]
2141 set vparentlist($n) {}
2142 set vdisporder($n) {}
2143 set vcmitlisted($n) {}
2144 start_rev_list $n
2146 set vhl_done $commitidx($hlview)
2147 if {$vhl_done > 0} {
2148 drawvisible
2152 proc delvhighlight {} {
2153 global hlview vhighlights
2155 if {![info exists hlview]} return
2156 unset hlview
2157 catch {unset vhighlights}
2158 unbolden
2161 proc vhighlightmore {} {
2162 global hlview vhl_done commitidx vhighlights
2163 global displayorder vdisporder curview mainfont
2165 set font [concat $mainfont bold]
2166 set max $commitidx($hlview)
2167 if {$hlview == $curview} {
2168 set disp $displayorder
2169 } else {
2170 set disp $vdisporder($hlview)
2172 set vr [visiblerows]
2173 set r0 [lindex $vr 0]
2174 set r1 [lindex $vr 1]
2175 for {set i $vhl_done} {$i < $max} {incr i} {
2176 set id [lindex $disp $i]
2177 if {[info exists commitrow($curview,$id)]} {
2178 set row $commitrow($curview,$id)
2179 if {$r0 <= $row && $row <= $r1} {
2180 if {![highlighted $row]} {
2181 bolden $row $font
2183 set vhighlights($row) 1
2187 set vhl_done $max
2190 proc askvhighlight {row id} {
2191 global hlview vhighlights commitrow iddrawn mainfont
2193 if {[info exists commitrow($hlview,$id)]} {
2194 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2195 bolden $row [concat $mainfont bold]
2197 set vhighlights($row) 1
2198 } else {
2199 set vhighlights($row) 0
2203 proc hfiles_change {name ix op} {
2204 global highlight_files filehighlight fhighlights fh_serial
2205 global mainfont highlight_paths
2207 if {[info exists filehighlight]} {
2208 # delete previous highlights
2209 catch {close $filehighlight}
2210 unset filehighlight
2211 catch {unset fhighlights}
2212 unbolden
2213 unhighlight_filelist
2215 set highlight_paths {}
2216 after cancel do_file_hl $fh_serial
2217 incr fh_serial
2218 if {$highlight_files ne {}} {
2219 after 300 do_file_hl $fh_serial
2223 proc makepatterns {l} {
2224 set ret {}
2225 foreach e $l {
2226 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2227 if {[string index $ee end] eq "/"} {
2228 lappend ret "$ee*"
2229 } else {
2230 lappend ret $ee
2231 lappend ret "$ee/*"
2234 return $ret
2237 proc do_file_hl {serial} {
2238 global highlight_files filehighlight highlight_paths gdttype fhl_list
2240 if {$gdttype eq "touching paths:"} {
2241 if {[catch {set paths [shellsplit $highlight_files]}]} return
2242 set highlight_paths [makepatterns $paths]
2243 highlight_filelist
2244 set gdtargs [concat -- $paths]
2245 } else {
2246 set gdtargs [list "-S$highlight_files"]
2248 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2249 set filehighlight [open $cmd r+]
2250 fconfigure $filehighlight -blocking 0
2251 filerun $filehighlight readfhighlight
2252 set fhl_list {}
2253 drawvisible
2254 flushhighlights
2257 proc flushhighlights {} {
2258 global filehighlight fhl_list
2260 if {[info exists filehighlight]} {
2261 lappend fhl_list {}
2262 puts $filehighlight ""
2263 flush $filehighlight
2267 proc askfilehighlight {row id} {
2268 global filehighlight fhighlights fhl_list
2270 lappend fhl_list $id
2271 set fhighlights($row) -1
2272 puts $filehighlight $id
2275 proc readfhighlight {} {
2276 global filehighlight fhighlights commitrow curview mainfont iddrawn
2277 global fhl_list
2279 if {![info exists filehighlight]} {
2280 return 0
2282 set nr 0
2283 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2284 set line [string trim $line]
2285 set i [lsearch -exact $fhl_list $line]
2286 if {$i < 0} continue
2287 for {set j 0} {$j < $i} {incr j} {
2288 set id [lindex $fhl_list $j]
2289 if {[info exists commitrow($curview,$id)]} {
2290 set fhighlights($commitrow($curview,$id)) 0
2293 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2294 if {$line eq {}} continue
2295 if {![info exists commitrow($curview,$line)]} continue
2296 set row $commitrow($curview,$line)
2297 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2298 bolden $row [concat $mainfont bold]
2300 set fhighlights($row) 1
2302 if {[eof $filehighlight]} {
2303 # strange...
2304 puts "oops, git diff-tree died"
2305 catch {close $filehighlight}
2306 unset filehighlight
2307 return 0
2309 next_hlcont
2310 return 1
2313 proc find_change {name ix op} {
2314 global nhighlights mainfont boldnamerows
2315 global findstring findpattern findtype
2317 # delete previous highlights, if any
2318 foreach row $boldnamerows {
2319 bolden_name $row $mainfont
2321 set boldnamerows {}
2322 catch {unset nhighlights}
2323 unbolden
2324 unmarkmatches
2325 if {$findtype ne "Regexp"} {
2326 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2327 $findstring]
2328 set findpattern "*$e*"
2330 drawvisible
2333 proc doesmatch {f} {
2334 global findtype findstring findpattern
2336 if {$findtype eq "Regexp"} {
2337 return [regexp $findstring $f]
2338 } elseif {$findtype eq "IgnCase"} {
2339 return [string match -nocase $findpattern $f]
2340 } else {
2341 return [string match $findpattern $f]
2345 proc askfindhighlight {row id} {
2346 global nhighlights commitinfo iddrawn mainfont
2347 global findloc
2348 global markingmatches
2350 if {![info exists commitinfo($id)]} {
2351 getcommit $id
2353 set info $commitinfo($id)
2354 set isbold 0
2355 set fldtypes {Headline Author Date Committer CDate Comments}
2356 foreach f $info ty $fldtypes {
2357 if {($findloc eq "All fields" || $findloc eq $ty) &&
2358 [doesmatch $f]} {
2359 if {$ty eq "Author"} {
2360 set isbold 2
2361 break
2363 set isbold 1
2366 if {$isbold && [info exists iddrawn($id)]} {
2367 set f [concat $mainfont bold]
2368 if {![ishighlighted $row]} {
2369 bolden $row $f
2370 if {$isbold > 1} {
2371 bolden_name $row $f
2374 if {$markingmatches} {
2375 markrowmatches $row $id
2378 set nhighlights($row) $isbold
2381 proc markrowmatches {row id} {
2382 global canv canv2 linehtag linentag commitinfo findloc
2384 set headline [lindex $commitinfo($id) 0]
2385 set author [lindex $commitinfo($id) 1]
2386 $canv delete match$row
2387 $canv2 delete match$row
2388 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2389 set m [findmatches $headline]
2390 if {$m ne {}} {
2391 markmatches $canv $row $headline $linehtag($row) $m \
2392 [$canv itemcget $linehtag($row) -font] $row
2395 if {$findloc eq "All fields" || $findloc eq "Author"} {
2396 set m [findmatches $author]
2397 if {$m ne {}} {
2398 markmatches $canv2 $row $author $linentag($row) $m \
2399 [$canv2 itemcget $linentag($row) -font] $row
2404 proc vrel_change {name ix op} {
2405 global highlight_related
2407 rhighlight_none
2408 if {$highlight_related ne "None"} {
2409 run drawvisible
2413 # prepare for testing whether commits are descendents or ancestors of a
2414 proc rhighlight_sel {a} {
2415 global descendent desc_todo ancestor anc_todo
2416 global highlight_related rhighlights
2418 catch {unset descendent}
2419 set desc_todo [list $a]
2420 catch {unset ancestor}
2421 set anc_todo [list $a]
2422 if {$highlight_related ne "None"} {
2423 rhighlight_none
2424 run drawvisible
2428 proc rhighlight_none {} {
2429 global rhighlights
2431 catch {unset rhighlights}
2432 unbolden
2435 proc is_descendent {a} {
2436 global curview children commitrow descendent desc_todo
2438 set v $curview
2439 set la $commitrow($v,$a)
2440 set todo $desc_todo
2441 set leftover {}
2442 set done 0
2443 for {set i 0} {$i < [llength $todo]} {incr i} {
2444 set do [lindex $todo $i]
2445 if {$commitrow($v,$do) < $la} {
2446 lappend leftover $do
2447 continue
2449 foreach nk $children($v,$do) {
2450 if {![info exists descendent($nk)]} {
2451 set descendent($nk) 1
2452 lappend todo $nk
2453 if {$nk eq $a} {
2454 set done 1
2458 if {$done} {
2459 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2460 return
2463 set descendent($a) 0
2464 set desc_todo $leftover
2467 proc is_ancestor {a} {
2468 global curview parentlist commitrow ancestor anc_todo
2470 set v $curview
2471 set la $commitrow($v,$a)
2472 set todo $anc_todo
2473 set leftover {}
2474 set done 0
2475 for {set i 0} {$i < [llength $todo]} {incr i} {
2476 set do [lindex $todo $i]
2477 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2478 lappend leftover $do
2479 continue
2481 foreach np [lindex $parentlist $commitrow($v,$do)] {
2482 if {![info exists ancestor($np)]} {
2483 set ancestor($np) 1
2484 lappend todo $np
2485 if {$np eq $a} {
2486 set done 1
2490 if {$done} {
2491 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2492 return
2495 set ancestor($a) 0
2496 set anc_todo $leftover
2499 proc askrelhighlight {row id} {
2500 global descendent highlight_related iddrawn mainfont rhighlights
2501 global selectedline ancestor
2503 if {![info exists selectedline]} return
2504 set isbold 0
2505 if {$highlight_related eq "Descendent" ||
2506 $highlight_related eq "Not descendent"} {
2507 if {![info exists descendent($id)]} {
2508 is_descendent $id
2510 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2511 set isbold 1
2513 } elseif {$highlight_related eq "Ancestor" ||
2514 $highlight_related eq "Not ancestor"} {
2515 if {![info exists ancestor($id)]} {
2516 is_ancestor $id
2518 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2519 set isbold 1
2522 if {[info exists iddrawn($id)]} {
2523 if {$isbold && ![ishighlighted $row]} {
2524 bolden $row [concat $mainfont bold]
2527 set rhighlights($row) $isbold
2530 proc next_hlcont {} {
2531 global fhl_row fhl_dirn displayorder numcommits
2532 global vhighlights fhighlights nhighlights rhighlights
2533 global hlview filehighlight findstring highlight_related
2535 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2536 set row $fhl_row
2537 while {1} {
2538 if {$row < 0 || $row >= $numcommits} {
2539 bell
2540 set fhl_dirn 0
2541 return
2543 set id [lindex $displayorder $row]
2544 if {[info exists hlview]} {
2545 if {![info exists vhighlights($row)]} {
2546 askvhighlight $row $id
2548 if {$vhighlights($row) > 0} break
2550 if {$findstring ne {}} {
2551 if {![info exists nhighlights($row)]} {
2552 askfindhighlight $row $id
2554 if {$nhighlights($row) > 0} break
2556 if {$highlight_related ne "None"} {
2557 if {![info exists rhighlights($row)]} {
2558 askrelhighlight $row $id
2560 if {$rhighlights($row) > 0} break
2562 if {[info exists filehighlight]} {
2563 if {![info exists fhighlights($row)]} {
2564 # ask for a few more while we're at it...
2565 set r $row
2566 for {set n 0} {$n < 100} {incr n} {
2567 if {![info exists fhighlights($r)]} {
2568 askfilehighlight $r [lindex $displayorder $r]
2570 incr r $fhl_dirn
2571 if {$r < 0 || $r >= $numcommits} break
2573 flushhighlights
2575 if {$fhighlights($row) < 0} {
2576 set fhl_row $row
2577 return
2579 if {$fhighlights($row) > 0} break
2581 incr row $fhl_dirn
2583 set fhl_dirn 0
2584 selectline $row 1
2587 proc next_highlight {dirn} {
2588 global selectedline fhl_row fhl_dirn
2589 global hlview filehighlight findstring highlight_related
2591 if {![info exists selectedline]} return
2592 if {!([info exists hlview] || $findstring ne {} ||
2593 $highlight_related ne "None" || [info exists filehighlight])} return
2594 set fhl_row [expr {$selectedline + $dirn}]
2595 set fhl_dirn $dirn
2596 next_hlcont
2599 proc cancel_next_highlight {} {
2600 global fhl_dirn
2602 set fhl_dirn 0
2605 # Graph layout functions
2607 proc shortids {ids} {
2608 set res {}
2609 foreach id $ids {
2610 if {[llength $id] > 1} {
2611 lappend res [shortids $id]
2612 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2613 lappend res [string range $id 0 7]
2614 } else {
2615 lappend res $id
2618 return $res
2621 proc ntimes {n o} {
2622 set ret {}
2623 set o [list $o]
2624 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2625 if {($n & $mask) != 0} {
2626 set ret [concat $ret $o]
2628 set o [concat $o $o]
2630 return $ret
2633 # Work out where id should go in idlist so that order-token
2634 # values increase from left to right
2635 proc idcol {idlist id {i 0}} {
2636 global ordertok curview
2638 set t $ordertok($curview,$id)
2639 if {$i >= [llength $idlist] ||
2640 $t < $ordertok($curview,[lindex $idlist $i])} {
2641 if {$i > [llength $idlist]} {
2642 set i [llength $idlist]
2644 while {[incr i -1] >= 0 &&
2645 $t < $ordertok($curview,[lindex $idlist $i])} {}
2646 incr i
2647 } else {
2648 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2649 while {[incr i] < [llength $idlist] &&
2650 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2653 return $i
2656 proc initlayout {} {
2657 global rowidlist rowisopt rowfinal displayorder commitlisted
2658 global numcommits canvxmax canv
2659 global nextcolor
2660 global parentlist
2661 global colormap rowtextx
2662 global selectfirst
2664 set numcommits 0
2665 set displayorder {}
2666 set commitlisted {}
2667 set parentlist {}
2668 set nextcolor 0
2669 set rowidlist {}
2670 set rowisopt {}
2671 set rowfinal {}
2672 set canvxmax [$canv cget -width]
2673 catch {unset colormap}
2674 catch {unset rowtextx}
2675 set selectfirst 1
2678 proc setcanvscroll {} {
2679 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2681 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2682 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2683 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2684 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2687 proc visiblerows {} {
2688 global canv numcommits linespc
2690 set ymax [lindex [$canv cget -scrollregion] 3]
2691 if {$ymax eq {} || $ymax == 0} return
2692 set f [$canv yview]
2693 set y0 [expr {int([lindex $f 0] * $ymax)}]
2694 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2695 if {$r0 < 0} {
2696 set r0 0
2698 set y1 [expr {int([lindex $f 1] * $ymax)}]
2699 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2700 if {$r1 >= $numcommits} {
2701 set r1 [expr {$numcommits - 1}]
2703 return [list $r0 $r1]
2706 proc layoutmore {} {
2707 global commitidx viewcomplete numcommits
2708 global uparrowlen downarrowlen mingaplen curview
2710 set show $commitidx($curview)
2711 if {$show > $numcommits} {
2712 showstuff $show $viewcomplete($curview)
2716 proc showstuff {canshow last} {
2717 global numcommits commitrow pending_select selectedline curview
2718 global lookingforhead mainheadid displayorder selectfirst
2719 global lastscrollset commitinterest
2721 if {$numcommits == 0} {
2722 global phase
2723 set phase "incrdraw"
2724 allcanvs delete all
2726 for {set l $numcommits} {$l < $canshow} {incr l} {
2727 set id [lindex $displayorder $l]
2728 if {[info exists commitinterest($id)]} {
2729 foreach script $commitinterest($id) {
2730 eval [string map [list "%I" $id] $script]
2732 unset commitinterest($id)
2735 set r0 $numcommits
2736 set prev $numcommits
2737 set numcommits $canshow
2738 set t [clock clicks -milliseconds]
2739 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2740 set lastscrollset $t
2741 setcanvscroll
2743 set rows [visiblerows]
2744 set r1 [lindex $rows 1]
2745 if {$r1 >= $canshow} {
2746 set r1 [expr {$canshow - 1}]
2748 if {$r0 <= $r1} {
2749 drawcommits $r0 $r1
2751 if {[info exists pending_select] &&
2752 [info exists commitrow($curview,$pending_select)] &&
2753 $commitrow($curview,$pending_select) < $numcommits} {
2754 selectline $commitrow($curview,$pending_select) 1
2756 if {$selectfirst} {
2757 if {[info exists selectedline] || [info exists pending_select]} {
2758 set selectfirst 0
2759 } else {
2760 set l [first_real_row]
2761 selectline $l 1
2762 set selectfirst 0
2765 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2766 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2767 set lookingforhead 0
2768 dodiffindex
2772 proc doshowlocalchanges {} {
2773 global lookingforhead curview mainheadid phase commitrow
2775 if {[info exists commitrow($curview,$mainheadid)] &&
2776 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2777 dodiffindex
2778 } elseif {$phase ne {}} {
2779 set lookingforhead 1
2783 proc dohidelocalchanges {} {
2784 global lookingforhead localfrow localirow lserial
2786 set lookingforhead 0
2787 if {$localfrow >= 0} {
2788 removerow $localfrow
2789 set localfrow -1
2790 if {$localirow > 0} {
2791 incr localirow -1
2794 if {$localirow >= 0} {
2795 removerow $localirow
2796 set localirow -1
2798 incr lserial
2801 # spawn off a process to do git diff-index --cached HEAD
2802 proc dodiffindex {} {
2803 global localirow localfrow lserial
2805 incr lserial
2806 set localfrow -1
2807 set localirow -1
2808 set fd [open "|git diff-index --cached HEAD" r]
2809 fconfigure $fd -blocking 0
2810 filerun $fd [list readdiffindex $fd $lserial]
2813 proc readdiffindex {fd serial} {
2814 global localirow commitrow mainheadid nullid2 curview
2815 global commitinfo commitdata lserial
2817 set isdiff 1
2818 if {[gets $fd line] < 0} {
2819 if {![eof $fd]} {
2820 return 1
2822 set isdiff 0
2824 # we only need to see one line and we don't really care what it says...
2825 close $fd
2827 # now see if there are any local changes not checked in to the index
2828 if {$serial == $lserial} {
2829 set fd [open "|git diff-files" r]
2830 fconfigure $fd -blocking 0
2831 filerun $fd [list readdifffiles $fd $serial]
2834 if {$isdiff && $serial == $lserial && $localirow == -1} {
2835 # add the line for the changes in the index to the graph
2836 set localirow $commitrow($curview,$mainheadid)
2837 set hl "Local changes checked in to index but not committed"
2838 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2839 set commitdata($nullid2) "\n $hl\n"
2840 insertrow $localirow $nullid2
2842 return 0
2845 proc readdifffiles {fd serial} {
2846 global localirow localfrow commitrow mainheadid nullid curview
2847 global commitinfo commitdata lserial
2849 set isdiff 1
2850 if {[gets $fd line] < 0} {
2851 if {![eof $fd]} {
2852 return 1
2854 set isdiff 0
2856 # we only need to see one line and we don't really care what it says...
2857 close $fd
2859 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2860 # add the line for the local diff to the graph
2861 if {$localirow >= 0} {
2862 set localfrow $localirow
2863 incr localirow
2864 } else {
2865 set localfrow $commitrow($curview,$mainheadid)
2867 set hl "Local uncommitted changes, not checked in to index"
2868 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2869 set commitdata($nullid) "\n $hl\n"
2870 insertrow $localfrow $nullid
2872 return 0
2875 proc nextuse {id row} {
2876 global commitrow curview children
2878 if {[info exists children($curview,$id)]} {
2879 foreach kid $children($curview,$id) {
2880 if {![info exists commitrow($curview,$kid)]} {
2881 return -1
2883 if {$commitrow($curview,$kid) > $row} {
2884 return $commitrow($curview,$kid)
2888 if {[info exists commitrow($curview,$id)]} {
2889 return $commitrow($curview,$id)
2891 return -1
2894 proc prevuse {id row} {
2895 global commitrow curview children
2897 set ret -1
2898 if {[info exists children($curview,$id)]} {
2899 foreach kid $children($curview,$id) {
2900 if {![info exists commitrow($curview,$kid)]} break
2901 if {$commitrow($curview,$kid) < $row} {
2902 set ret $commitrow($curview,$kid)
2906 return $ret
2909 proc make_idlist {row} {
2910 global displayorder parentlist uparrowlen downarrowlen mingaplen
2911 global commitidx curview ordertok children commitrow
2913 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2914 if {$r < 0} {
2915 set r 0
2917 set ra [expr {$row - $downarrowlen}]
2918 if {$ra < 0} {
2919 set ra 0
2921 set rb [expr {$row + $uparrowlen}]
2922 if {$rb > $commitidx($curview)} {
2923 set rb $commitidx($curview)
2925 set ids {}
2926 for {} {$r < $ra} {incr r} {
2927 set nextid [lindex $displayorder [expr {$r + 1}]]
2928 foreach p [lindex $parentlist $r] {
2929 if {$p eq $nextid} continue
2930 set rn [nextuse $p $r]
2931 if {$rn >= $row &&
2932 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2933 lappend ids [list $ordertok($curview,$p) $p]
2937 for {} {$r < $row} {incr r} {
2938 set nextid [lindex $displayorder [expr {$r + 1}]]
2939 foreach p [lindex $parentlist $r] {
2940 if {$p eq $nextid} continue
2941 set rn [nextuse $p $r]
2942 if {$rn < 0 || $rn >= $row} {
2943 lappend ids [list $ordertok($curview,$p) $p]
2947 set id [lindex $displayorder $row]
2948 lappend ids [list $ordertok($curview,$id) $id]
2949 while {$r < $rb} {
2950 foreach p [lindex $parentlist $r] {
2951 set firstkid [lindex $children($curview,$p) 0]
2952 if {$commitrow($curview,$firstkid) < $row} {
2953 lappend ids [list $ordertok($curview,$p) $p]
2956 incr r
2957 set id [lindex $displayorder $r]
2958 if {$id ne {}} {
2959 set firstkid [lindex $children($curview,$id) 0]
2960 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
2961 lappend ids [list $ordertok($curview,$id) $id]
2965 set idlist {}
2966 foreach idx [lsort -unique $ids] {
2967 lappend idlist [lindex $idx 1]
2969 return $idlist
2972 proc rowsequal {a b} {
2973 while {[set i [lsearch -exact $a {}]] >= 0} {
2974 set a [lreplace $a $i $i]
2976 while {[set i [lsearch -exact $b {}]] >= 0} {
2977 set b [lreplace $b $i $i]
2979 return [expr {$a eq $b}]
2982 proc makeupline {id row rend col} {
2983 global rowidlist uparrowlen downarrowlen mingaplen
2985 for {set r $rend} {1} {set r $rstart} {
2986 set rstart [prevuse $id $r]
2987 if {$rstart < 0} return
2988 if {$rstart < $row} break
2990 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
2991 set rstart [expr {$rend - $uparrowlen - 1}]
2993 for {set r $rstart} {[incr r] <= $row} {} {
2994 set idlist [lindex $rowidlist $r]
2995 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
2996 set col [idcol $idlist $id $col]
2997 lset rowidlist $r [linsert $idlist $col $id]
2998 changedrow $r
3003 proc layoutrows {row endrow} {
3004 global rowidlist rowisopt rowfinal displayorder
3005 global uparrowlen downarrowlen maxwidth mingaplen
3006 global children parentlist
3007 global commitidx viewcomplete curview commitrow
3009 set idlist {}
3010 if {$row > 0} {
3011 foreach id [lindex $rowidlist [expr {$row - 1}]] {
3012 if {$id ne {}} {
3013 lappend idlist $id
3017 for {} {$row < $endrow} {incr row} {
3018 set rm1 [expr {$row - 1}]
3019 if {$rm1 < 0 || [lindex $rowidlist $rm1] eq {}} {
3020 set idlist [make_idlist $row]
3021 set final 1
3022 } else {
3023 set id [lindex $displayorder $rm1]
3024 set final [lindex $rowfinal $rm1]
3025 set col [lsearch -exact $idlist $id]
3026 set idlist [lreplace $idlist $col $col]
3027 foreach p [lindex $parentlist $rm1] {
3028 if {[lsearch -exact $idlist $p] < 0} {
3029 set col [idcol $idlist $p $col]
3030 set idlist [linsert $idlist $col $p]
3031 # if not the first child, we have to insert a line going up
3032 if {$id ne [lindex $children($curview,$p) 0]} {
3033 makeupline $p $rm1 $row $col
3037 set id [lindex $displayorder $row]
3038 if {$row > $downarrowlen} {
3039 set termrow [expr {$row - $downarrowlen - 1}]
3040 foreach p [lindex $parentlist $termrow] {
3041 set i [lsearch -exact $idlist $p]
3042 if {$i < 0} continue
3043 set nr [nextuse $p $termrow]
3044 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3045 set idlist [lreplace $idlist $i $i]
3049 set col [lsearch -exact $idlist $id]
3050 if {$col < 0} {
3051 set col [idcol $idlist $id]
3052 set idlist [linsert $idlist $col $id]
3053 if {$children($curview,$id) ne {}} {
3054 makeupline $id $rm1 $row $col
3057 set r [expr {$row + $uparrowlen - 1}]
3058 if {$r < $commitidx($curview)} {
3059 set x $col
3060 foreach p [lindex $parentlist $r] {
3061 if {[lsearch -exact $idlist $p] >= 0} continue
3062 set fk [lindex $children($curview,$p) 0]
3063 if {$commitrow($curview,$fk) < $row} {
3064 set x [idcol $idlist $p $x]
3065 set idlist [linsert $idlist $x $p]
3068 if {[incr r] < $commitidx($curview)} {
3069 set p [lindex $displayorder $r]
3070 if {[lsearch -exact $idlist $p] < 0} {
3071 set fk [lindex $children($curview,$p) 0]
3072 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3073 set x [idcol $idlist $p $x]
3074 set idlist [linsert $idlist $x $p]
3080 if {$final && !$viewcomplete($curview) &&
3081 $row + $uparrowlen + $mingaplen + $downarrowlen
3082 >= $commitidx($curview)} {
3083 set final 0
3085 set l [llength $rowidlist]
3086 if {$row == $l} {
3087 lappend rowidlist $idlist
3088 lappend rowisopt 0
3089 lappend rowfinal $final
3090 } elseif {$row < $l} {
3091 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3092 lset rowidlist $row $idlist
3093 lset rowfinal $row $final
3094 changedrow $row
3096 } else {
3097 set pad [ntimes [expr {$row - $l}] {}]
3098 set rowidlist [concat $rowidlist $pad]
3099 lappend rowidlist $idlist
3100 set rowfinal [concat $rowfinal $pad]
3101 lappend rowfinal $final
3102 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3105 return $row
3108 proc changedrow {row} {
3109 global displayorder iddrawn rowisopt need_redisplay
3111 set l [llength $rowisopt]
3112 if {$row < $l} {
3113 lset rowisopt $row 0
3114 if {$row + 1 < $l} {
3115 lset rowisopt [expr {$row + 1}] 0
3116 if {$row + 2 < $l} {
3117 lset rowisopt [expr {$row + 2}] 0
3121 set id [lindex $displayorder $row]
3122 if {[info exists iddrawn($id)]} {
3123 set need_redisplay 1
3127 proc insert_pad {row col npad} {
3128 global rowidlist
3130 set pad [ntimes $npad {}]
3131 set idlist [lindex $rowidlist $row]
3132 set bef [lrange $idlist 0 [expr {$col - 1}]]
3133 set aft [lrange $idlist $col end]
3134 set i [lsearch -exact $aft {}]
3135 if {$i > 0} {
3136 set aft [lreplace $aft $i $i]
3138 lset rowidlist $row [concat $bef $pad $aft]
3139 changedrow $row
3142 proc optimize_rows {row col endrow} {
3143 global rowidlist rowisopt displayorder curview children
3145 if {$row < 1} {
3146 set row 1
3148 for {} {$row < $endrow} {incr row; set col 0} {
3149 if {[lindex $rowisopt $row]} continue
3150 set haspad 0
3151 set y0 [expr {$row - 1}]
3152 set ym [expr {$row - 2}]
3153 set idlist [lindex $rowidlist $row]
3154 set previdlist [lindex $rowidlist $y0]
3155 if {$idlist eq {} || $previdlist eq {}} continue
3156 if {$ym >= 0} {
3157 set pprevidlist [lindex $rowidlist $ym]
3158 if {$pprevidlist eq {}} continue
3159 } else {
3160 set pprevidlist {}
3162 set x0 -1
3163 set xm -1
3164 for {} {$col < [llength $idlist]} {incr col} {
3165 set id [lindex $idlist $col]
3166 if {[lindex $previdlist $col] eq $id} continue
3167 if {$id eq {}} {
3168 set haspad 1
3169 continue
3171 set x0 [lsearch -exact $previdlist $id]
3172 if {$x0 < 0} continue
3173 set z [expr {$x0 - $col}]
3174 set isarrow 0
3175 set z0 {}
3176 if {$ym >= 0} {
3177 set xm [lsearch -exact $pprevidlist $id]
3178 if {$xm >= 0} {
3179 set z0 [expr {$xm - $x0}]
3182 if {$z0 eq {}} {
3183 # if row y0 is the first child of $id then it's not an arrow
3184 if {[lindex $children($curview,$id) 0] ne
3185 [lindex $displayorder $y0]} {
3186 set isarrow 1
3189 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3190 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3191 set isarrow 1
3193 # Looking at lines from this row to the previous row,
3194 # make them go straight up if they end in an arrow on
3195 # the previous row; otherwise make them go straight up
3196 # or at 45 degrees.
3197 if {$z < -1 || ($z < 0 && $isarrow)} {
3198 # Line currently goes left too much;
3199 # insert pads in the previous row, then optimize it
3200 set npad [expr {-1 - $z + $isarrow}]
3201 insert_pad $y0 $x0 $npad
3202 if {$y0 > 0} {
3203 optimize_rows $y0 $x0 $row
3205 set previdlist [lindex $rowidlist $y0]
3206 set x0 [lsearch -exact $previdlist $id]
3207 set z [expr {$x0 - $col}]
3208 if {$z0 ne {}} {
3209 set pprevidlist [lindex $rowidlist $ym]
3210 set xm [lsearch -exact $pprevidlist $id]
3211 set z0 [expr {$xm - $x0}]
3213 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3214 # Line currently goes right too much;
3215 # insert pads in this line
3216 set npad [expr {$z - 1 + $isarrow}]
3217 insert_pad $row $col $npad
3218 set idlist [lindex $rowidlist $row]
3219 incr col $npad
3220 set z [expr {$x0 - $col}]
3221 set haspad 1
3223 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3224 # this line links to its first child on row $row-2
3225 set id [lindex $displayorder $ym]
3226 set xc [lsearch -exact $pprevidlist $id]
3227 if {$xc >= 0} {
3228 set z0 [expr {$xc - $x0}]
3231 # avoid lines jigging left then immediately right
3232 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3233 insert_pad $y0 $x0 1
3234 incr x0
3235 optimize_rows $y0 $x0 $row
3236 set previdlist [lindex $rowidlist $y0]
3239 if {!$haspad} {
3240 # Find the first column that doesn't have a line going right
3241 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3242 set id [lindex $idlist $col]
3243 if {$id eq {}} break
3244 set x0 [lsearch -exact $previdlist $id]
3245 if {$x0 < 0} {
3246 # check if this is the link to the first child
3247 set kid [lindex $displayorder $y0]
3248 if {[lindex $children($curview,$id) 0] eq $kid} {
3249 # it is, work out offset to child
3250 set x0 [lsearch -exact $previdlist $kid]
3253 if {$x0 <= $col} break
3255 # Insert a pad at that column as long as it has a line and
3256 # isn't the last column
3257 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3258 set idlist [linsert $idlist $col {}]
3259 lset rowidlist $row $idlist
3260 changedrow $row
3266 proc xc {row col} {
3267 global canvx0 linespc
3268 return [expr {$canvx0 + $col * $linespc}]
3271 proc yc {row} {
3272 global canvy0 linespc
3273 return [expr {$canvy0 + $row * $linespc}]
3276 proc linewidth {id} {
3277 global thickerline lthickness
3279 set wid $lthickness
3280 if {[info exists thickerline] && $id eq $thickerline} {
3281 set wid [expr {2 * $lthickness}]
3283 return $wid
3286 proc rowranges {id} {
3287 global commitrow curview children uparrowlen downarrowlen
3288 global rowidlist
3290 set kids $children($curview,$id)
3291 if {$kids eq {}} {
3292 return {}
3294 set ret {}
3295 lappend kids $id
3296 foreach child $kids {
3297 if {![info exists commitrow($curview,$child)]} break
3298 set row $commitrow($curview,$child)
3299 if {![info exists prev]} {
3300 lappend ret [expr {$row + 1}]
3301 } else {
3302 if {$row <= $prevrow} {
3303 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3305 # see if the line extends the whole way from prevrow to row
3306 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3307 [lsearch -exact [lindex $rowidlist \
3308 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3309 # it doesn't, see where it ends
3310 set r [expr {$prevrow + $downarrowlen}]
3311 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3312 while {[incr r -1] > $prevrow &&
3313 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3314 } else {
3315 while {[incr r] <= $row &&
3316 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3317 incr r -1
3319 lappend ret $r
3320 # see where it starts up again
3321 set r [expr {$row - $uparrowlen}]
3322 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3323 while {[incr r] < $row &&
3324 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3325 } else {
3326 while {[incr r -1] >= $prevrow &&
3327 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3328 incr r
3330 lappend ret $r
3333 if {$child eq $id} {
3334 lappend ret $row
3336 set prev $id
3337 set prevrow $row
3339 return $ret
3342 proc drawlineseg {id row endrow arrowlow} {
3343 global rowidlist displayorder iddrawn linesegs
3344 global canv colormap linespc curview maxlinelen parentlist
3346 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3347 set le [expr {$row + 1}]
3348 set arrowhigh 1
3349 while {1} {
3350 set c [lsearch -exact [lindex $rowidlist $le] $id]
3351 if {$c < 0} {
3352 incr le -1
3353 break
3355 lappend cols $c
3356 set x [lindex $displayorder $le]
3357 if {$x eq $id} {
3358 set arrowhigh 0
3359 break
3361 if {[info exists iddrawn($x)] || $le == $endrow} {
3362 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3363 if {$c >= 0} {
3364 lappend cols $c
3365 set arrowhigh 0
3367 break
3369 incr le
3371 if {$le <= $row} {
3372 return $row
3375 set lines {}
3376 set i 0
3377 set joinhigh 0
3378 if {[info exists linesegs($id)]} {
3379 set lines $linesegs($id)
3380 foreach li $lines {
3381 set r0 [lindex $li 0]
3382 if {$r0 > $row} {
3383 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3384 set joinhigh 1
3386 break
3388 incr i
3391 set joinlow 0
3392 if {$i > 0} {
3393 set li [lindex $lines [expr {$i-1}]]
3394 set r1 [lindex $li 1]
3395 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3396 set joinlow 1
3400 set x [lindex $cols [expr {$le - $row}]]
3401 set xp [lindex $cols [expr {$le - 1 - $row}]]
3402 set dir [expr {$xp - $x}]
3403 if {$joinhigh} {
3404 set ith [lindex $lines $i 2]
3405 set coords [$canv coords $ith]
3406 set ah [$canv itemcget $ith -arrow]
3407 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3408 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3409 if {$x2 ne {} && $x - $x2 == $dir} {
3410 set coords [lrange $coords 0 end-2]
3412 } else {
3413 set coords [list [xc $le $x] [yc $le]]
3415 if {$joinlow} {
3416 set itl [lindex $lines [expr {$i-1}] 2]
3417 set al [$canv itemcget $itl -arrow]
3418 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3419 } elseif {$arrowlow} {
3420 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3421 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3422 set arrowlow 0
3425 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3426 for {set y $le} {[incr y -1] > $row} {} {
3427 set x $xp
3428 set xp [lindex $cols [expr {$y - 1 - $row}]]
3429 set ndir [expr {$xp - $x}]
3430 if {$dir != $ndir || $xp < 0} {
3431 lappend coords [xc $y $x] [yc $y]
3433 set dir $ndir
3435 if {!$joinlow} {
3436 if {$xp < 0} {
3437 # join parent line to first child
3438 set ch [lindex $displayorder $row]
3439 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3440 if {$xc < 0} {
3441 puts "oops: drawlineseg: child $ch not on row $row"
3442 } elseif {$xc != $x} {
3443 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3444 set d [expr {int(0.5 * $linespc)}]
3445 set x1 [xc $row $x]
3446 if {$xc < $x} {
3447 set x2 [expr {$x1 - $d}]
3448 } else {
3449 set x2 [expr {$x1 + $d}]
3451 set y2 [yc $row]
3452 set y1 [expr {$y2 + $d}]
3453 lappend coords $x1 $y1 $x2 $y2
3454 } elseif {$xc < $x - 1} {
3455 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3456 } elseif {$xc > $x + 1} {
3457 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3459 set x $xc
3461 lappend coords [xc $row $x] [yc $row]
3462 } else {
3463 set xn [xc $row $xp]
3464 set yn [yc $row]
3465 lappend coords $xn $yn
3467 if {!$joinhigh} {
3468 assigncolor $id
3469 set t [$canv create line $coords -width [linewidth $id] \
3470 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3471 $canv lower $t
3472 bindline $t $id
3473 set lines [linsert $lines $i [list $row $le $t]]
3474 } else {
3475 $canv coords $ith $coords
3476 if {$arrow ne $ah} {
3477 $canv itemconf $ith -arrow $arrow
3479 lset lines $i 0 $row
3481 } else {
3482 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3483 set ndir [expr {$xo - $xp}]
3484 set clow [$canv coords $itl]
3485 if {$dir == $ndir} {
3486 set clow [lrange $clow 2 end]
3488 set coords [concat $coords $clow]
3489 if {!$joinhigh} {
3490 lset lines [expr {$i-1}] 1 $le
3491 } else {
3492 # coalesce two pieces
3493 $canv delete $ith
3494 set b [lindex $lines [expr {$i-1}] 0]
3495 set e [lindex $lines $i 1]
3496 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3498 $canv coords $itl $coords
3499 if {$arrow ne $al} {
3500 $canv itemconf $itl -arrow $arrow
3504 set linesegs($id) $lines
3505 return $le
3508 proc drawparentlinks {id row} {
3509 global rowidlist canv colormap curview parentlist
3510 global idpos linespc
3512 set rowids [lindex $rowidlist $row]
3513 set col [lsearch -exact $rowids $id]
3514 if {$col < 0} return
3515 set olds [lindex $parentlist $row]
3516 set row2 [expr {$row + 1}]
3517 set x [xc $row $col]
3518 set y [yc $row]
3519 set y2 [yc $row2]
3520 set d [expr {int(0.5 * $linespc)}]
3521 set ymid [expr {$y + $d}]
3522 set ids [lindex $rowidlist $row2]
3523 # rmx = right-most X coord used
3524 set rmx 0
3525 foreach p $olds {
3526 set i [lsearch -exact $ids $p]
3527 if {$i < 0} {
3528 puts "oops, parent $p of $id not in list"
3529 continue
3531 set x2 [xc $row2 $i]
3532 if {$x2 > $rmx} {
3533 set rmx $x2
3535 set j [lsearch -exact $rowids $p]
3536 if {$j < 0} {
3537 # drawlineseg will do this one for us
3538 continue
3540 assigncolor $p
3541 # should handle duplicated parents here...
3542 set coords [list $x $y]
3543 if {$i != $col} {
3544 # if attaching to a vertical segment, draw a smaller
3545 # slant for visual distinctness
3546 if {$i == $j} {
3547 if {$i < $col} {
3548 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3549 } else {
3550 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3552 } elseif {$i < $col && $i < $j} {
3553 # segment slants towards us already
3554 lappend coords [xc $row $j] $y
3555 } else {
3556 if {$i < $col - 1} {
3557 lappend coords [expr {$x2 + $linespc}] $y
3558 } elseif {$i > $col + 1} {
3559 lappend coords [expr {$x2 - $linespc}] $y
3561 lappend coords $x2 $y2
3563 } else {
3564 lappend coords $x2 $y2
3566 set t [$canv create line $coords -width [linewidth $p] \
3567 -fill $colormap($p) -tags lines.$p]
3568 $canv lower $t
3569 bindline $t $p
3571 if {$rmx > [lindex $idpos($id) 1]} {
3572 lset idpos($id) 1 $rmx
3573 redrawtags $id
3577 proc drawlines {id} {
3578 global canv
3580 $canv itemconf lines.$id -width [linewidth $id]
3583 proc drawcmittext {id row col} {
3584 global linespc canv canv2 canv3 canvy0 fgcolor curview
3585 global commitlisted commitinfo rowidlist parentlist
3586 global rowtextx idpos idtags idheads idotherrefs
3587 global linehtag linentag linedtag selectedline
3588 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3590 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3591 set listed [lindex $commitlisted $row]
3592 if {$id eq $nullid} {
3593 set ofill red
3594 } elseif {$id eq $nullid2} {
3595 set ofill green
3596 } else {
3597 set ofill [expr {$listed != 0? "blue": "white"}]
3599 set x [xc $row $col]
3600 set y [yc $row]
3601 set orad [expr {$linespc / 3}]
3602 if {$listed <= 1} {
3603 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3604 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3605 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3606 } elseif {$listed == 2} {
3607 # triangle pointing left for left-side commits
3608 set t [$canv create polygon \
3609 [expr {$x - $orad}] $y \
3610 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3611 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3612 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3613 } else {
3614 # triangle pointing right for right-side commits
3615 set t [$canv create polygon \
3616 [expr {$x + $orad - 1}] $y \
3617 [expr {$x - $orad}] [expr {$y - $orad}] \
3618 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3619 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3621 $canv raise $t
3622 $canv bind $t <1> {selcanvline {} %x %y}
3623 set rmx [llength [lindex $rowidlist $row]]
3624 set olds [lindex $parentlist $row]
3625 if {$olds ne {}} {
3626 set nextids [lindex $rowidlist [expr {$row + 1}]]
3627 foreach p $olds {
3628 set i [lsearch -exact $nextids $p]
3629 if {$i > $rmx} {
3630 set rmx $i
3634 set xt [xc $row $rmx]
3635 set rowtextx($row) $xt
3636 set idpos($id) [list $x $xt $y]
3637 if {[info exists idtags($id)] || [info exists idheads($id)]
3638 || [info exists idotherrefs($id)]} {
3639 set xt [drawtags $id $x $xt $y]
3641 set headline [lindex $commitinfo($id) 0]
3642 set name [lindex $commitinfo($id) 1]
3643 set date [lindex $commitinfo($id) 2]
3644 set date [formatdate $date]
3645 set font $mainfont
3646 set nfont $mainfont
3647 set isbold [ishighlighted $row]
3648 if {$isbold > 0} {
3649 lappend boldrows $row
3650 lappend font bold
3651 if {$isbold > 1} {
3652 lappend boldnamerows $row
3653 lappend nfont bold
3656 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3657 -text $headline -font $font -tags text]
3658 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3659 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3660 -text $name -font $nfont -tags text]
3661 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3662 -text $date -font $mainfont -tags text]
3663 if {[info exists selectedline] && $selectedline == $row} {
3664 make_secsel $row
3666 set xr [expr {$xt + [font measure $mainfont $headline]}]
3667 if {$xr > $canvxmax} {
3668 set canvxmax $xr
3669 setcanvscroll
3673 proc drawcmitrow {row} {
3674 global displayorder rowidlist nrows_drawn
3675 global iddrawn markingmatches
3676 global commitinfo parentlist numcommits
3677 global filehighlight fhighlights findstring nhighlights
3678 global hlview vhighlights
3679 global highlight_related rhighlights
3681 if {$row >= $numcommits} return
3683 set id [lindex $displayorder $row]
3684 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3685 askvhighlight $row $id
3687 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3688 askfilehighlight $row $id
3690 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3691 askfindhighlight $row $id
3693 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3694 askrelhighlight $row $id
3696 if {![info exists iddrawn($id)]} {
3697 set col [lsearch -exact [lindex $rowidlist $row] $id]
3698 if {$col < 0} {
3699 puts "oops, row $row id $id not in list"
3700 return
3702 if {![info exists commitinfo($id)]} {
3703 getcommit $id
3705 assigncolor $id
3706 drawcmittext $id $row $col
3707 set iddrawn($id) 1
3708 incr nrows_drawn
3710 if {$markingmatches} {
3711 markrowmatches $row $id
3715 proc drawcommits {row {endrow {}}} {
3716 global numcommits iddrawn displayorder curview need_redisplay
3717 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3719 if {$row < 0} {
3720 set row 0
3722 if {$endrow eq {}} {
3723 set endrow $row
3725 if {$endrow >= $numcommits} {
3726 set endrow [expr {$numcommits - 1}]
3729 set rl1 [expr {$row - $downarrowlen - 3}]
3730 if {$rl1 < 0} {
3731 set rl1 0
3733 set ro1 [expr {$row - 3}]
3734 if {$ro1 < 0} {
3735 set ro1 0
3737 set r2 [expr {$endrow + $uparrowlen + 3}]
3738 if {$r2 > $numcommits} {
3739 set r2 $numcommits
3741 for {set r $rl1} {$r < $r2} {incr r} {
3742 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3743 if {$rl1 < $r} {
3744 layoutrows $rl1 $r
3746 set rl1 [expr {$r + 1}]
3749 if {$rl1 < $r} {
3750 layoutrows $rl1 $r
3752 optimize_rows $ro1 0 $r2
3753 if {$need_redisplay || $nrows_drawn > 2000} {
3754 clear_display
3755 drawvisible
3758 # make the lines join to already-drawn rows either side
3759 set r [expr {$row - 1}]
3760 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3761 set r $row
3763 set er [expr {$endrow + 1}]
3764 if {$er >= $numcommits ||
3765 ![info exists iddrawn([lindex $displayorder $er])]} {
3766 set er $endrow
3768 for {} {$r <= $er} {incr r} {
3769 set id [lindex $displayorder $r]
3770 set wasdrawn [info exists iddrawn($id)]
3771 drawcmitrow $r
3772 if {$r == $er} break
3773 set nextid [lindex $displayorder [expr {$r + 1}]]
3774 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3775 catch {unset prevlines}
3776 continue
3778 drawparentlinks $id $r
3780 if {[info exists lineends($r)]} {
3781 foreach lid $lineends($r) {
3782 unset prevlines($lid)
3785 set rowids [lindex $rowidlist $r]
3786 foreach lid $rowids {
3787 if {$lid eq {}} continue
3788 if {$lid eq $id} {
3789 # see if this is the first child of any of its parents
3790 foreach p [lindex $parentlist $r] {
3791 if {[lsearch -exact $rowids $p] < 0} {
3792 # make this line extend up to the child
3793 set le [drawlineseg $p $r $er 0]
3794 lappend lineends($le) $p
3795 set prevlines($p) 1
3798 } elseif {![info exists prevlines($lid)]} {
3799 set le [drawlineseg $lid $r $er 1]
3800 lappend lineends($le) $lid
3801 set prevlines($lid) 1
3807 proc drawfrac {f0 f1} {
3808 global canv linespc
3810 set ymax [lindex [$canv cget -scrollregion] 3]
3811 if {$ymax eq {} || $ymax == 0} return
3812 set y0 [expr {int($f0 * $ymax)}]
3813 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3814 set y1 [expr {int($f1 * $ymax)}]
3815 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3816 drawcommits $row $endrow
3819 proc drawvisible {} {
3820 global canv
3821 eval drawfrac [$canv yview]
3824 proc clear_display {} {
3825 global iddrawn linesegs need_redisplay nrows_drawn
3826 global vhighlights fhighlights nhighlights rhighlights
3828 allcanvs delete all
3829 catch {unset iddrawn}
3830 catch {unset linesegs}
3831 catch {unset vhighlights}
3832 catch {unset fhighlights}
3833 catch {unset nhighlights}
3834 catch {unset rhighlights}
3835 set need_redisplay 0
3836 set nrows_drawn 0
3839 proc findcrossings {id} {
3840 global rowidlist parentlist numcommits displayorder
3842 set cross {}
3843 set ccross {}
3844 foreach {s e} [rowranges $id] {
3845 if {$e >= $numcommits} {
3846 set e [expr {$numcommits - 1}]
3848 if {$e <= $s} continue
3849 for {set row $e} {[incr row -1] >= $s} {} {
3850 set x [lsearch -exact [lindex $rowidlist $row] $id]
3851 if {$x < 0} break
3852 set olds [lindex $parentlist $row]
3853 set kid [lindex $displayorder $row]
3854 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3855 if {$kidx < 0} continue
3856 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3857 foreach p $olds {
3858 set px [lsearch -exact $nextrow $p]
3859 if {$px < 0} continue
3860 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3861 if {[lsearch -exact $ccross $p] >= 0} continue
3862 if {$x == $px + ($kidx < $px? -1: 1)} {
3863 lappend ccross $p
3864 } elseif {[lsearch -exact $cross $p] < 0} {
3865 lappend cross $p
3871 return [concat $ccross {{}} $cross]
3874 proc assigncolor {id} {
3875 global colormap colors nextcolor
3876 global commitrow parentlist children children curview
3878 if {[info exists colormap($id)]} return
3879 set ncolors [llength $colors]
3880 if {[info exists children($curview,$id)]} {
3881 set kids $children($curview,$id)
3882 } else {
3883 set kids {}
3885 if {[llength $kids] == 1} {
3886 set child [lindex $kids 0]
3887 if {[info exists colormap($child)]
3888 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3889 set colormap($id) $colormap($child)
3890 return
3893 set badcolors {}
3894 set origbad {}
3895 foreach x [findcrossings $id] {
3896 if {$x eq {}} {
3897 # delimiter between corner crossings and other crossings
3898 if {[llength $badcolors] >= $ncolors - 1} break
3899 set origbad $badcolors
3901 if {[info exists colormap($x)]
3902 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3903 lappend badcolors $colormap($x)
3906 if {[llength $badcolors] >= $ncolors} {
3907 set badcolors $origbad
3909 set origbad $badcolors
3910 if {[llength $badcolors] < $ncolors - 1} {
3911 foreach child $kids {
3912 if {[info exists colormap($child)]
3913 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3914 lappend badcolors $colormap($child)
3916 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3917 if {[info exists colormap($p)]
3918 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3919 lappend badcolors $colormap($p)
3923 if {[llength $badcolors] >= $ncolors} {
3924 set badcolors $origbad
3927 for {set i 0} {$i <= $ncolors} {incr i} {
3928 set c [lindex $colors $nextcolor]
3929 if {[incr nextcolor] >= $ncolors} {
3930 set nextcolor 0
3932 if {[lsearch -exact $badcolors $c]} break
3934 set colormap($id) $c
3937 proc bindline {t id} {
3938 global canv
3940 $canv bind $t <Enter> "lineenter %x %y $id"
3941 $canv bind $t <Motion> "linemotion %x %y $id"
3942 $canv bind $t <Leave> "lineleave $id"
3943 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3946 proc drawtags {id x xt y1} {
3947 global idtags idheads idotherrefs mainhead
3948 global linespc lthickness
3949 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3951 set marks {}
3952 set ntags 0
3953 set nheads 0
3954 if {[info exists idtags($id)]} {
3955 set marks $idtags($id)
3956 set ntags [llength $marks]
3958 if {[info exists idheads($id)]} {
3959 set marks [concat $marks $idheads($id)]
3960 set nheads [llength $idheads($id)]
3962 if {[info exists idotherrefs($id)]} {
3963 set marks [concat $marks $idotherrefs($id)]
3965 if {$marks eq {}} {
3966 return $xt
3969 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3970 set yt [expr {$y1 - 0.5 * $linespc}]
3971 set yb [expr {$yt + $linespc - 1}]
3972 set xvals {}
3973 set wvals {}
3974 set i -1
3975 foreach tag $marks {
3976 incr i
3977 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3978 set wid [font measure [concat $mainfont bold] $tag]
3979 } else {
3980 set wid [font measure $mainfont $tag]
3982 lappend xvals $xt
3983 lappend wvals $wid
3984 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3986 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3987 -width $lthickness -fill black -tags tag.$id]
3988 $canv lower $t
3989 foreach tag $marks x $xvals wid $wvals {
3990 set xl [expr {$x + $delta}]
3991 set xr [expr {$x + $delta + $wid + $lthickness}]
3992 set font $mainfont
3993 if {[incr ntags -1] >= 0} {
3994 # draw a tag
3995 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3996 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3997 -width 1 -outline black -fill yellow -tags tag.$id]
3998 $canv bind $t <1> [list showtag $tag 1]
3999 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4000 } else {
4001 # draw a head or other ref
4002 if {[incr nheads -1] >= 0} {
4003 set col green
4004 if {$tag eq $mainhead} {
4005 lappend font bold
4007 } else {
4008 set col "#ddddff"
4010 set xl [expr {$xl - $delta/2}]
4011 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4012 -width 1 -outline black -fill $col -tags tag.$id
4013 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4014 set rwid [font measure $mainfont $remoteprefix]
4015 set xi [expr {$x + 1}]
4016 set yti [expr {$yt + 1}]
4017 set xri [expr {$x + $rwid}]
4018 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4019 -width 0 -fill "#ffddaa" -tags tag.$id
4022 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4023 -font $font -tags [list tag.$id text]]
4024 if {$ntags >= 0} {
4025 $canv bind $t <1> [list showtag $tag 1]
4026 } elseif {$nheads >= 0} {
4027 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4030 return $xt
4033 proc xcoord {i level ln} {
4034 global canvx0 xspc1 xspc2
4036 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4037 if {$i > 0 && $i == $level} {
4038 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4039 } elseif {$i > $level} {
4040 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4042 return $x
4045 proc show_status {msg} {
4046 global canv mainfont fgcolor
4048 clear_display
4049 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
4050 -tags text -fill $fgcolor
4053 # Insert a new commit as the child of the commit on row $row.
4054 # The new commit will be displayed on row $row and the commits
4055 # on that row and below will move down one row.
4056 proc insertrow {row newcmit} {
4057 global displayorder parentlist commitlisted children
4058 global commitrow curview rowidlist rowisopt numcommits
4059 global numcommits
4060 global selectedline commitidx ordertok
4062 if {$row >= $numcommits} {
4063 puts "oops, inserting new row $row but only have $numcommits rows"
4064 return
4066 set p [lindex $displayorder $row]
4067 set displayorder [linsert $displayorder $row $newcmit]
4068 set parentlist [linsert $parentlist $row $p]
4069 set kids $children($curview,$p)
4070 lappend kids $newcmit
4071 set children($curview,$p) $kids
4072 set children($curview,$newcmit) {}
4073 set commitlisted [linsert $commitlisted $row 1]
4074 set l [llength $displayorder]
4075 for {set r $row} {$r < $l} {incr r} {
4076 set id [lindex $displayorder $r]
4077 set commitrow($curview,$id) $r
4079 incr commitidx($curview)
4080 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4082 set idlist [lindex $rowidlist $row]
4083 if {[llength $kids] == 1} {
4084 set col [lsearch -exact $idlist $p]
4085 lset idlist $col $newcmit
4086 } else {
4087 set col [llength $idlist]
4088 lappend idlist $newcmit
4090 set rowidlist [linsert $rowidlist $row $idlist]
4091 set rowisopt [linsert $rowisopt $row 0]
4093 incr numcommits
4095 if {[info exists selectedline] && $selectedline >= $row} {
4096 incr selectedline
4098 redisplay
4101 # Remove a commit that was inserted with insertrow on row $row.
4102 proc removerow {row} {
4103 global displayorder parentlist commitlisted children
4104 global commitrow curview rowidlist rowisopt numcommits
4105 global numcommits
4106 global linesegends selectedline commitidx
4108 if {$row >= $numcommits} {
4109 puts "oops, removing row $row but only have $numcommits rows"
4110 return
4112 set rp1 [expr {$row + 1}]
4113 set id [lindex $displayorder $row]
4114 set p [lindex $parentlist $row]
4115 set displayorder [lreplace $displayorder $row $row]
4116 set parentlist [lreplace $parentlist $row $row]
4117 set commitlisted [lreplace $commitlisted $row $row]
4118 set kids $children($curview,$p)
4119 set i [lsearch -exact $kids $id]
4120 if {$i >= 0} {
4121 set kids [lreplace $kids $i $i]
4122 set children($curview,$p) $kids
4124 set l [llength $displayorder]
4125 for {set r $row} {$r < $l} {incr r} {
4126 set id [lindex $displayorder $r]
4127 set commitrow($curview,$id) $r
4129 incr commitidx($curview) -1
4131 set rowidlist [lreplace $rowidlist $row $row]
4132 set rowisopt [lreplace $rowisopt $row $row]
4134 incr numcommits -1
4136 if {[info exists selectedline] && $selectedline > $row} {
4137 incr selectedline -1
4139 redisplay
4142 # Don't change the text pane cursor if it is currently the hand cursor,
4143 # showing that we are over a sha1 ID link.
4144 proc settextcursor {c} {
4145 global ctext curtextcursor
4147 if {[$ctext cget -cursor] == $curtextcursor} {
4148 $ctext config -cursor $c
4150 set curtextcursor $c
4153 proc nowbusy {what} {
4154 global isbusy
4156 if {[array names isbusy] eq {}} {
4157 . config -cursor watch
4158 settextcursor watch
4160 set isbusy($what) 1
4163 proc notbusy {what} {
4164 global isbusy maincursor textcursor
4166 catch {unset isbusy($what)}
4167 if {[array names isbusy] eq {}} {
4168 . config -cursor $maincursor
4169 settextcursor $textcursor
4173 proc findmatches {f} {
4174 global findtype findstring
4175 if {$findtype == "Regexp"} {
4176 set matches [regexp -indices -all -inline $findstring $f]
4177 } else {
4178 set fs $findstring
4179 if {$findtype == "IgnCase"} {
4180 set f [string tolower $f]
4181 set fs [string tolower $fs]
4183 set matches {}
4184 set i 0
4185 set l [string length $fs]
4186 while {[set j [string first $fs $f $i]] >= 0} {
4187 lappend matches [list $j [expr {$j+$l-1}]]
4188 set i [expr {$j + $l}]
4191 return $matches
4194 proc dofind {{rev 0}} {
4195 global findstring findstartline findcurline selectedline numcommits
4197 unmarkmatches
4198 cancel_next_highlight
4199 focus .
4200 if {$findstring eq {} || $numcommits == 0} return
4201 if {![info exists selectedline]} {
4202 set findstartline [lindex [visiblerows] $rev]
4203 } else {
4204 set findstartline $selectedline
4206 set findcurline $findstartline
4207 nowbusy finding
4208 if {!$rev} {
4209 run findmore
4210 } else {
4211 if {$findcurline == 0} {
4212 set findcurline $numcommits
4214 incr findcurline -1
4215 run findmorerev
4219 proc findnext {restart} {
4220 global findcurline
4221 if {![info exists findcurline]} {
4222 if {$restart} {
4223 dofind
4224 } else {
4225 bell
4227 } else {
4228 run findmore
4229 nowbusy finding
4233 proc findprev {} {
4234 global findcurline
4235 if {![info exists findcurline]} {
4236 dofind 1
4237 } else {
4238 run findmorerev
4239 nowbusy finding
4243 proc findmore {} {
4244 global commitdata commitinfo numcommits findstring findpattern findloc
4245 global findstartline findcurline displayorder
4247 set fldtypes {Headline Author Date Committer CDate Comments}
4248 set l [expr {$findcurline + 1}]
4249 if {$l >= $numcommits} {
4250 set l 0
4252 if {$l <= $findstartline} {
4253 set lim [expr {$findstartline + 1}]
4254 } else {
4255 set lim $numcommits
4257 if {$lim - $l > 500} {
4258 set lim [expr {$l + 500}]
4260 set last 0
4261 for {} {$l < $lim} {incr l} {
4262 set id [lindex $displayorder $l]
4263 # shouldn't happen unless git log doesn't give all the commits...
4264 if {![info exists commitdata($id)]} continue
4265 if {![doesmatch $commitdata($id)]} continue
4266 if {![info exists commitinfo($id)]} {
4267 getcommit $id
4269 set info $commitinfo($id)
4270 foreach f $info ty $fldtypes {
4271 if {($findloc eq "All fields" || $findloc eq $ty) &&
4272 [doesmatch $f]} {
4273 findselectline $l
4274 notbusy finding
4275 return 0
4279 if {$l == $findstartline + 1} {
4280 bell
4281 unset findcurline
4282 notbusy finding
4283 return 0
4285 set findcurline [expr {$l - 1}]
4286 return 1
4289 proc findmorerev {} {
4290 global commitdata commitinfo numcommits findstring findpattern findloc
4291 global findstartline findcurline displayorder
4293 set fldtypes {Headline Author Date Committer CDate Comments}
4294 set l $findcurline
4295 if {$l == 0} {
4296 set l $numcommits
4298 incr l -1
4299 if {$l >= $findstartline} {
4300 set lim [expr {$findstartline - 1}]
4301 } else {
4302 set lim -1
4304 if {$l - $lim > 500} {
4305 set lim [expr {$l - 500}]
4307 set last 0
4308 for {} {$l > $lim} {incr l -1} {
4309 set id [lindex $displayorder $l]
4310 if {![info exists commitdata($id)]} continue
4311 if {![doesmatch $commitdata($id)]} continue
4312 if {![info exists commitinfo($id)]} {
4313 getcommit $id
4315 set info $commitinfo($id)
4316 foreach f $info ty $fldtypes {
4317 if {($findloc eq "All fields" || $findloc eq $ty) &&
4318 [doesmatch $f]} {
4319 findselectline $l
4320 notbusy finding
4321 return 0
4325 if {$l == -1} {
4326 bell
4327 unset findcurline
4328 notbusy finding
4329 return 0
4331 set findcurline [expr {$l + 1}]
4332 return 1
4335 proc findselectline {l} {
4336 global findloc commentend ctext findcurline markingmatches
4338 set markingmatches 1
4339 set findcurline $l
4340 selectline $l 1
4341 if {$findloc == "All fields" || $findloc == "Comments"} {
4342 # highlight the matches in the comments
4343 set f [$ctext get 1.0 $commentend]
4344 set matches [findmatches $f]
4345 foreach match $matches {
4346 set start [lindex $match 0]
4347 set end [expr {[lindex $match 1] + 1}]
4348 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4351 drawvisible
4354 # mark the bits of a headline or author that match a find string
4355 proc markmatches {canv l str tag matches font row} {
4356 global selectedline
4358 set bbox [$canv bbox $tag]
4359 set x0 [lindex $bbox 0]
4360 set y0 [lindex $bbox 1]
4361 set y1 [lindex $bbox 3]
4362 foreach match $matches {
4363 set start [lindex $match 0]
4364 set end [lindex $match 1]
4365 if {$start > $end} continue
4366 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4367 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4368 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4369 [expr {$x0+$xlen+2}] $y1 \
4370 -outline {} -tags [list match$l matches] -fill yellow]
4371 $canv lower $t
4372 if {[info exists selectedline] && $row == $selectedline} {
4373 $canv raise $t secsel
4378 proc unmarkmatches {} {
4379 global findids markingmatches findcurline
4381 allcanvs delete matches
4382 catch {unset findids}
4383 set markingmatches 0
4384 catch {unset findcurline}
4387 proc selcanvline {w x y} {
4388 global canv canvy0 ctext linespc
4389 global rowtextx
4390 set ymax [lindex [$canv cget -scrollregion] 3]
4391 if {$ymax == {}} return
4392 set yfrac [lindex [$canv yview] 0]
4393 set y [expr {$y + $yfrac * $ymax}]
4394 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4395 if {$l < 0} {
4396 set l 0
4398 if {$w eq $canv} {
4399 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4401 unmarkmatches
4402 selectline $l 1
4405 proc commit_descriptor {p} {
4406 global commitinfo
4407 if {![info exists commitinfo($p)]} {
4408 getcommit $p
4410 set l "..."
4411 if {[llength $commitinfo($p)] > 1} {
4412 set l [lindex $commitinfo($p) 0]
4414 return "$p ($l)\n"
4417 # append some text to the ctext widget, and make any SHA1 ID
4418 # that we know about be a clickable link.
4419 proc appendwithlinks {text tags} {
4420 global ctext commitrow linknum curview pendinglinks
4422 set start [$ctext index "end - 1c"]
4423 $ctext insert end $text $tags
4424 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4425 foreach l $links {
4426 set s [lindex $l 0]
4427 set e [lindex $l 1]
4428 set linkid [string range $text $s $e]
4429 incr e
4430 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4431 setlink $linkid link$linknum
4432 incr linknum
4436 proc setlink {id lk} {
4437 global curview commitrow ctext pendinglinks commitinterest
4439 if {[info exists commitrow($curview,$id)]} {
4440 $ctext tag conf $lk -foreground blue -underline 1
4441 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4442 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4443 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4444 } else {
4445 lappend pendinglinks($id) $lk
4446 lappend commitinterest($id) {makelink %I}
4450 proc makelink {id} {
4451 global pendinglinks
4453 if {![info exists pendinglinks($id)]} return
4454 foreach lk $pendinglinks($id) {
4455 setlink $id $lk
4457 unset pendinglinks($id)
4460 proc linkcursor {w inc} {
4461 global linkentercount curtextcursor
4463 if {[incr linkentercount $inc] > 0} {
4464 $w configure -cursor hand2
4465 } else {
4466 $w configure -cursor $curtextcursor
4467 if {$linkentercount < 0} {
4468 set linkentercount 0
4473 proc viewnextline {dir} {
4474 global canv linespc
4476 $canv delete hover
4477 set ymax [lindex [$canv cget -scrollregion] 3]
4478 set wnow [$canv yview]
4479 set wtop [expr {[lindex $wnow 0] * $ymax}]
4480 set newtop [expr {$wtop + $dir * $linespc}]
4481 if {$newtop < 0} {
4482 set newtop 0
4483 } elseif {$newtop > $ymax} {
4484 set newtop $ymax
4486 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4489 # add a list of tag or branch names at position pos
4490 # returns the number of names inserted
4491 proc appendrefs {pos ids var} {
4492 global ctext commitrow linknum curview $var maxrefs
4494 if {[catch {$ctext index $pos}]} {
4495 return 0
4497 $ctext conf -state normal
4498 $ctext delete $pos "$pos lineend"
4499 set tags {}
4500 foreach id $ids {
4501 foreach tag [set $var\($id\)] {
4502 lappend tags [list $tag $id]
4505 if {[llength $tags] > $maxrefs} {
4506 $ctext insert $pos "many ([llength $tags])"
4507 } else {
4508 set tags [lsort -index 0 -decreasing $tags]
4509 set sep {}
4510 foreach ti $tags {
4511 set id [lindex $ti 1]
4512 set lk link$linknum
4513 incr linknum
4514 $ctext tag delete $lk
4515 $ctext insert $pos $sep
4516 $ctext insert $pos [lindex $ti 0] $lk
4517 setlink $id $lk
4518 set sep ", "
4521 $ctext conf -state disabled
4522 return [llength $tags]
4525 # called when we have finished computing the nearby tags
4526 proc dispneartags {delay} {
4527 global selectedline currentid showneartags tagphase
4529 if {![info exists selectedline] || !$showneartags} return
4530 after cancel dispnexttag
4531 if {$delay} {
4532 after 200 dispnexttag
4533 set tagphase -1
4534 } else {
4535 after idle dispnexttag
4536 set tagphase 0
4540 proc dispnexttag {} {
4541 global selectedline currentid showneartags tagphase ctext
4543 if {![info exists selectedline] || !$showneartags} return
4544 switch -- $tagphase {
4546 set dtags [desctags $currentid]
4547 if {$dtags ne {}} {
4548 appendrefs precedes $dtags idtags
4552 set atags [anctags $currentid]
4553 if {$atags ne {}} {
4554 appendrefs follows $atags idtags
4558 set dheads [descheads $currentid]
4559 if {$dheads ne {}} {
4560 if {[appendrefs branch $dheads idheads] > 1
4561 && [$ctext get "branch -3c"] eq "h"} {
4562 # turn "Branch" into "Branches"
4563 $ctext conf -state normal
4564 $ctext insert "branch -2c" "es"
4565 $ctext conf -state disabled
4570 if {[incr tagphase] <= 2} {
4571 after idle dispnexttag
4575 proc make_secsel {l} {
4576 global linehtag linentag linedtag canv canv2 canv3
4578 if {![info exists linehtag($l)]} return
4579 $canv delete secsel
4580 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4581 -tags secsel -fill [$canv cget -selectbackground]]
4582 $canv lower $t
4583 $canv2 delete secsel
4584 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4585 -tags secsel -fill [$canv2 cget -selectbackground]]
4586 $canv2 lower $t
4587 $canv3 delete secsel
4588 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4589 -tags secsel -fill [$canv3 cget -selectbackground]]
4590 $canv3 lower $t
4593 proc selectline {l isnew} {
4594 global canv ctext commitinfo selectedline
4595 global displayorder
4596 global canvy0 linespc parentlist children curview
4597 global currentid sha1entry
4598 global commentend idtags linknum
4599 global mergemax numcommits pending_select
4600 global cmitmode showneartags allcommits
4602 catch {unset pending_select}
4603 $canv delete hover
4604 normalline
4605 cancel_next_highlight
4606 unsel_reflist
4607 if {$l < 0 || $l >= $numcommits} return
4608 set y [expr {$canvy0 + $l * $linespc}]
4609 set ymax [lindex [$canv cget -scrollregion] 3]
4610 set ytop [expr {$y - $linespc - 1}]
4611 set ybot [expr {$y + $linespc + 1}]
4612 set wnow [$canv yview]
4613 set wtop [expr {[lindex $wnow 0] * $ymax}]
4614 set wbot [expr {[lindex $wnow 1] * $ymax}]
4615 set wh [expr {$wbot - $wtop}]
4616 set newtop $wtop
4617 if {$ytop < $wtop} {
4618 if {$ybot < $wtop} {
4619 set newtop [expr {$y - $wh / 2.0}]
4620 } else {
4621 set newtop $ytop
4622 if {$newtop > $wtop - $linespc} {
4623 set newtop [expr {$wtop - $linespc}]
4626 } elseif {$ybot > $wbot} {
4627 if {$ytop > $wbot} {
4628 set newtop [expr {$y - $wh / 2.0}]
4629 } else {
4630 set newtop [expr {$ybot - $wh}]
4631 if {$newtop < $wtop + $linespc} {
4632 set newtop [expr {$wtop + $linespc}]
4636 if {$newtop != $wtop} {
4637 if {$newtop < 0} {
4638 set newtop 0
4640 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4641 drawvisible
4644 make_secsel $l
4646 if {$isnew} {
4647 addtohistory [list selectline $l 0]
4650 set selectedline $l
4652 set id [lindex $displayorder $l]
4653 set currentid $id
4654 $sha1entry delete 0 end
4655 $sha1entry insert 0 $id
4656 $sha1entry selection from 0
4657 $sha1entry selection to end
4658 rhighlight_sel $id
4660 $ctext conf -state normal
4661 clear_ctext
4662 set linknum 0
4663 set info $commitinfo($id)
4664 set date [formatdate [lindex $info 2]]
4665 $ctext insert end "Author: [lindex $info 1] $date\n"
4666 set date [formatdate [lindex $info 4]]
4667 $ctext insert end "Committer: [lindex $info 3] $date\n"
4668 if {[info exists idtags($id)]} {
4669 $ctext insert end "Tags:"
4670 foreach tag $idtags($id) {
4671 $ctext insert end " $tag"
4673 $ctext insert end "\n"
4676 set headers {}
4677 set olds [lindex $parentlist $l]
4678 if {[llength $olds] > 1} {
4679 set np 0
4680 foreach p $olds {
4681 if {$np >= $mergemax} {
4682 set tag mmax
4683 } else {
4684 set tag m$np
4686 $ctext insert end "Parent: " $tag
4687 appendwithlinks [commit_descriptor $p] {}
4688 incr np
4690 } else {
4691 foreach p $olds {
4692 append headers "Parent: [commit_descriptor $p]"
4696 foreach c $children($curview,$id) {
4697 append headers "Child: [commit_descriptor $c]"
4700 # make anything that looks like a SHA1 ID be a clickable link
4701 appendwithlinks $headers {}
4702 if {$showneartags} {
4703 if {![info exists allcommits]} {
4704 getallcommits
4706 $ctext insert end "Branch: "
4707 $ctext mark set branch "end -1c"
4708 $ctext mark gravity branch left
4709 $ctext insert end "\nFollows: "
4710 $ctext mark set follows "end -1c"
4711 $ctext mark gravity follows left
4712 $ctext insert end "\nPrecedes: "
4713 $ctext mark set precedes "end -1c"
4714 $ctext mark gravity precedes left
4715 $ctext insert end "\n"
4716 dispneartags 1
4718 $ctext insert end "\n"
4719 set comment [lindex $info 5]
4720 if {[string first "\r" $comment] >= 0} {
4721 set comment [string map {"\r" "\n "} $comment]
4723 appendwithlinks $comment {comment}
4725 $ctext tag remove found 1.0 end
4726 $ctext conf -state disabled
4727 set commentend [$ctext index "end - 1c"]
4729 init_flist "Comments"
4730 if {$cmitmode eq "tree"} {
4731 gettree $id
4732 } elseif {[llength $olds] <= 1} {
4733 startdiff $id
4734 } else {
4735 mergediff $id $l
4739 proc selfirstline {} {
4740 unmarkmatches
4741 selectline 0 1
4744 proc sellastline {} {
4745 global numcommits
4746 unmarkmatches
4747 set l [expr {$numcommits - 1}]
4748 selectline $l 1
4751 proc selnextline {dir} {
4752 global selectedline
4753 focus .
4754 if {![info exists selectedline]} return
4755 set l [expr {$selectedline + $dir}]
4756 unmarkmatches
4757 selectline $l 1
4760 proc selnextpage {dir} {
4761 global canv linespc selectedline numcommits
4763 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4764 if {$lpp < 1} {
4765 set lpp 1
4767 allcanvs yview scroll [expr {$dir * $lpp}] units
4768 drawvisible
4769 if {![info exists selectedline]} return
4770 set l [expr {$selectedline + $dir * $lpp}]
4771 if {$l < 0} {
4772 set l 0
4773 } elseif {$l >= $numcommits} {
4774 set l [expr $numcommits - 1]
4776 unmarkmatches
4777 selectline $l 1
4780 proc unselectline {} {
4781 global selectedline currentid
4783 catch {unset selectedline}
4784 catch {unset currentid}
4785 allcanvs delete secsel
4786 rhighlight_none
4787 cancel_next_highlight
4790 proc reselectline {} {
4791 global selectedline
4793 if {[info exists selectedline]} {
4794 selectline $selectedline 0
4798 proc addtohistory {cmd} {
4799 global history historyindex curview
4801 set elt [list $curview $cmd]
4802 if {$historyindex > 0
4803 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4804 return
4807 if {$historyindex < [llength $history]} {
4808 set history [lreplace $history $historyindex end $elt]
4809 } else {
4810 lappend history $elt
4812 incr historyindex
4813 if {$historyindex > 1} {
4814 .tf.bar.leftbut conf -state normal
4815 } else {
4816 .tf.bar.leftbut conf -state disabled
4818 .tf.bar.rightbut conf -state disabled
4821 proc godo {elt} {
4822 global curview
4824 set view [lindex $elt 0]
4825 set cmd [lindex $elt 1]
4826 if {$curview != $view} {
4827 showview $view
4829 eval $cmd
4832 proc goback {} {
4833 global history historyindex
4834 focus .
4836 if {$historyindex > 1} {
4837 incr historyindex -1
4838 godo [lindex $history [expr {$historyindex - 1}]]
4839 .tf.bar.rightbut conf -state normal
4841 if {$historyindex <= 1} {
4842 .tf.bar.leftbut conf -state disabled
4846 proc goforw {} {
4847 global history historyindex
4848 focus .
4850 if {$historyindex < [llength $history]} {
4851 set cmd [lindex $history $historyindex]
4852 incr historyindex
4853 godo $cmd
4854 .tf.bar.leftbut conf -state normal
4856 if {$historyindex >= [llength $history]} {
4857 .tf.bar.rightbut conf -state disabled
4861 proc gettree {id} {
4862 global treefilelist treeidlist diffids diffmergeid treepending
4863 global nullid nullid2
4865 set diffids $id
4866 catch {unset diffmergeid}
4867 if {![info exists treefilelist($id)]} {
4868 if {![info exists treepending]} {
4869 if {$id eq $nullid} {
4870 set cmd [list | git ls-files]
4871 } elseif {$id eq $nullid2} {
4872 set cmd [list | git ls-files --stage -t]
4873 } else {
4874 set cmd [list | git ls-tree -r $id]
4876 if {[catch {set gtf [open $cmd r]}]} {
4877 return
4879 set treepending $id
4880 set treefilelist($id) {}
4881 set treeidlist($id) {}
4882 fconfigure $gtf -blocking 0
4883 filerun $gtf [list gettreeline $gtf $id]
4885 } else {
4886 setfilelist $id
4890 proc gettreeline {gtf id} {
4891 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4893 set nl 0
4894 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4895 if {$diffids eq $nullid} {
4896 set fname $line
4897 } else {
4898 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4899 set i [string first "\t" $line]
4900 if {$i < 0} continue
4901 set sha1 [lindex $line 2]
4902 set fname [string range $line [expr {$i+1}] end]
4903 if {[string index $fname 0] eq "\""} {
4904 set fname [lindex $fname 0]
4906 lappend treeidlist($id) $sha1
4908 lappend treefilelist($id) $fname
4910 if {![eof $gtf]} {
4911 return [expr {$nl >= 1000? 2: 1}]
4913 close $gtf
4914 unset treepending
4915 if {$cmitmode ne "tree"} {
4916 if {![info exists diffmergeid]} {
4917 gettreediffs $diffids
4919 } elseif {$id ne $diffids} {
4920 gettree $diffids
4921 } else {
4922 setfilelist $id
4924 return 0
4927 proc showfile {f} {
4928 global treefilelist treeidlist diffids nullid nullid2
4929 global ctext commentend
4931 set i [lsearch -exact $treefilelist($diffids) $f]
4932 if {$i < 0} {
4933 puts "oops, $f not in list for id $diffids"
4934 return
4936 if {$diffids eq $nullid} {
4937 if {[catch {set bf [open $f r]} err]} {
4938 puts "oops, can't read $f: $err"
4939 return
4941 } else {
4942 set blob [lindex $treeidlist($diffids) $i]
4943 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4944 puts "oops, error reading blob $blob: $err"
4945 return
4948 fconfigure $bf -blocking 0
4949 filerun $bf [list getblobline $bf $diffids]
4950 $ctext config -state normal
4951 clear_ctext $commentend
4952 $ctext insert end "\n"
4953 $ctext insert end "$f\n" filesep
4954 $ctext config -state disabled
4955 $ctext yview $commentend
4958 proc getblobline {bf id} {
4959 global diffids cmitmode ctext
4961 if {$id ne $diffids || $cmitmode ne "tree"} {
4962 catch {close $bf}
4963 return 0
4965 $ctext config -state normal
4966 set nl 0
4967 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4968 $ctext insert end "$line\n"
4970 if {[eof $bf]} {
4971 # delete last newline
4972 $ctext delete "end - 2c" "end - 1c"
4973 close $bf
4974 return 0
4976 $ctext config -state disabled
4977 return [expr {$nl >= 1000? 2: 1}]
4980 proc mergediff {id l} {
4981 global diffmergeid diffopts mdifffd
4982 global diffids
4983 global parentlist
4985 set diffmergeid $id
4986 set diffids $id
4987 # this doesn't seem to actually affect anything...
4988 set env(GIT_DIFF_OPTS) $diffopts
4989 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4990 if {[catch {set mdf [open $cmd r]} err]} {
4991 error_popup "Error getting merge diffs: $err"
4992 return
4994 fconfigure $mdf -blocking 0
4995 set mdifffd($id) $mdf
4996 set np [llength [lindex $parentlist $l]]
4997 filerun $mdf [list getmergediffline $mdf $id $np]
5000 proc getmergediffline {mdf id np} {
5001 global diffmergeid ctext cflist mergemax
5002 global difffilestart mdifffd
5004 $ctext conf -state normal
5005 set nr 0
5006 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5007 if {![info exists diffmergeid] || $id != $diffmergeid
5008 || $mdf != $mdifffd($id)} {
5009 close $mdf
5010 return 0
5012 if {[regexp {^diff --cc (.*)} $line match fname]} {
5013 # start of a new file
5014 $ctext insert end "\n"
5015 set here [$ctext index "end - 1c"]
5016 lappend difffilestart $here
5017 add_flist [list $fname]
5018 set l [expr {(78 - [string length $fname]) / 2}]
5019 set pad [string range "----------------------------------------" 1 $l]
5020 $ctext insert end "$pad $fname $pad\n" filesep
5021 } elseif {[regexp {^@@} $line]} {
5022 $ctext insert end "$line\n" hunksep
5023 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5024 # do nothing
5025 } else {
5026 # parse the prefix - one ' ', '-' or '+' for each parent
5027 set spaces {}
5028 set minuses {}
5029 set pluses {}
5030 set isbad 0
5031 for {set j 0} {$j < $np} {incr j} {
5032 set c [string range $line $j $j]
5033 if {$c == " "} {
5034 lappend spaces $j
5035 } elseif {$c == "-"} {
5036 lappend minuses $j
5037 } elseif {$c == "+"} {
5038 lappend pluses $j
5039 } else {
5040 set isbad 1
5041 break
5044 set tags {}
5045 set num {}
5046 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5047 # line doesn't appear in result, parents in $minuses have the line
5048 set num [lindex $minuses 0]
5049 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5050 # line appears in result, parents in $pluses don't have the line
5051 lappend tags mresult
5052 set num [lindex $spaces 0]
5054 if {$num ne {}} {
5055 if {$num >= $mergemax} {
5056 set num "max"
5058 lappend tags m$num
5060 $ctext insert end "$line\n" $tags
5063 $ctext conf -state disabled
5064 if {[eof $mdf]} {
5065 close $mdf
5066 return 0
5068 return [expr {$nr >= 1000? 2: 1}]
5071 proc startdiff {ids} {
5072 global treediffs diffids treepending diffmergeid nullid nullid2
5074 set diffids $ids
5075 catch {unset diffmergeid}
5076 if {![info exists treediffs($ids)] ||
5077 [lsearch -exact $ids $nullid] >= 0 ||
5078 [lsearch -exact $ids $nullid2] >= 0} {
5079 if {![info exists treepending]} {
5080 gettreediffs $ids
5082 } else {
5083 addtocflist $ids
5087 proc addtocflist {ids} {
5088 global treediffs cflist
5089 add_flist $treediffs($ids)
5090 getblobdiffs $ids
5093 proc diffcmd {ids flags} {
5094 global nullid nullid2
5096 set i [lsearch -exact $ids $nullid]
5097 set j [lsearch -exact $ids $nullid2]
5098 if {$i >= 0} {
5099 if {[llength $ids] > 1 && $j < 0} {
5100 # comparing working directory with some specific revision
5101 set cmd [concat | git diff-index $flags]
5102 if {$i == 0} {
5103 lappend cmd -R [lindex $ids 1]
5104 } else {
5105 lappend cmd [lindex $ids 0]
5107 } else {
5108 # comparing working directory with index
5109 set cmd [concat | git diff-files $flags]
5110 if {$j == 1} {
5111 lappend cmd -R
5114 } elseif {$j >= 0} {
5115 set cmd [concat | git diff-index --cached $flags]
5116 if {[llength $ids] > 1} {
5117 # comparing index with specific revision
5118 if {$i == 0} {
5119 lappend cmd -R [lindex $ids 1]
5120 } else {
5121 lappend cmd [lindex $ids 0]
5123 } else {
5124 # comparing index with HEAD
5125 lappend cmd HEAD
5127 } else {
5128 set cmd [concat | git diff-tree -r $flags $ids]
5130 return $cmd
5133 proc gettreediffs {ids} {
5134 global treediff treepending
5136 set treepending $ids
5137 set treediff {}
5138 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5139 fconfigure $gdtf -blocking 0
5140 filerun $gdtf [list gettreediffline $gdtf $ids]
5143 proc gettreediffline {gdtf ids} {
5144 global treediff treediffs treepending diffids diffmergeid
5145 global cmitmode
5147 set nr 0
5148 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5149 set i [string first "\t" $line]
5150 if {$i >= 0} {
5151 set file [string range $line [expr {$i+1}] end]
5152 if {[string index $file 0] eq "\""} {
5153 set file [lindex $file 0]
5155 lappend treediff $file
5158 if {![eof $gdtf]} {
5159 return [expr {$nr >= 1000? 2: 1}]
5161 close $gdtf
5162 set treediffs($ids) $treediff
5163 unset treepending
5164 if {$cmitmode eq "tree"} {
5165 gettree $diffids
5166 } elseif {$ids != $diffids} {
5167 if {![info exists diffmergeid]} {
5168 gettreediffs $diffids
5170 } else {
5171 addtocflist $ids
5173 return 0
5176 # empty string or positive integer
5177 proc diffcontextvalidate {v} {
5178 return [regexp {^(|[1-9][0-9]*)$} $v]
5181 proc diffcontextchange {n1 n2 op} {
5182 global diffcontextstring diffcontext
5184 if {[string is integer -strict $diffcontextstring]} {
5185 if {$diffcontextstring > 0} {
5186 set diffcontext $diffcontextstring
5187 reselectline
5192 proc getblobdiffs {ids} {
5193 global diffopts blobdifffd diffids env
5194 global diffinhdr treediffs
5195 global diffcontext
5197 set env(GIT_DIFF_OPTS) $diffopts
5198 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5199 puts "error getting diffs: $err"
5200 return
5202 set diffinhdr 0
5203 fconfigure $bdf -blocking 0
5204 set blobdifffd($ids) $bdf
5205 filerun $bdf [list getblobdiffline $bdf $diffids]
5208 proc setinlist {var i val} {
5209 global $var
5211 while {[llength [set $var]] < $i} {
5212 lappend $var {}
5214 if {[llength [set $var]] == $i} {
5215 lappend $var $val
5216 } else {
5217 lset $var $i $val
5221 proc makediffhdr {fname ids} {
5222 global ctext curdiffstart treediffs
5224 set i [lsearch -exact $treediffs($ids) $fname]
5225 if {$i >= 0} {
5226 setinlist difffilestart $i $curdiffstart
5228 set l [expr {(78 - [string length $fname]) / 2}]
5229 set pad [string range "----------------------------------------" 1 $l]
5230 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5233 proc getblobdiffline {bdf ids} {
5234 global diffids blobdifffd ctext curdiffstart
5235 global diffnexthead diffnextnote difffilestart
5236 global diffinhdr treediffs
5238 set nr 0
5239 $ctext conf -state normal
5240 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5241 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5242 close $bdf
5243 return 0
5245 if {![string compare -length 11 "diff --git " $line]} {
5246 # trim off "diff --git "
5247 set line [string range $line 11 end]
5248 set diffinhdr 1
5249 # start of a new file
5250 $ctext insert end "\n"
5251 set curdiffstart [$ctext index "end - 1c"]
5252 $ctext insert end "\n" filesep
5253 # If the name hasn't changed the length will be odd,
5254 # the middle char will be a space, and the two bits either
5255 # side will be a/name and b/name, or "a/name" and "b/name".
5256 # If the name has changed we'll get "rename from" and
5257 # "rename to" or "copy from" and "copy to" lines following this,
5258 # and we'll use them to get the filenames.
5259 # This complexity is necessary because spaces in the filename(s)
5260 # don't get escaped.
5261 set l [string length $line]
5262 set i [expr {$l / 2}]
5263 if {!(($l & 1) && [string index $line $i] eq " " &&
5264 [string range $line 2 [expr {$i - 1}]] eq \
5265 [string range $line [expr {$i + 3}] end])} {
5266 continue
5268 # unescape if quoted and chop off the a/ from the front
5269 if {[string index $line 0] eq "\""} {
5270 set fname [string range [lindex $line 0] 2 end]
5271 } else {
5272 set fname [string range $line 2 [expr {$i - 1}]]
5274 makediffhdr $fname $ids
5276 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5277 $line match f1l f1c f2l f2c rest]} {
5278 $ctext insert end "$line\n" hunksep
5279 set diffinhdr 0
5281 } elseif {$diffinhdr} {
5282 if {![string compare -length 12 "rename from " $line] ||
5283 ![string compare -length 10 "copy from " $line]} {
5284 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5285 if {[string index $fname 0] eq "\""} {
5286 set fname [lindex $fname 0]
5288 set i [lsearch -exact $treediffs($ids) $fname]
5289 if {$i >= 0} {
5290 setinlist difffilestart $i $curdiffstart
5292 } elseif {![string compare -length 10 $line "rename to "] ||
5293 ![string compare -length 8 $line "copy to "]} {
5294 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5295 if {[string index $fname 0] eq "\""} {
5296 set fname [lindex $fname 0]
5298 makediffhdr $fname $ids
5299 } elseif {[string compare -length 3 $line "---"] == 0} {
5300 # do nothing
5301 continue
5302 } elseif {[string compare -length 3 $line "+++"] == 0} {
5303 set diffinhdr 0
5304 continue
5306 $ctext insert end "$line\n" filesep
5308 } else {
5309 set x [string range $line 0 0]
5310 if {$x == "-" || $x == "+"} {
5311 set tag [expr {$x == "+"}]
5312 $ctext insert end "$line\n" d$tag
5313 } elseif {$x == " "} {
5314 $ctext insert end "$line\n"
5315 } else {
5316 # "\ No newline at end of file",
5317 # or something else we don't recognize
5318 $ctext insert end "$line\n" hunksep
5322 $ctext conf -state disabled
5323 if {[eof $bdf]} {
5324 close $bdf
5325 return 0
5327 return [expr {$nr >= 1000? 2: 1}]
5330 proc changediffdisp {} {
5331 global ctext diffelide
5333 $ctext tag conf d0 -elide [lindex $diffelide 0]
5334 $ctext tag conf d1 -elide [lindex $diffelide 1]
5337 proc prevfile {} {
5338 global difffilestart ctext
5339 set prev [lindex $difffilestart 0]
5340 set here [$ctext index @0,0]
5341 foreach loc $difffilestart {
5342 if {[$ctext compare $loc >= $here]} {
5343 $ctext yview $prev
5344 return
5346 set prev $loc
5348 $ctext yview $prev
5351 proc nextfile {} {
5352 global difffilestart ctext
5353 set here [$ctext index @0,0]
5354 foreach loc $difffilestart {
5355 if {[$ctext compare $loc > $here]} {
5356 $ctext yview $loc
5357 return
5362 proc clear_ctext {{first 1.0}} {
5363 global ctext smarktop smarkbot
5364 global pendinglinks
5366 set l [lindex [split $first .] 0]
5367 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5368 set smarktop $l
5370 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5371 set smarkbot $l
5373 $ctext delete $first end
5374 if {$first eq "1.0"} {
5375 catch {unset pendinglinks}
5379 proc incrsearch {name ix op} {
5380 global ctext searchstring searchdirn
5382 $ctext tag remove found 1.0 end
5383 if {[catch {$ctext index anchor}]} {
5384 # no anchor set, use start of selection, or of visible area
5385 set sel [$ctext tag ranges sel]
5386 if {$sel ne {}} {
5387 $ctext mark set anchor [lindex $sel 0]
5388 } elseif {$searchdirn eq "-forwards"} {
5389 $ctext mark set anchor @0,0
5390 } else {
5391 $ctext mark set anchor @0,[winfo height $ctext]
5394 if {$searchstring ne {}} {
5395 set here [$ctext search $searchdirn -- $searchstring anchor]
5396 if {$here ne {}} {
5397 $ctext see $here
5399 searchmarkvisible 1
5403 proc dosearch {} {
5404 global sstring ctext searchstring searchdirn
5406 focus $sstring
5407 $sstring icursor end
5408 set searchdirn -forwards
5409 if {$searchstring ne {}} {
5410 set sel [$ctext tag ranges sel]
5411 if {$sel ne {}} {
5412 set start "[lindex $sel 0] + 1c"
5413 } elseif {[catch {set start [$ctext index anchor]}]} {
5414 set start "@0,0"
5416 set match [$ctext search -count mlen -- $searchstring $start]
5417 $ctext tag remove sel 1.0 end
5418 if {$match eq {}} {
5419 bell
5420 return
5422 $ctext see $match
5423 set mend "$match + $mlen c"
5424 $ctext tag add sel $match $mend
5425 $ctext mark unset anchor
5429 proc dosearchback {} {
5430 global sstring ctext searchstring searchdirn
5432 focus $sstring
5433 $sstring icursor end
5434 set searchdirn -backwards
5435 if {$searchstring ne {}} {
5436 set sel [$ctext tag ranges sel]
5437 if {$sel ne {}} {
5438 set start [lindex $sel 0]
5439 } elseif {[catch {set start [$ctext index anchor]}]} {
5440 set start @0,[winfo height $ctext]
5442 set match [$ctext search -backwards -count ml -- $searchstring $start]
5443 $ctext tag remove sel 1.0 end
5444 if {$match eq {}} {
5445 bell
5446 return
5448 $ctext see $match
5449 set mend "$match + $ml c"
5450 $ctext tag add sel $match $mend
5451 $ctext mark unset anchor
5455 proc searchmark {first last} {
5456 global ctext searchstring
5458 set mend $first.0
5459 while {1} {
5460 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5461 if {$match eq {}} break
5462 set mend "$match + $mlen c"
5463 $ctext tag add found $match $mend
5467 proc searchmarkvisible {doall} {
5468 global ctext smarktop smarkbot
5470 set topline [lindex [split [$ctext index @0,0] .] 0]
5471 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5472 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5473 # no overlap with previous
5474 searchmark $topline $botline
5475 set smarktop $topline
5476 set smarkbot $botline
5477 } else {
5478 if {$topline < $smarktop} {
5479 searchmark $topline [expr {$smarktop-1}]
5480 set smarktop $topline
5482 if {$botline > $smarkbot} {
5483 searchmark [expr {$smarkbot+1}] $botline
5484 set smarkbot $botline
5489 proc scrolltext {f0 f1} {
5490 global searchstring
5492 .bleft.sb set $f0 $f1
5493 if {$searchstring ne {}} {
5494 searchmarkvisible 0
5498 proc setcoords {} {
5499 global linespc charspc canvx0 canvy0 mainfont
5500 global xspc1 xspc2 lthickness
5502 set linespc [font metrics $mainfont -linespace]
5503 set charspc [font measure $mainfont "m"]
5504 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5505 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5506 set lthickness [expr {int($linespc / 9) + 1}]
5507 set xspc1(0) $linespc
5508 set xspc2 $linespc
5511 proc redisplay {} {
5512 global canv
5513 global selectedline
5515 set ymax [lindex [$canv cget -scrollregion] 3]
5516 if {$ymax eq {} || $ymax == 0} return
5517 set span [$canv yview]
5518 clear_display
5519 setcanvscroll
5520 allcanvs yview moveto [lindex $span 0]
5521 drawvisible
5522 if {[info exists selectedline]} {
5523 selectline $selectedline 0
5524 allcanvs yview moveto [lindex $span 0]
5528 proc incrfont {inc} {
5529 global mainfont textfont ctext canv phase cflist showrefstop
5530 global charspc tabstop
5531 global stopped entries
5532 unmarkmatches
5533 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5534 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5535 setcoords
5536 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5537 $cflist conf -font $textfont
5538 $ctext tag conf filesep -font [concat $textfont bold]
5539 foreach e $entries {
5540 $e conf -font $mainfont
5542 if {$phase eq "getcommits"} {
5543 $canv itemconf textitems -font $mainfont
5545 if {[info exists showrefstop] && [winfo exists $showrefstop]} {
5546 $showrefstop.list conf -font $mainfont
5548 redisplay
5551 proc clearsha1 {} {
5552 global sha1entry sha1string
5553 if {[string length $sha1string] == 40} {
5554 $sha1entry delete 0 end
5558 proc sha1change {n1 n2 op} {
5559 global sha1string currentid sha1but
5560 if {$sha1string == {}
5561 || ([info exists currentid] && $sha1string == $currentid)} {
5562 set state disabled
5563 } else {
5564 set state normal
5566 if {[$sha1but cget -state] == $state} return
5567 if {$state == "normal"} {
5568 $sha1but conf -state normal -relief raised -text "Goto: "
5569 } else {
5570 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5574 proc gotocommit {} {
5575 global sha1string currentid commitrow tagids headids
5576 global displayorder numcommits curview
5578 if {$sha1string == {}
5579 || ([info exists currentid] && $sha1string == $currentid)} return
5580 if {[info exists tagids($sha1string)]} {
5581 set id $tagids($sha1string)
5582 } elseif {[info exists headids($sha1string)]} {
5583 set id $headids($sha1string)
5584 } else {
5585 set id [string tolower $sha1string]
5586 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5587 set matches {}
5588 foreach i $displayorder {
5589 if {[string match $id* $i]} {
5590 lappend matches $i
5593 if {$matches ne {}} {
5594 if {[llength $matches] > 1} {
5595 error_popup "Short SHA1 id $id is ambiguous"
5596 return
5598 set id [lindex $matches 0]
5602 if {[info exists commitrow($curview,$id)]} {
5603 selectline $commitrow($curview,$id) 1
5604 return
5606 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5607 set type "SHA1 id"
5608 } else {
5609 set type "Tag/Head"
5611 error_popup "$type $sha1string is not known"
5614 proc lineenter {x y id} {
5615 global hoverx hovery hoverid hovertimer
5616 global commitinfo canv
5618 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5619 set hoverx $x
5620 set hovery $y
5621 set hoverid $id
5622 if {[info exists hovertimer]} {
5623 after cancel $hovertimer
5625 set hovertimer [after 500 linehover]
5626 $canv delete hover
5629 proc linemotion {x y id} {
5630 global hoverx hovery hoverid hovertimer
5632 if {[info exists hoverid] && $id == $hoverid} {
5633 set hoverx $x
5634 set hovery $y
5635 if {[info exists hovertimer]} {
5636 after cancel $hovertimer
5638 set hovertimer [after 500 linehover]
5642 proc lineleave {id} {
5643 global hoverid hovertimer canv
5645 if {[info exists hoverid] && $id == $hoverid} {
5646 $canv delete hover
5647 if {[info exists hovertimer]} {
5648 after cancel $hovertimer
5649 unset hovertimer
5651 unset hoverid
5655 proc linehover {} {
5656 global hoverx hovery hoverid hovertimer
5657 global canv linespc lthickness
5658 global commitinfo mainfont
5660 set text [lindex $commitinfo($hoverid) 0]
5661 set ymax [lindex [$canv cget -scrollregion] 3]
5662 if {$ymax == {}} return
5663 set yfrac [lindex [$canv yview] 0]
5664 set x [expr {$hoverx + 2 * $linespc}]
5665 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5666 set x0 [expr {$x - 2 * $lthickness}]
5667 set y0 [expr {$y - 2 * $lthickness}]
5668 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5669 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5670 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5671 -fill \#ffff80 -outline black -width 1 -tags hover]
5672 $canv raise $t
5673 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5674 -font $mainfont]
5675 $canv raise $t
5678 proc clickisonarrow {id y} {
5679 global lthickness
5681 set ranges [rowranges $id]
5682 set thresh [expr {2 * $lthickness + 6}]
5683 set n [expr {[llength $ranges] - 1}]
5684 for {set i 1} {$i < $n} {incr i} {
5685 set row [lindex $ranges $i]
5686 if {abs([yc $row] - $y) < $thresh} {
5687 return $i
5690 return {}
5693 proc arrowjump {id n y} {
5694 global canv
5696 # 1 <-> 2, 3 <-> 4, etc...
5697 set n [expr {(($n - 1) ^ 1) + 1}]
5698 set row [lindex [rowranges $id] $n]
5699 set yt [yc $row]
5700 set ymax [lindex [$canv cget -scrollregion] 3]
5701 if {$ymax eq {} || $ymax <= 0} return
5702 set view [$canv yview]
5703 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5704 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5705 if {$yfrac < 0} {
5706 set yfrac 0
5708 allcanvs yview moveto $yfrac
5711 proc lineclick {x y id isnew} {
5712 global ctext commitinfo children canv thickerline curview commitrow
5714 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5715 unmarkmatches
5716 unselectline
5717 normalline
5718 $canv delete hover
5719 # draw this line thicker than normal
5720 set thickerline $id
5721 drawlines $id
5722 if {$isnew} {
5723 set ymax [lindex [$canv cget -scrollregion] 3]
5724 if {$ymax eq {}} return
5725 set yfrac [lindex [$canv yview] 0]
5726 set y [expr {$y + $yfrac * $ymax}]
5728 set dirn [clickisonarrow $id $y]
5729 if {$dirn ne {}} {
5730 arrowjump $id $dirn $y
5731 return
5734 if {$isnew} {
5735 addtohistory [list lineclick $x $y $id 0]
5737 # fill the details pane with info about this line
5738 $ctext conf -state normal
5739 clear_ctext
5740 $ctext insert end "Parent:\t"
5741 $ctext insert end $id link0
5742 setlink $id link0
5743 set info $commitinfo($id)
5744 $ctext insert end "\n\t[lindex $info 0]\n"
5745 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5746 set date [formatdate [lindex $info 2]]
5747 $ctext insert end "\tDate:\t$date\n"
5748 set kids $children($curview,$id)
5749 if {$kids ne {}} {
5750 $ctext insert end "\nChildren:"
5751 set i 0
5752 foreach child $kids {
5753 incr i
5754 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5755 set info $commitinfo($child)
5756 $ctext insert end "\n\t"
5757 $ctext insert end $child link$i
5758 setlink $child link$i
5759 $ctext insert end "\n\t[lindex $info 0]"
5760 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5761 set date [formatdate [lindex $info 2]]
5762 $ctext insert end "\n\tDate:\t$date\n"
5765 $ctext conf -state disabled
5766 init_flist {}
5769 proc normalline {} {
5770 global thickerline
5771 if {[info exists thickerline]} {
5772 set id $thickerline
5773 unset thickerline
5774 drawlines $id
5778 proc selbyid {id} {
5779 global commitrow curview
5780 if {[info exists commitrow($curview,$id)]} {
5781 selectline $commitrow($curview,$id) 1
5785 proc mstime {} {
5786 global startmstime
5787 if {![info exists startmstime]} {
5788 set startmstime [clock clicks -milliseconds]
5790 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5793 proc rowmenu {x y id} {
5794 global rowctxmenu commitrow selectedline rowmenuid curview
5795 global nullid nullid2 fakerowmenu mainhead
5797 set rowmenuid $id
5798 if {![info exists selectedline]
5799 || $commitrow($curview,$id) eq $selectedline} {
5800 set state disabled
5801 } else {
5802 set state normal
5804 if {$id ne $nullid && $id ne $nullid2} {
5805 set menu $rowctxmenu
5806 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5807 } else {
5808 set menu $fakerowmenu
5810 $menu entryconfigure "Diff this*" -state $state
5811 $menu entryconfigure "Diff selected*" -state $state
5812 $menu entryconfigure "Make patch" -state $state
5813 tk_popup $menu $x $y
5816 proc diffvssel {dirn} {
5817 global rowmenuid selectedline displayorder
5819 if {![info exists selectedline]} return
5820 if {$dirn} {
5821 set oldid [lindex $displayorder $selectedline]
5822 set newid $rowmenuid
5823 } else {
5824 set oldid $rowmenuid
5825 set newid [lindex $displayorder $selectedline]
5827 addtohistory [list doseldiff $oldid $newid]
5828 doseldiff $oldid $newid
5831 proc doseldiff {oldid newid} {
5832 global ctext
5833 global commitinfo
5835 $ctext conf -state normal
5836 clear_ctext
5837 init_flist "Top"
5838 $ctext insert end "From "
5839 $ctext insert end $oldid link0
5840 setlink $oldid link0
5841 $ctext insert end "\n "
5842 $ctext insert end [lindex $commitinfo($oldid) 0]
5843 $ctext insert end "\n\nTo "
5844 $ctext insert end $newid link1
5845 setlink $newid link1
5846 $ctext insert end "\n "
5847 $ctext insert end [lindex $commitinfo($newid) 0]
5848 $ctext insert end "\n"
5849 $ctext conf -state disabled
5850 $ctext tag remove found 1.0 end
5851 startdiff [list $oldid $newid]
5854 proc mkpatch {} {
5855 global rowmenuid currentid commitinfo patchtop patchnum
5857 if {![info exists currentid]} return
5858 set oldid $currentid
5859 set oldhead [lindex $commitinfo($oldid) 0]
5860 set newid $rowmenuid
5861 set newhead [lindex $commitinfo($newid) 0]
5862 set top .patch
5863 set patchtop $top
5864 catch {destroy $top}
5865 toplevel $top
5866 label $top.title -text "Generate patch"
5867 grid $top.title - -pady 10
5868 label $top.from -text "From:"
5869 entry $top.fromsha1 -width 40 -relief flat
5870 $top.fromsha1 insert 0 $oldid
5871 $top.fromsha1 conf -state readonly
5872 grid $top.from $top.fromsha1 -sticky w
5873 entry $top.fromhead -width 60 -relief flat
5874 $top.fromhead insert 0 $oldhead
5875 $top.fromhead conf -state readonly
5876 grid x $top.fromhead -sticky w
5877 label $top.to -text "To:"
5878 entry $top.tosha1 -width 40 -relief flat
5879 $top.tosha1 insert 0 $newid
5880 $top.tosha1 conf -state readonly
5881 grid $top.to $top.tosha1 -sticky w
5882 entry $top.tohead -width 60 -relief flat
5883 $top.tohead insert 0 $newhead
5884 $top.tohead conf -state readonly
5885 grid x $top.tohead -sticky w
5886 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5887 grid $top.rev x -pady 10
5888 label $top.flab -text "Output file:"
5889 entry $top.fname -width 60
5890 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5891 incr patchnum
5892 grid $top.flab $top.fname -sticky w
5893 frame $top.buts
5894 button $top.buts.gen -text "Generate" -command mkpatchgo
5895 button $top.buts.can -text "Cancel" -command mkpatchcan
5896 grid $top.buts.gen $top.buts.can
5897 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5898 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5899 grid $top.buts - -pady 10 -sticky ew
5900 focus $top.fname
5903 proc mkpatchrev {} {
5904 global patchtop
5906 set oldid [$patchtop.fromsha1 get]
5907 set oldhead [$patchtop.fromhead get]
5908 set newid [$patchtop.tosha1 get]
5909 set newhead [$patchtop.tohead get]
5910 foreach e [list fromsha1 fromhead tosha1 tohead] \
5911 v [list $newid $newhead $oldid $oldhead] {
5912 $patchtop.$e conf -state normal
5913 $patchtop.$e delete 0 end
5914 $patchtop.$e insert 0 $v
5915 $patchtop.$e conf -state readonly
5919 proc mkpatchgo {} {
5920 global patchtop nullid nullid2
5922 set oldid [$patchtop.fromsha1 get]
5923 set newid [$patchtop.tosha1 get]
5924 set fname [$patchtop.fname get]
5925 set cmd [diffcmd [list $oldid $newid] -p]
5926 lappend cmd >$fname &
5927 if {[catch {eval exec $cmd} err]} {
5928 error_popup "Error creating patch: $err"
5930 catch {destroy $patchtop}
5931 unset patchtop
5934 proc mkpatchcan {} {
5935 global patchtop
5937 catch {destroy $patchtop}
5938 unset patchtop
5941 proc mktag {} {
5942 global rowmenuid mktagtop commitinfo
5944 set top .maketag
5945 set mktagtop $top
5946 catch {destroy $top}
5947 toplevel $top
5948 label $top.title -text "Create tag"
5949 grid $top.title - -pady 10
5950 label $top.id -text "ID:"
5951 entry $top.sha1 -width 40 -relief flat
5952 $top.sha1 insert 0 $rowmenuid
5953 $top.sha1 conf -state readonly
5954 grid $top.id $top.sha1 -sticky w
5955 entry $top.head -width 60 -relief flat
5956 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5957 $top.head conf -state readonly
5958 grid x $top.head -sticky w
5959 label $top.tlab -text "Tag name:"
5960 entry $top.tag -width 60
5961 grid $top.tlab $top.tag -sticky w
5962 frame $top.buts
5963 button $top.buts.gen -text "Create" -command mktaggo
5964 button $top.buts.can -text "Cancel" -command mktagcan
5965 grid $top.buts.gen $top.buts.can
5966 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5967 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5968 grid $top.buts - -pady 10 -sticky ew
5969 focus $top.tag
5972 proc domktag {} {
5973 global mktagtop env tagids idtags
5975 set id [$mktagtop.sha1 get]
5976 set tag [$mktagtop.tag get]
5977 if {$tag == {}} {
5978 error_popup "No tag name specified"
5979 return
5981 if {[info exists tagids($tag)]} {
5982 error_popup "Tag \"$tag\" already exists"
5983 return
5985 if {[catch {
5986 set dir [gitdir]
5987 set fname [file join $dir "refs/tags" $tag]
5988 set f [open $fname w]
5989 puts $f $id
5990 close $f
5991 } err]} {
5992 error_popup "Error creating tag: $err"
5993 return
5996 set tagids($tag) $id
5997 lappend idtags($id) $tag
5998 redrawtags $id
5999 addedtag $id
6000 dispneartags 0
6001 run refill_reflist
6004 proc redrawtags {id} {
6005 global canv linehtag commitrow idpos selectedline curview
6006 global mainfont canvxmax iddrawn
6008 if {![info exists commitrow($curview,$id)]} return
6009 if {![info exists iddrawn($id)]} return
6010 drawcommits $commitrow($curview,$id)
6011 $canv delete tag.$id
6012 set xt [eval drawtags $id $idpos($id)]
6013 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6014 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6015 set xr [expr {$xt + [font measure $mainfont $text]}]
6016 if {$xr > $canvxmax} {
6017 set canvxmax $xr
6018 setcanvscroll
6020 if {[info exists selectedline]
6021 && $selectedline == $commitrow($curview,$id)} {
6022 selectline $selectedline 0
6026 proc mktagcan {} {
6027 global mktagtop
6029 catch {destroy $mktagtop}
6030 unset mktagtop
6033 proc mktaggo {} {
6034 domktag
6035 mktagcan
6038 proc writecommit {} {
6039 global rowmenuid wrcomtop commitinfo wrcomcmd
6041 set top .writecommit
6042 set wrcomtop $top
6043 catch {destroy $top}
6044 toplevel $top
6045 label $top.title -text "Write commit to file"
6046 grid $top.title - -pady 10
6047 label $top.id -text "ID:"
6048 entry $top.sha1 -width 40 -relief flat
6049 $top.sha1 insert 0 $rowmenuid
6050 $top.sha1 conf -state readonly
6051 grid $top.id $top.sha1 -sticky w
6052 entry $top.head -width 60 -relief flat
6053 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6054 $top.head conf -state readonly
6055 grid x $top.head -sticky w
6056 label $top.clab -text "Command:"
6057 entry $top.cmd -width 60 -textvariable wrcomcmd
6058 grid $top.clab $top.cmd -sticky w -pady 10
6059 label $top.flab -text "Output file:"
6060 entry $top.fname -width 60
6061 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6062 grid $top.flab $top.fname -sticky w
6063 frame $top.buts
6064 button $top.buts.gen -text "Write" -command wrcomgo
6065 button $top.buts.can -text "Cancel" -command wrcomcan
6066 grid $top.buts.gen $top.buts.can
6067 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6068 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6069 grid $top.buts - -pady 10 -sticky ew
6070 focus $top.fname
6073 proc wrcomgo {} {
6074 global wrcomtop
6076 set id [$wrcomtop.sha1 get]
6077 set cmd "echo $id | [$wrcomtop.cmd get]"
6078 set fname [$wrcomtop.fname get]
6079 if {[catch {exec sh -c $cmd >$fname &} err]} {
6080 error_popup "Error writing commit: $err"
6082 catch {destroy $wrcomtop}
6083 unset wrcomtop
6086 proc wrcomcan {} {
6087 global wrcomtop
6089 catch {destroy $wrcomtop}
6090 unset wrcomtop
6093 proc mkbranch {} {
6094 global rowmenuid mkbrtop
6096 set top .makebranch
6097 catch {destroy $top}
6098 toplevel $top
6099 label $top.title -text "Create new branch"
6100 grid $top.title - -pady 10
6101 label $top.id -text "ID:"
6102 entry $top.sha1 -width 40 -relief flat
6103 $top.sha1 insert 0 $rowmenuid
6104 $top.sha1 conf -state readonly
6105 grid $top.id $top.sha1 -sticky w
6106 label $top.nlab -text "Name:"
6107 entry $top.name -width 40
6108 grid $top.nlab $top.name -sticky w
6109 frame $top.buts
6110 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6111 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6112 grid $top.buts.go $top.buts.can
6113 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6114 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6115 grid $top.buts - -pady 10 -sticky ew
6116 focus $top.name
6119 proc mkbrgo {top} {
6120 global headids idheads
6122 set name [$top.name get]
6123 set id [$top.sha1 get]
6124 if {$name eq {}} {
6125 error_popup "Please specify a name for the new branch"
6126 return
6128 catch {destroy $top}
6129 nowbusy newbranch
6130 update
6131 if {[catch {
6132 exec git branch $name $id
6133 } err]} {
6134 notbusy newbranch
6135 error_popup $err
6136 } else {
6137 set headids($name) $id
6138 lappend idheads($id) $name
6139 addedhead $id $name
6140 notbusy newbranch
6141 redrawtags $id
6142 dispneartags 0
6143 run refill_reflist
6147 proc cherrypick {} {
6148 global rowmenuid curview commitrow
6149 global mainhead
6151 set oldhead [exec git rev-parse HEAD]
6152 set dheads [descheads $rowmenuid]
6153 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6154 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6155 included in branch $mainhead -- really re-apply it?"]
6156 if {!$ok} return
6158 nowbusy cherrypick
6159 update
6160 # Unfortunately git-cherry-pick writes stuff to stderr even when
6161 # no error occurs, and exec takes that as an indication of error...
6162 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6163 notbusy cherrypick
6164 error_popup $err
6165 return
6167 set newhead [exec git rev-parse HEAD]
6168 if {$newhead eq $oldhead} {
6169 notbusy cherrypick
6170 error_popup "No changes committed"
6171 return
6173 addnewchild $newhead $oldhead
6174 if {[info exists commitrow($curview,$oldhead)]} {
6175 insertrow $commitrow($curview,$oldhead) $newhead
6176 if {$mainhead ne {}} {
6177 movehead $newhead $mainhead
6178 movedhead $newhead $mainhead
6180 redrawtags $oldhead
6181 redrawtags $newhead
6183 notbusy cherrypick
6186 proc resethead {} {
6187 global mainheadid mainhead rowmenuid confirm_ok resettype
6188 global showlocalchanges
6190 set confirm_ok 0
6191 set w ".confirmreset"
6192 toplevel $w
6193 wm transient $w .
6194 wm title $w "Confirm reset"
6195 message $w.m -text \
6196 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6197 -justify center -aspect 1000
6198 pack $w.m -side top -fill x -padx 20 -pady 20
6199 frame $w.f -relief sunken -border 2
6200 message $w.f.rt -text "Reset type:" -aspect 1000
6201 grid $w.f.rt -sticky w
6202 set resettype mixed
6203 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6204 -text "Soft: Leave working tree and index untouched"
6205 grid $w.f.soft -sticky w
6206 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6207 -text "Mixed: Leave working tree untouched, reset index"
6208 grid $w.f.mixed -sticky w
6209 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6210 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6211 grid $w.f.hard -sticky w
6212 pack $w.f -side top -fill x
6213 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6214 pack $w.ok -side left -fill x -padx 20 -pady 20
6215 button $w.cancel -text Cancel -command "destroy $w"
6216 pack $w.cancel -side right -fill x -padx 20 -pady 20
6217 bind $w <Visibility> "grab $w; focus $w"
6218 tkwait window $w
6219 if {!$confirm_ok} return
6220 if {[catch {set fd [open \
6221 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6222 error_popup $err
6223 } else {
6224 dohidelocalchanges
6225 set w ".resetprogress"
6226 filerun $fd [list readresetstat $fd $w]
6227 toplevel $w
6228 wm transient $w
6229 wm title $w "Reset progress"
6230 message $w.m -text "Reset in progress, please wait..." \
6231 -justify center -aspect 1000
6232 pack $w.m -side top -fill x -padx 20 -pady 5
6233 canvas $w.c -width 150 -height 20 -bg white
6234 $w.c create rect 0 0 0 20 -fill green -tags rect
6235 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6236 nowbusy reset
6240 proc readresetstat {fd w} {
6241 global mainhead mainheadid showlocalchanges
6243 if {[gets $fd line] >= 0} {
6244 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6245 set x [expr {($m * 150) / $n}]
6246 $w.c coords rect 0 0 $x 20
6248 return 1
6250 destroy $w
6251 notbusy reset
6252 if {[catch {close $fd} err]} {
6253 error_popup $err
6255 set oldhead $mainheadid
6256 set newhead [exec git rev-parse HEAD]
6257 if {$newhead ne $oldhead} {
6258 movehead $newhead $mainhead
6259 movedhead $newhead $mainhead
6260 set mainheadid $newhead
6261 redrawtags $oldhead
6262 redrawtags $newhead
6264 if {$showlocalchanges} {
6265 doshowlocalchanges
6267 return 0
6270 # context menu for a head
6271 proc headmenu {x y id head} {
6272 global headmenuid headmenuhead headctxmenu mainhead
6274 set headmenuid $id
6275 set headmenuhead $head
6276 set state normal
6277 if {$head eq $mainhead} {
6278 set state disabled
6280 $headctxmenu entryconfigure 0 -state $state
6281 $headctxmenu entryconfigure 1 -state $state
6282 tk_popup $headctxmenu $x $y
6285 proc cobranch {} {
6286 global headmenuid headmenuhead mainhead headids
6287 global showlocalchanges mainheadid
6289 # check the tree is clean first??
6290 set oldmainhead $mainhead
6291 nowbusy checkout
6292 update
6293 dohidelocalchanges
6294 if {[catch {
6295 exec git checkout -q $headmenuhead
6296 } err]} {
6297 notbusy checkout
6298 error_popup $err
6299 } else {
6300 notbusy checkout
6301 set mainhead $headmenuhead
6302 set mainheadid $headmenuid
6303 if {[info exists headids($oldmainhead)]} {
6304 redrawtags $headids($oldmainhead)
6306 redrawtags $headmenuid
6308 if {$showlocalchanges} {
6309 dodiffindex
6313 proc rmbranch {} {
6314 global headmenuid headmenuhead mainhead
6315 global idheads
6317 set head $headmenuhead
6318 set id $headmenuid
6319 # this check shouldn't be needed any more...
6320 if {$head eq $mainhead} {
6321 error_popup "Cannot delete the currently checked-out branch"
6322 return
6324 set dheads [descheads $id]
6325 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6326 # the stuff on this branch isn't on any other branch
6327 if {![confirm_popup "The commits on branch $head aren't on any other\
6328 branch.\nReally delete branch $head?"]} return
6330 nowbusy rmbranch
6331 update
6332 if {[catch {exec git branch -D $head} err]} {
6333 notbusy rmbranch
6334 error_popup $err
6335 return
6337 removehead $id $head
6338 removedhead $id $head
6339 redrawtags $id
6340 notbusy rmbranch
6341 dispneartags 0
6342 run refill_reflist
6345 # Display a list of tags and heads
6346 proc showrefs {} {
6347 global showrefstop bgcolor fgcolor selectbgcolor mainfont
6348 global bglist fglist uifont reflistfilter reflist maincursor
6350 set top .showrefs
6351 set showrefstop $top
6352 if {[winfo exists $top]} {
6353 raise $top
6354 refill_reflist
6355 return
6357 toplevel $top
6358 wm title $top "Tags and heads: [file tail [pwd]]"
6359 text $top.list -background $bgcolor -foreground $fgcolor \
6360 -selectbackground $selectbgcolor -font $mainfont \
6361 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6362 -width 30 -height 20 -cursor $maincursor \
6363 -spacing1 1 -spacing3 1 -state disabled
6364 $top.list tag configure highlight -background $selectbgcolor
6365 lappend bglist $top.list
6366 lappend fglist $top.list
6367 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6368 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6369 grid $top.list $top.ysb -sticky nsew
6370 grid $top.xsb x -sticky ew
6371 frame $top.f
6372 label $top.f.l -text "Filter: " -font $uifont
6373 entry $top.f.e -width 20 -textvariable reflistfilter -font $uifont
6374 set reflistfilter "*"
6375 trace add variable reflistfilter write reflistfilter_change
6376 pack $top.f.e -side right -fill x -expand 1
6377 pack $top.f.l -side left
6378 grid $top.f - -sticky ew -pady 2
6379 button $top.close -command [list destroy $top] -text "Close" \
6380 -font $uifont
6381 grid $top.close -
6382 grid columnconfigure $top 0 -weight 1
6383 grid rowconfigure $top 0 -weight 1
6384 bind $top.list <1> {break}
6385 bind $top.list <B1-Motion> {break}
6386 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6387 set reflist {}
6388 refill_reflist
6391 proc sel_reflist {w x y} {
6392 global showrefstop reflist headids tagids otherrefids
6394 if {![winfo exists $showrefstop]} return
6395 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6396 set ref [lindex $reflist [expr {$l-1}]]
6397 set n [lindex $ref 0]
6398 switch -- [lindex $ref 1] {
6399 "H" {selbyid $headids($n)}
6400 "T" {selbyid $tagids($n)}
6401 "o" {selbyid $otherrefids($n)}
6403 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6406 proc unsel_reflist {} {
6407 global showrefstop
6409 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6410 $showrefstop.list tag remove highlight 0.0 end
6413 proc reflistfilter_change {n1 n2 op} {
6414 global reflistfilter
6416 after cancel refill_reflist
6417 after 200 refill_reflist
6420 proc refill_reflist {} {
6421 global reflist reflistfilter showrefstop headids tagids otherrefids
6422 global commitrow curview commitinterest
6424 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6425 set refs {}
6426 foreach n [array names headids] {
6427 if {[string match $reflistfilter $n]} {
6428 if {[info exists commitrow($curview,$headids($n))]} {
6429 lappend refs [list $n H]
6430 } else {
6431 set commitinterest($headids($n)) {run refill_reflist}
6435 foreach n [array names tagids] {
6436 if {[string match $reflistfilter $n]} {
6437 if {[info exists commitrow($curview,$tagids($n))]} {
6438 lappend refs [list $n T]
6439 } else {
6440 set commitinterest($tagids($n)) {run refill_reflist}
6444 foreach n [array names otherrefids] {
6445 if {[string match $reflistfilter $n]} {
6446 if {[info exists commitrow($curview,$otherrefids($n))]} {
6447 lappend refs [list $n o]
6448 } else {
6449 set commitinterest($otherrefids($n)) {run refill_reflist}
6453 set refs [lsort -index 0 $refs]
6454 if {$refs eq $reflist} return
6456 # Update the contents of $showrefstop.list according to the
6457 # differences between $reflist (old) and $refs (new)
6458 $showrefstop.list conf -state normal
6459 $showrefstop.list insert end "\n"
6460 set i 0
6461 set j 0
6462 while {$i < [llength $reflist] || $j < [llength $refs]} {
6463 if {$i < [llength $reflist]} {
6464 if {$j < [llength $refs]} {
6465 set cmp [string compare [lindex $reflist $i 0] \
6466 [lindex $refs $j 0]]
6467 if {$cmp == 0} {
6468 set cmp [string compare [lindex $reflist $i 1] \
6469 [lindex $refs $j 1]]
6471 } else {
6472 set cmp -1
6474 } else {
6475 set cmp 1
6477 switch -- $cmp {
6478 -1 {
6479 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6480 incr i
6483 incr i
6484 incr j
6487 set l [expr {$j + 1}]
6488 $showrefstop.list image create $l.0 -align baseline \
6489 -image reficon-[lindex $refs $j 1] -padx 2
6490 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6491 incr j
6495 set reflist $refs
6496 # delete last newline
6497 $showrefstop.list delete end-2c end-1c
6498 $showrefstop.list conf -state disabled
6501 # Stuff for finding nearby tags
6502 proc getallcommits {} {
6503 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6504 global idheads idtags idotherrefs allparents tagobjid
6506 if {![info exists allcommits]} {
6507 set nextarc 0
6508 set allcommits 0
6509 set seeds {}
6510 set allcwait 0
6511 set cachedarcs 0
6512 set allccache [file join [gitdir] "gitk.cache"]
6513 if {![catch {
6514 set f [open $allccache r]
6515 set allcwait 1
6516 getcache $f
6517 }]} return
6520 if {$allcwait} {
6521 return
6523 set cmd [list | git rev-list --parents]
6524 set allcupdate [expr {$seeds ne {}}]
6525 if {!$allcupdate} {
6526 set ids "--all"
6527 } else {
6528 set refs [concat [array names idheads] [array names idtags] \
6529 [array names idotherrefs]]
6530 set ids {}
6531 set tagobjs {}
6532 foreach name [array names tagobjid] {
6533 lappend tagobjs $tagobjid($name)
6535 foreach id [lsort -unique $refs] {
6536 if {![info exists allparents($id)] &&
6537 [lsearch -exact $tagobjs $id] < 0} {
6538 lappend ids $id
6541 if {$ids ne {}} {
6542 foreach id $seeds {
6543 lappend ids "^$id"
6547 if {$ids ne {}} {
6548 set fd [open [concat $cmd $ids] r]
6549 fconfigure $fd -blocking 0
6550 incr allcommits
6551 nowbusy allcommits
6552 filerun $fd [list getallclines $fd]
6553 } else {
6554 dispneartags 0
6558 # Since most commits have 1 parent and 1 child, we group strings of
6559 # such commits into "arcs" joining branch/merge points (BMPs), which
6560 # are commits that either don't have 1 parent or don't have 1 child.
6562 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6563 # arcout(id) - outgoing arcs for BMP
6564 # arcids(a) - list of IDs on arc including end but not start
6565 # arcstart(a) - BMP ID at start of arc
6566 # arcend(a) - BMP ID at end of arc
6567 # growing(a) - arc a is still growing
6568 # arctags(a) - IDs out of arcids (excluding end) that have tags
6569 # archeads(a) - IDs out of arcids (excluding end) that have heads
6570 # The start of an arc is at the descendent end, so "incoming" means
6571 # coming from descendents, and "outgoing" means going towards ancestors.
6573 proc getallclines {fd} {
6574 global allparents allchildren idtags idheads nextarc
6575 global arcnos arcids arctags arcout arcend arcstart archeads growing
6576 global seeds allcommits cachedarcs allcupdate
6578 set nid 0
6579 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6580 set id [lindex $line 0]
6581 if {[info exists allparents($id)]} {
6582 # seen it already
6583 continue
6585 set cachedarcs 0
6586 set olds [lrange $line 1 end]
6587 set allparents($id) $olds
6588 if {![info exists allchildren($id)]} {
6589 set allchildren($id) {}
6590 set arcnos($id) {}
6591 lappend seeds $id
6592 } else {
6593 set a $arcnos($id)
6594 if {[llength $olds] == 1 && [llength $a] == 1} {
6595 lappend arcids($a) $id
6596 if {[info exists idtags($id)]} {
6597 lappend arctags($a) $id
6599 if {[info exists idheads($id)]} {
6600 lappend archeads($a) $id
6602 if {[info exists allparents($olds)]} {
6603 # seen parent already
6604 if {![info exists arcout($olds)]} {
6605 splitarc $olds
6607 lappend arcids($a) $olds
6608 set arcend($a) $olds
6609 unset growing($a)
6611 lappend allchildren($olds) $id
6612 lappend arcnos($olds) $a
6613 continue
6616 foreach a $arcnos($id) {
6617 lappend arcids($a) $id
6618 set arcend($a) $id
6619 unset growing($a)
6622 set ao {}
6623 foreach p $olds {
6624 lappend allchildren($p) $id
6625 set a [incr nextarc]
6626 set arcstart($a) $id
6627 set archeads($a) {}
6628 set arctags($a) {}
6629 set archeads($a) {}
6630 set arcids($a) {}
6631 lappend ao $a
6632 set growing($a) 1
6633 if {[info exists allparents($p)]} {
6634 # seen it already, may need to make a new branch
6635 if {![info exists arcout($p)]} {
6636 splitarc $p
6638 lappend arcids($a) $p
6639 set arcend($a) $p
6640 unset growing($a)
6642 lappend arcnos($p) $a
6644 set arcout($id) $ao
6646 if {$nid > 0} {
6647 global cached_dheads cached_dtags cached_atags
6648 catch {unset cached_dheads}
6649 catch {unset cached_dtags}
6650 catch {unset cached_atags}
6652 if {![eof $fd]} {
6653 return [expr {$nid >= 1000? 2: 1}]
6655 set cacheok 1
6656 if {[catch {
6657 fconfigure $fd -blocking 1
6658 close $fd
6659 } err]} {
6660 # got an error reading the list of commits
6661 # if we were updating, try rereading the whole thing again
6662 if {$allcupdate} {
6663 incr allcommits -1
6664 dropcache $err
6665 return
6667 error_popup "Error reading commit topology information;\
6668 branch and preceding/following tag information\
6669 will be incomplete.\n($err)"
6670 set cacheok 0
6672 if {[incr allcommits -1] == 0} {
6673 notbusy allcommits
6674 if {$cacheok} {
6675 run savecache
6678 dispneartags 0
6679 return 0
6682 proc recalcarc {a} {
6683 global arctags archeads arcids idtags idheads
6685 set at {}
6686 set ah {}
6687 foreach id [lrange $arcids($a) 0 end-1] {
6688 if {[info exists idtags($id)]} {
6689 lappend at $id
6691 if {[info exists idheads($id)]} {
6692 lappend ah $id
6695 set arctags($a) $at
6696 set archeads($a) $ah
6699 proc splitarc {p} {
6700 global arcnos arcids nextarc arctags archeads idtags idheads
6701 global arcstart arcend arcout allparents growing
6703 set a $arcnos($p)
6704 if {[llength $a] != 1} {
6705 puts "oops splitarc called but [llength $a] arcs already"
6706 return
6708 set a [lindex $a 0]
6709 set i [lsearch -exact $arcids($a) $p]
6710 if {$i < 0} {
6711 puts "oops splitarc $p not in arc $a"
6712 return
6714 set na [incr nextarc]
6715 if {[info exists arcend($a)]} {
6716 set arcend($na) $arcend($a)
6717 } else {
6718 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6719 set j [lsearch -exact $arcnos($l) $a]
6720 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6722 set tail [lrange $arcids($a) [expr {$i+1}] end]
6723 set arcids($a) [lrange $arcids($a) 0 $i]
6724 set arcend($a) $p
6725 set arcstart($na) $p
6726 set arcout($p) $na
6727 set arcids($na) $tail
6728 if {[info exists growing($a)]} {
6729 set growing($na) 1
6730 unset growing($a)
6733 foreach id $tail {
6734 if {[llength $arcnos($id)] == 1} {
6735 set arcnos($id) $na
6736 } else {
6737 set j [lsearch -exact $arcnos($id) $a]
6738 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6742 # reconstruct tags and heads lists
6743 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6744 recalcarc $a
6745 recalcarc $na
6746 } else {
6747 set arctags($na) {}
6748 set archeads($na) {}
6752 # Update things for a new commit added that is a child of one
6753 # existing commit. Used when cherry-picking.
6754 proc addnewchild {id p} {
6755 global allparents allchildren idtags nextarc
6756 global arcnos arcids arctags arcout arcend arcstart archeads growing
6757 global seeds allcommits
6759 if {![info exists allcommits]} return
6760 set allparents($id) [list $p]
6761 set allchildren($id) {}
6762 set arcnos($id) {}
6763 lappend seeds $id
6764 lappend allchildren($p) $id
6765 set a [incr nextarc]
6766 set arcstart($a) $id
6767 set archeads($a) {}
6768 set arctags($a) {}
6769 set arcids($a) [list $p]
6770 set arcend($a) $p
6771 if {![info exists arcout($p)]} {
6772 splitarc $p
6774 lappend arcnos($p) $a
6775 set arcout($id) [list $a]
6778 # This implements a cache for the topology information.
6779 # The cache saves, for each arc, the start and end of the arc,
6780 # the ids on the arc, and the outgoing arcs from the end.
6781 proc readcache {f} {
6782 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6783 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6784 global allcwait
6786 set a $nextarc
6787 set lim $cachedarcs
6788 if {$lim - $a > 500} {
6789 set lim [expr {$a + 500}]
6791 if {[catch {
6792 if {$a == $lim} {
6793 # finish reading the cache and setting up arctags, etc.
6794 set line [gets $f]
6795 if {$line ne "1"} {error "bad final version"}
6796 close $f
6797 foreach id [array names idtags] {
6798 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6799 [llength $allparents($id)] == 1} {
6800 set a [lindex $arcnos($id) 0]
6801 if {$arctags($a) eq {}} {
6802 recalcarc $a
6806 foreach id [array names idheads] {
6807 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6808 [llength $allparents($id)] == 1} {
6809 set a [lindex $arcnos($id) 0]
6810 if {$archeads($a) eq {}} {
6811 recalcarc $a
6815 foreach id [lsort -unique $possible_seeds] {
6816 if {$arcnos($id) eq {}} {
6817 lappend seeds $id
6820 set allcwait 0
6821 } else {
6822 while {[incr a] <= $lim} {
6823 set line [gets $f]
6824 if {[llength $line] != 3} {error "bad line"}
6825 set s [lindex $line 0]
6826 set arcstart($a) $s
6827 lappend arcout($s) $a
6828 if {![info exists arcnos($s)]} {
6829 lappend possible_seeds $s
6830 set arcnos($s) {}
6832 set e [lindex $line 1]
6833 if {$e eq {}} {
6834 set growing($a) 1
6835 } else {
6836 set arcend($a) $e
6837 if {![info exists arcout($e)]} {
6838 set arcout($e) {}
6841 set arcids($a) [lindex $line 2]
6842 foreach id $arcids($a) {
6843 lappend allparents($s) $id
6844 set s $id
6845 lappend arcnos($id) $a
6847 if {![info exists allparents($s)]} {
6848 set allparents($s) {}
6850 set arctags($a) {}
6851 set archeads($a) {}
6853 set nextarc [expr {$a - 1}]
6855 } err]} {
6856 dropcache $err
6857 return 0
6859 if {!$allcwait} {
6860 getallcommits
6862 return $allcwait
6865 proc getcache {f} {
6866 global nextarc cachedarcs possible_seeds
6868 if {[catch {
6869 set line [gets $f]
6870 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
6871 # make sure it's an integer
6872 set cachedarcs [expr {int([lindex $line 1])}]
6873 if {$cachedarcs < 0} {error "bad number of arcs"}
6874 set nextarc 0
6875 set possible_seeds {}
6876 run readcache $f
6877 } err]} {
6878 dropcache $err
6880 return 0
6883 proc dropcache {err} {
6884 global allcwait nextarc cachedarcs seeds
6886 #puts "dropping cache ($err)"
6887 foreach v {arcnos arcout arcids arcstart arcend growing \
6888 arctags archeads allparents allchildren} {
6889 global $v
6890 catch {unset $v}
6892 set allcwait 0
6893 set nextarc 0
6894 set cachedarcs 0
6895 set seeds {}
6896 getallcommits
6899 proc writecache {f} {
6900 global cachearc cachedarcs allccache
6901 global arcstart arcend arcnos arcids arcout
6903 set a $cachearc
6904 set lim $cachedarcs
6905 if {$lim - $a > 1000} {
6906 set lim [expr {$a + 1000}]
6908 if {[catch {
6909 while {[incr a] <= $lim} {
6910 if {[info exists arcend($a)]} {
6911 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
6912 } else {
6913 puts $f [list $arcstart($a) {} $arcids($a)]
6916 } err]} {
6917 catch {close $f}
6918 catch {file delete $allccache}
6919 #puts "writing cache failed ($err)"
6920 return 0
6922 set cachearc [expr {$a - 1}]
6923 if {$a > $cachedarcs} {
6924 puts $f "1"
6925 close $f
6926 return 0
6928 return 1
6931 proc savecache {} {
6932 global nextarc cachedarcs cachearc allccache
6934 if {$nextarc == $cachedarcs} return
6935 set cachearc 0
6936 set cachedarcs $nextarc
6937 catch {
6938 set f [open $allccache w]
6939 puts $f [list 1 $cachedarcs]
6940 run writecache $f
6944 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6945 # or 0 if neither is true.
6946 proc anc_or_desc {a b} {
6947 global arcout arcstart arcend arcnos cached_isanc
6949 if {$arcnos($a) eq $arcnos($b)} {
6950 # Both are on the same arc(s); either both are the same BMP,
6951 # or if one is not a BMP, the other is also not a BMP or is
6952 # the BMP at end of the arc (and it only has 1 incoming arc).
6953 # Or both can be BMPs with no incoming arcs.
6954 if {$a eq $b || $arcnos($a) eq {}} {
6955 return 0
6957 # assert {[llength $arcnos($a)] == 1}
6958 set arc [lindex $arcnos($a) 0]
6959 set i [lsearch -exact $arcids($arc) $a]
6960 set j [lsearch -exact $arcids($arc) $b]
6961 if {$i < 0 || $i > $j} {
6962 return 1
6963 } else {
6964 return -1
6968 if {![info exists arcout($a)]} {
6969 set arc [lindex $arcnos($a) 0]
6970 if {[info exists arcend($arc)]} {
6971 set aend $arcend($arc)
6972 } else {
6973 set aend {}
6975 set a $arcstart($arc)
6976 } else {
6977 set aend $a
6979 if {![info exists arcout($b)]} {
6980 set arc [lindex $arcnos($b) 0]
6981 if {[info exists arcend($arc)]} {
6982 set bend $arcend($arc)
6983 } else {
6984 set bend {}
6986 set b $arcstart($arc)
6987 } else {
6988 set bend $b
6990 if {$a eq $bend} {
6991 return 1
6993 if {$b eq $aend} {
6994 return -1
6996 if {[info exists cached_isanc($a,$bend)]} {
6997 if {$cached_isanc($a,$bend)} {
6998 return 1
7001 if {[info exists cached_isanc($b,$aend)]} {
7002 if {$cached_isanc($b,$aend)} {
7003 return -1
7005 if {[info exists cached_isanc($a,$bend)]} {
7006 return 0
7010 set todo [list $a $b]
7011 set anc($a) a
7012 set anc($b) b
7013 for {set i 0} {$i < [llength $todo]} {incr i} {
7014 set x [lindex $todo $i]
7015 if {$anc($x) eq {}} {
7016 continue
7018 foreach arc $arcnos($x) {
7019 set xd $arcstart($arc)
7020 if {$xd eq $bend} {
7021 set cached_isanc($a,$bend) 1
7022 set cached_isanc($b,$aend) 0
7023 return 1
7024 } elseif {$xd eq $aend} {
7025 set cached_isanc($b,$aend) 1
7026 set cached_isanc($a,$bend) 0
7027 return -1
7029 if {![info exists anc($xd)]} {
7030 set anc($xd) $anc($x)
7031 lappend todo $xd
7032 } elseif {$anc($xd) ne $anc($x)} {
7033 set anc($xd) {}
7037 set cached_isanc($a,$bend) 0
7038 set cached_isanc($b,$aend) 0
7039 return 0
7042 # This identifies whether $desc has an ancestor that is
7043 # a growing tip of the graph and which is not an ancestor of $anc
7044 # and returns 0 if so and 1 if not.
7045 # If we subsequently discover a tag on such a growing tip, and that
7046 # turns out to be a descendent of $anc (which it could, since we
7047 # don't necessarily see children before parents), then $desc
7048 # isn't a good choice to display as a descendent tag of
7049 # $anc (since it is the descendent of another tag which is
7050 # a descendent of $anc). Similarly, $anc isn't a good choice to
7051 # display as a ancestor tag of $desc.
7053 proc is_certain {desc anc} {
7054 global arcnos arcout arcstart arcend growing problems
7056 set certain {}
7057 if {[llength $arcnos($anc)] == 1} {
7058 # tags on the same arc are certain
7059 if {$arcnos($desc) eq $arcnos($anc)} {
7060 return 1
7062 if {![info exists arcout($anc)]} {
7063 # if $anc is partway along an arc, use the start of the arc instead
7064 set a [lindex $arcnos($anc) 0]
7065 set anc $arcstart($a)
7068 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7069 set x $desc
7070 } else {
7071 set a [lindex $arcnos($desc) 0]
7072 set x $arcend($a)
7074 if {$x == $anc} {
7075 return 1
7077 set anclist [list $x]
7078 set dl($x) 1
7079 set nnh 1
7080 set ngrowanc 0
7081 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7082 set x [lindex $anclist $i]
7083 if {$dl($x)} {
7084 incr nnh -1
7086 set done($x) 1
7087 foreach a $arcout($x) {
7088 if {[info exists growing($a)]} {
7089 if {![info exists growanc($x)] && $dl($x)} {
7090 set growanc($x) 1
7091 incr ngrowanc
7093 } else {
7094 set y $arcend($a)
7095 if {[info exists dl($y)]} {
7096 if {$dl($y)} {
7097 if {!$dl($x)} {
7098 set dl($y) 0
7099 if {![info exists done($y)]} {
7100 incr nnh -1
7102 if {[info exists growanc($x)]} {
7103 incr ngrowanc -1
7105 set xl [list $y]
7106 for {set k 0} {$k < [llength $xl]} {incr k} {
7107 set z [lindex $xl $k]
7108 foreach c $arcout($z) {
7109 if {[info exists arcend($c)]} {
7110 set v $arcend($c)
7111 if {[info exists dl($v)] && $dl($v)} {
7112 set dl($v) 0
7113 if {![info exists done($v)]} {
7114 incr nnh -1
7116 if {[info exists growanc($v)]} {
7117 incr ngrowanc -1
7119 lappend xl $v
7126 } elseif {$y eq $anc || !$dl($x)} {
7127 set dl($y) 0
7128 lappend anclist $y
7129 } else {
7130 set dl($y) 1
7131 lappend anclist $y
7132 incr nnh
7137 foreach x [array names growanc] {
7138 if {$dl($x)} {
7139 return 0
7141 return 0
7143 return 1
7146 proc validate_arctags {a} {
7147 global arctags idtags
7149 set i -1
7150 set na $arctags($a)
7151 foreach id $arctags($a) {
7152 incr i
7153 if {![info exists idtags($id)]} {
7154 set na [lreplace $na $i $i]
7155 incr i -1
7158 set arctags($a) $na
7161 proc validate_archeads {a} {
7162 global archeads idheads
7164 set i -1
7165 set na $archeads($a)
7166 foreach id $archeads($a) {
7167 incr i
7168 if {![info exists idheads($id)]} {
7169 set na [lreplace $na $i $i]
7170 incr i -1
7173 set archeads($a) $na
7176 # Return the list of IDs that have tags that are descendents of id,
7177 # ignoring IDs that are descendents of IDs already reported.
7178 proc desctags {id} {
7179 global arcnos arcstart arcids arctags idtags allparents
7180 global growing cached_dtags
7182 if {![info exists allparents($id)]} {
7183 return {}
7185 set t1 [clock clicks -milliseconds]
7186 set argid $id
7187 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7188 # part-way along an arc; check that arc first
7189 set a [lindex $arcnos($id) 0]
7190 if {$arctags($a) ne {}} {
7191 validate_arctags $a
7192 set i [lsearch -exact $arcids($a) $id]
7193 set tid {}
7194 foreach t $arctags($a) {
7195 set j [lsearch -exact $arcids($a) $t]
7196 if {$j >= $i} break
7197 set tid $t
7199 if {$tid ne {}} {
7200 return $tid
7203 set id $arcstart($a)
7204 if {[info exists idtags($id)]} {
7205 return $id
7208 if {[info exists cached_dtags($id)]} {
7209 return $cached_dtags($id)
7212 set origid $id
7213 set todo [list $id]
7214 set queued($id) 1
7215 set nc 1
7216 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7217 set id [lindex $todo $i]
7218 set done($id) 1
7219 set ta [info exists hastaggedancestor($id)]
7220 if {!$ta} {
7221 incr nc -1
7223 # ignore tags on starting node
7224 if {!$ta && $i > 0} {
7225 if {[info exists idtags($id)]} {
7226 set tagloc($id) $id
7227 set ta 1
7228 } elseif {[info exists cached_dtags($id)]} {
7229 set tagloc($id) $cached_dtags($id)
7230 set ta 1
7233 foreach a $arcnos($id) {
7234 set d $arcstart($a)
7235 if {!$ta && $arctags($a) ne {}} {
7236 validate_arctags $a
7237 if {$arctags($a) ne {}} {
7238 lappend tagloc($id) [lindex $arctags($a) end]
7241 if {$ta || $arctags($a) ne {}} {
7242 set tomark [list $d]
7243 for {set j 0} {$j < [llength $tomark]} {incr j} {
7244 set dd [lindex $tomark $j]
7245 if {![info exists hastaggedancestor($dd)]} {
7246 if {[info exists done($dd)]} {
7247 foreach b $arcnos($dd) {
7248 lappend tomark $arcstart($b)
7250 if {[info exists tagloc($dd)]} {
7251 unset tagloc($dd)
7253 } elseif {[info exists queued($dd)]} {
7254 incr nc -1
7256 set hastaggedancestor($dd) 1
7260 if {![info exists queued($d)]} {
7261 lappend todo $d
7262 set queued($d) 1
7263 if {![info exists hastaggedancestor($d)]} {
7264 incr nc
7269 set tags {}
7270 foreach id [array names tagloc] {
7271 if {![info exists hastaggedancestor($id)]} {
7272 foreach t $tagloc($id) {
7273 if {[lsearch -exact $tags $t] < 0} {
7274 lappend tags $t
7279 set t2 [clock clicks -milliseconds]
7280 set loopix $i
7282 # remove tags that are descendents of other tags
7283 for {set i 0} {$i < [llength $tags]} {incr i} {
7284 set a [lindex $tags $i]
7285 for {set j 0} {$j < $i} {incr j} {
7286 set b [lindex $tags $j]
7287 set r [anc_or_desc $a $b]
7288 if {$r == 1} {
7289 set tags [lreplace $tags $j $j]
7290 incr j -1
7291 incr i -1
7292 } elseif {$r == -1} {
7293 set tags [lreplace $tags $i $i]
7294 incr i -1
7295 break
7300 if {[array names growing] ne {}} {
7301 # graph isn't finished, need to check if any tag could get
7302 # eclipsed by another tag coming later. Simply ignore any
7303 # tags that could later get eclipsed.
7304 set ctags {}
7305 foreach t $tags {
7306 if {[is_certain $t $origid]} {
7307 lappend ctags $t
7310 if {$tags eq $ctags} {
7311 set cached_dtags($origid) $tags
7312 } else {
7313 set tags $ctags
7315 } else {
7316 set cached_dtags($origid) $tags
7318 set t3 [clock clicks -milliseconds]
7319 if {0 && $t3 - $t1 >= 100} {
7320 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7321 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7323 return $tags
7326 proc anctags {id} {
7327 global arcnos arcids arcout arcend arctags idtags allparents
7328 global growing cached_atags
7330 if {![info exists allparents($id)]} {
7331 return {}
7333 set t1 [clock clicks -milliseconds]
7334 set argid $id
7335 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7336 # part-way along an arc; check that arc first
7337 set a [lindex $arcnos($id) 0]
7338 if {$arctags($a) ne {}} {
7339 validate_arctags $a
7340 set i [lsearch -exact $arcids($a) $id]
7341 foreach t $arctags($a) {
7342 set j [lsearch -exact $arcids($a) $t]
7343 if {$j > $i} {
7344 return $t
7348 if {![info exists arcend($a)]} {
7349 return {}
7351 set id $arcend($a)
7352 if {[info exists idtags($id)]} {
7353 return $id
7356 if {[info exists cached_atags($id)]} {
7357 return $cached_atags($id)
7360 set origid $id
7361 set todo [list $id]
7362 set queued($id) 1
7363 set taglist {}
7364 set nc 1
7365 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7366 set id [lindex $todo $i]
7367 set done($id) 1
7368 set td [info exists hastaggeddescendent($id)]
7369 if {!$td} {
7370 incr nc -1
7372 # ignore tags on starting node
7373 if {!$td && $i > 0} {
7374 if {[info exists idtags($id)]} {
7375 set tagloc($id) $id
7376 set td 1
7377 } elseif {[info exists cached_atags($id)]} {
7378 set tagloc($id) $cached_atags($id)
7379 set td 1
7382 foreach a $arcout($id) {
7383 if {!$td && $arctags($a) ne {}} {
7384 validate_arctags $a
7385 if {$arctags($a) ne {}} {
7386 lappend tagloc($id) [lindex $arctags($a) 0]
7389 if {![info exists arcend($a)]} continue
7390 set d $arcend($a)
7391 if {$td || $arctags($a) ne {}} {
7392 set tomark [list $d]
7393 for {set j 0} {$j < [llength $tomark]} {incr j} {
7394 set dd [lindex $tomark $j]
7395 if {![info exists hastaggeddescendent($dd)]} {
7396 if {[info exists done($dd)]} {
7397 foreach b $arcout($dd) {
7398 if {[info exists arcend($b)]} {
7399 lappend tomark $arcend($b)
7402 if {[info exists tagloc($dd)]} {
7403 unset tagloc($dd)
7405 } elseif {[info exists queued($dd)]} {
7406 incr nc -1
7408 set hastaggeddescendent($dd) 1
7412 if {![info exists queued($d)]} {
7413 lappend todo $d
7414 set queued($d) 1
7415 if {![info exists hastaggeddescendent($d)]} {
7416 incr nc
7421 set t2 [clock clicks -milliseconds]
7422 set loopix $i
7423 set tags {}
7424 foreach id [array names tagloc] {
7425 if {![info exists hastaggeddescendent($id)]} {
7426 foreach t $tagloc($id) {
7427 if {[lsearch -exact $tags $t] < 0} {
7428 lappend tags $t
7434 # remove tags that are ancestors of other tags
7435 for {set i 0} {$i < [llength $tags]} {incr i} {
7436 set a [lindex $tags $i]
7437 for {set j 0} {$j < $i} {incr j} {
7438 set b [lindex $tags $j]
7439 set r [anc_or_desc $a $b]
7440 if {$r == -1} {
7441 set tags [lreplace $tags $j $j]
7442 incr j -1
7443 incr i -1
7444 } elseif {$r == 1} {
7445 set tags [lreplace $tags $i $i]
7446 incr i -1
7447 break
7452 if {[array names growing] ne {}} {
7453 # graph isn't finished, need to check if any tag could get
7454 # eclipsed by another tag coming later. Simply ignore any
7455 # tags that could later get eclipsed.
7456 set ctags {}
7457 foreach t $tags {
7458 if {[is_certain $origid $t]} {
7459 lappend ctags $t
7462 if {$tags eq $ctags} {
7463 set cached_atags($origid) $tags
7464 } else {
7465 set tags $ctags
7467 } else {
7468 set cached_atags($origid) $tags
7470 set t3 [clock clicks -milliseconds]
7471 if {0 && $t3 - $t1 >= 100} {
7472 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7473 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7475 return $tags
7478 # Return the list of IDs that have heads that are descendents of id,
7479 # including id itself if it has a head.
7480 proc descheads {id} {
7481 global arcnos arcstart arcids archeads idheads cached_dheads
7482 global allparents
7484 if {![info exists allparents($id)]} {
7485 return {}
7487 set aret {}
7488 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7489 # part-way along an arc; check it first
7490 set a [lindex $arcnos($id) 0]
7491 if {$archeads($a) ne {}} {
7492 validate_archeads $a
7493 set i [lsearch -exact $arcids($a) $id]
7494 foreach t $archeads($a) {
7495 set j [lsearch -exact $arcids($a) $t]
7496 if {$j > $i} break
7497 lappend aret $t
7500 set id $arcstart($a)
7502 set origid $id
7503 set todo [list $id]
7504 set seen($id) 1
7505 set ret {}
7506 for {set i 0} {$i < [llength $todo]} {incr i} {
7507 set id [lindex $todo $i]
7508 if {[info exists cached_dheads($id)]} {
7509 set ret [concat $ret $cached_dheads($id)]
7510 } else {
7511 if {[info exists idheads($id)]} {
7512 lappend ret $id
7514 foreach a $arcnos($id) {
7515 if {$archeads($a) ne {}} {
7516 validate_archeads $a
7517 if {$archeads($a) ne {}} {
7518 set ret [concat $ret $archeads($a)]
7521 set d $arcstart($a)
7522 if {![info exists seen($d)]} {
7523 lappend todo $d
7524 set seen($d) 1
7529 set ret [lsort -unique $ret]
7530 set cached_dheads($origid) $ret
7531 return [concat $ret $aret]
7534 proc addedtag {id} {
7535 global arcnos arcout cached_dtags cached_atags
7537 if {![info exists arcnos($id)]} return
7538 if {![info exists arcout($id)]} {
7539 recalcarc [lindex $arcnos($id) 0]
7541 catch {unset cached_dtags}
7542 catch {unset cached_atags}
7545 proc addedhead {hid head} {
7546 global arcnos arcout cached_dheads
7548 if {![info exists arcnos($hid)]} return
7549 if {![info exists arcout($hid)]} {
7550 recalcarc [lindex $arcnos($hid) 0]
7552 catch {unset cached_dheads}
7555 proc removedhead {hid head} {
7556 global cached_dheads
7558 catch {unset cached_dheads}
7561 proc movedhead {hid head} {
7562 global arcnos arcout cached_dheads
7564 if {![info exists arcnos($hid)]} return
7565 if {![info exists arcout($hid)]} {
7566 recalcarc [lindex $arcnos($hid) 0]
7568 catch {unset cached_dheads}
7571 proc changedrefs {} {
7572 global cached_dheads cached_dtags cached_atags
7573 global arctags archeads arcnos arcout idheads idtags
7575 foreach id [concat [array names idheads] [array names idtags]] {
7576 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7577 set a [lindex $arcnos($id) 0]
7578 if {![info exists donearc($a)]} {
7579 recalcarc $a
7580 set donearc($a) 1
7584 catch {unset cached_dtags}
7585 catch {unset cached_atags}
7586 catch {unset cached_dheads}
7589 proc rereadrefs {} {
7590 global idtags idheads idotherrefs mainhead
7592 set refids [concat [array names idtags] \
7593 [array names idheads] [array names idotherrefs]]
7594 foreach id $refids {
7595 if {![info exists ref($id)]} {
7596 set ref($id) [listrefs $id]
7599 set oldmainhead $mainhead
7600 readrefs
7601 changedrefs
7602 set refids [lsort -unique [concat $refids [array names idtags] \
7603 [array names idheads] [array names idotherrefs]]]
7604 foreach id $refids {
7605 set v [listrefs $id]
7606 if {![info exists ref($id)] || $ref($id) != $v ||
7607 ($id eq $oldmainhead && $id ne $mainhead) ||
7608 ($id eq $mainhead && $id ne $oldmainhead)} {
7609 redrawtags $id
7612 run refill_reflist
7615 proc listrefs {id} {
7616 global idtags idheads idotherrefs
7618 set x {}
7619 if {[info exists idtags($id)]} {
7620 set x $idtags($id)
7622 set y {}
7623 if {[info exists idheads($id)]} {
7624 set y $idheads($id)
7626 set z {}
7627 if {[info exists idotherrefs($id)]} {
7628 set z $idotherrefs($id)
7630 return [list $x $y $z]
7633 proc showtag {tag isnew} {
7634 global ctext tagcontents tagids linknum tagobjid
7636 if {$isnew} {
7637 addtohistory [list showtag $tag 0]
7639 $ctext conf -state normal
7640 clear_ctext
7641 set linknum 0
7642 if {![info exists tagcontents($tag)]} {
7643 catch {
7644 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7647 if {[info exists tagcontents($tag)]} {
7648 set text $tagcontents($tag)
7649 } else {
7650 set text "Tag: $tag\nId: $tagids($tag)"
7652 appendwithlinks $text {}
7653 $ctext conf -state disabled
7654 init_flist {}
7657 proc doquit {} {
7658 global stopped
7659 set stopped 100
7660 savestuff .
7661 destroy .
7664 proc doprefs {} {
7665 global maxwidth maxgraphpct diffopts
7666 global oldprefs prefstop showneartags showlocalchanges
7667 global bgcolor fgcolor ctext diffcolors selectbgcolor
7668 global uifont tabstop
7670 set top .gitkprefs
7671 set prefstop $top
7672 if {[winfo exists $top]} {
7673 raise $top
7674 return
7676 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7677 set oldprefs($v) [set $v]
7679 toplevel $top
7680 wm title $top "Gitk preferences"
7681 label $top.ldisp -text "Commit list display options"
7682 $top.ldisp configure -font $uifont
7683 grid $top.ldisp - -sticky w -pady 10
7684 label $top.spacer -text " "
7685 label $top.maxwidthl -text "Maximum graph width (lines)" \
7686 -font optionfont
7687 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7688 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7689 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7690 -font optionfont
7691 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7692 grid x $top.maxpctl $top.maxpct -sticky w
7693 frame $top.showlocal
7694 label $top.showlocal.l -text "Show local changes" -font optionfont
7695 checkbutton $top.showlocal.b -variable showlocalchanges
7696 pack $top.showlocal.b $top.showlocal.l -side left
7697 grid x $top.showlocal -sticky w
7699 label $top.ddisp -text "Diff display options"
7700 $top.ddisp configure -font $uifont
7701 grid $top.ddisp - -sticky w -pady 10
7702 label $top.diffoptl -text "Options for diff program" \
7703 -font optionfont
7704 entry $top.diffopt -width 20 -textvariable diffopts
7705 grid x $top.diffoptl $top.diffopt -sticky w
7706 frame $top.ntag
7707 label $top.ntag.l -text "Display nearby tags" -font optionfont
7708 checkbutton $top.ntag.b -variable showneartags
7709 pack $top.ntag.b $top.ntag.l -side left
7710 grid x $top.ntag -sticky w
7711 label $top.tabstopl -text "tabstop" -font optionfont
7712 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7713 grid x $top.tabstopl $top.tabstop -sticky w
7715 label $top.cdisp -text "Colors: press to choose"
7716 $top.cdisp configure -font $uifont
7717 grid $top.cdisp - -sticky w -pady 10
7718 label $top.bg -padx 40 -relief sunk -background $bgcolor
7719 button $top.bgbut -text "Background" -font optionfont \
7720 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7721 grid x $top.bgbut $top.bg -sticky w
7722 label $top.fg -padx 40 -relief sunk -background $fgcolor
7723 button $top.fgbut -text "Foreground" -font optionfont \
7724 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7725 grid x $top.fgbut $top.fg -sticky w
7726 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7727 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7728 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7729 [list $ctext tag conf d0 -foreground]]
7730 grid x $top.diffoldbut $top.diffold -sticky w
7731 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7732 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7733 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7734 [list $ctext tag conf d1 -foreground]]
7735 grid x $top.diffnewbut $top.diffnew -sticky w
7736 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7737 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7738 -command [list choosecolor diffcolors 2 $top.hunksep \
7739 "diff hunk header" \
7740 [list $ctext tag conf hunksep -foreground]]
7741 grid x $top.hunksepbut $top.hunksep -sticky w
7742 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7743 button $top.selbgbut -text "Select bg" -font optionfont \
7744 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7745 grid x $top.selbgbut $top.selbgsep -sticky w
7747 frame $top.buts
7748 button $top.buts.ok -text "OK" -command prefsok -default active
7749 $top.buts.ok configure -font $uifont
7750 button $top.buts.can -text "Cancel" -command prefscan -default normal
7751 $top.buts.can configure -font $uifont
7752 grid $top.buts.ok $top.buts.can
7753 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7754 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7755 grid $top.buts - - -pady 10 -sticky ew
7756 bind $top <Visibility> "focus $top.buts.ok"
7759 proc choosecolor {v vi w x cmd} {
7760 global $v
7762 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7763 -title "Gitk: choose color for $x"]
7764 if {$c eq {}} return
7765 $w conf -background $c
7766 lset $v $vi $c
7767 eval $cmd $c
7770 proc setselbg {c} {
7771 global bglist cflist
7772 foreach w $bglist {
7773 $w configure -selectbackground $c
7775 $cflist tag configure highlight \
7776 -background [$cflist cget -selectbackground]
7777 allcanvs itemconf secsel -fill $c
7780 proc setbg {c} {
7781 global bglist
7783 foreach w $bglist {
7784 $w conf -background $c
7788 proc setfg {c} {
7789 global fglist canv
7791 foreach w $fglist {
7792 $w conf -foreground $c
7794 allcanvs itemconf text -fill $c
7795 $canv itemconf circle -outline $c
7798 proc prefscan {} {
7799 global maxwidth maxgraphpct diffopts
7800 global oldprefs prefstop showneartags showlocalchanges
7802 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7803 set $v $oldprefs($v)
7805 catch {destroy $prefstop}
7806 unset prefstop
7809 proc prefsok {} {
7810 global maxwidth maxgraphpct
7811 global oldprefs prefstop showneartags showlocalchanges
7812 global charspc ctext tabstop
7814 catch {destroy $prefstop}
7815 unset prefstop
7816 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7817 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7818 if {$showlocalchanges} {
7819 doshowlocalchanges
7820 } else {
7821 dohidelocalchanges
7824 if {$maxwidth != $oldprefs(maxwidth)
7825 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7826 redisplay
7827 } elseif {$showneartags != $oldprefs(showneartags)} {
7828 reselectline
7832 proc formatdate {d} {
7833 global datetimeformat
7834 if {$d ne {}} {
7835 set d [clock format $d -format $datetimeformat]
7837 return $d
7840 # This list of encoding names and aliases is distilled from
7841 # http://www.iana.org/assignments/character-sets.
7842 # Not all of them are supported by Tcl.
7843 set encoding_aliases {
7844 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7845 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7846 { ISO-10646-UTF-1 csISO10646UTF1 }
7847 { ISO_646.basic:1983 ref csISO646basic1983 }
7848 { INVARIANT csINVARIANT }
7849 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7850 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7851 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7852 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7853 { NATS-DANO iso-ir-9-1 csNATSDANO }
7854 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7855 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7856 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7857 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7858 { ISO-2022-KR csISO2022KR }
7859 { EUC-KR csEUCKR }
7860 { ISO-2022-JP csISO2022JP }
7861 { ISO-2022-JP-2 csISO2022JP2 }
7862 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7863 csISO13JISC6220jp }
7864 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7865 { IT iso-ir-15 ISO646-IT csISO15Italian }
7866 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7867 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7868 { greek7-old iso-ir-18 csISO18Greek7Old }
7869 { latin-greek iso-ir-19 csISO19LatinGreek }
7870 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7871 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7872 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7873 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7874 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7875 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7876 { INIS iso-ir-49 csISO49INIS }
7877 { INIS-8 iso-ir-50 csISO50INIS8 }
7878 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7879 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7880 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7881 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7882 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7883 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7884 csISO60Norwegian1 }
7885 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7886 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7887 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7888 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7889 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7890 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7891 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7892 { greek7 iso-ir-88 csISO88Greek7 }
7893 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7894 { iso-ir-90 csISO90 }
7895 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7896 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7897 csISO92JISC62991984b }
7898 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7899 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7900 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7901 csISO95JIS62291984handadd }
7902 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7903 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7904 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7905 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7906 CP819 csISOLatin1 }
7907 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7908 { T.61-7bit iso-ir-102 csISO102T617bit }
7909 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7910 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7911 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7912 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7913 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7914 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7915 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7916 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7917 arabic csISOLatinArabic }
7918 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7919 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7920 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7921 greek greek8 csISOLatinGreek }
7922 { T.101-G2 iso-ir-128 csISO128T101G2 }
7923 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7924 csISOLatinHebrew }
7925 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7926 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7927 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7928 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7929 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7930 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7931 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7932 csISOLatinCyrillic }
7933 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7934 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7935 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7936 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7937 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7938 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7939 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7940 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7941 { ISO_10367-box iso-ir-155 csISO10367Box }
7942 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7943 { latin-lap lap iso-ir-158 csISO158Lap }
7944 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7945 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7946 { us-dk csUSDK }
7947 { dk-us csDKUS }
7948 { JIS_X0201 X0201 csHalfWidthKatakana }
7949 { KSC5636 ISO646-KR csKSC5636 }
7950 { ISO-10646-UCS-2 csUnicode }
7951 { ISO-10646-UCS-4 csUCS4 }
7952 { DEC-MCS dec csDECMCS }
7953 { hp-roman8 roman8 r8 csHPRoman8 }
7954 { macintosh mac csMacintosh }
7955 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7956 csIBM037 }
7957 { IBM038 EBCDIC-INT cp038 csIBM038 }
7958 { IBM273 CP273 csIBM273 }
7959 { IBM274 EBCDIC-BE CP274 csIBM274 }
7960 { IBM275 EBCDIC-BR cp275 csIBM275 }
7961 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7962 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7963 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7964 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7965 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7966 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7967 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7968 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7969 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7970 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7971 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7972 { IBM437 cp437 437 csPC8CodePage437 }
7973 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7974 { IBM775 cp775 csPC775Baltic }
7975 { IBM850 cp850 850 csPC850Multilingual }
7976 { IBM851 cp851 851 csIBM851 }
7977 { IBM852 cp852 852 csPCp852 }
7978 { IBM855 cp855 855 csIBM855 }
7979 { IBM857 cp857 857 csIBM857 }
7980 { IBM860 cp860 860 csIBM860 }
7981 { IBM861 cp861 861 cp-is csIBM861 }
7982 { IBM862 cp862 862 csPC862LatinHebrew }
7983 { IBM863 cp863 863 csIBM863 }
7984 { IBM864 cp864 csIBM864 }
7985 { IBM865 cp865 865 csIBM865 }
7986 { IBM866 cp866 866 csIBM866 }
7987 { IBM868 CP868 cp-ar csIBM868 }
7988 { IBM869 cp869 869 cp-gr csIBM869 }
7989 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7990 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7991 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7992 { IBM891 cp891 csIBM891 }
7993 { IBM903 cp903 csIBM903 }
7994 { IBM904 cp904 904 csIBBM904 }
7995 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7996 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7997 { IBM1026 CP1026 csIBM1026 }
7998 { EBCDIC-AT-DE csIBMEBCDICATDE }
7999 { EBCDIC-AT-DE-A csEBCDICATDEA }
8000 { EBCDIC-CA-FR csEBCDICCAFR }
8001 { EBCDIC-DK-NO csEBCDICDKNO }
8002 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8003 { EBCDIC-FI-SE csEBCDICFISE }
8004 { EBCDIC-FI-SE-A csEBCDICFISEA }
8005 { EBCDIC-FR csEBCDICFR }
8006 { EBCDIC-IT csEBCDICIT }
8007 { EBCDIC-PT csEBCDICPT }
8008 { EBCDIC-ES csEBCDICES }
8009 { EBCDIC-ES-A csEBCDICESA }
8010 { EBCDIC-ES-S csEBCDICESS }
8011 { EBCDIC-UK csEBCDICUK }
8012 { EBCDIC-US csEBCDICUS }
8013 { UNKNOWN-8BIT csUnknown8BiT }
8014 { MNEMONIC csMnemonic }
8015 { MNEM csMnem }
8016 { VISCII csVISCII }
8017 { VIQR csVIQR }
8018 { KOI8-R csKOI8R }
8019 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8020 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8021 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8022 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8023 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8024 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8025 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8026 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8027 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8028 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8029 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8030 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8031 { IBM1047 IBM-1047 }
8032 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8033 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8034 { UNICODE-1-1 csUnicode11 }
8035 { CESU-8 csCESU-8 }
8036 { BOCU-1 csBOCU-1 }
8037 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8038 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8039 l8 }
8040 { ISO-8859-15 ISO_8859-15 Latin-9 }
8041 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8042 { GBK CP936 MS936 windows-936 }
8043 { JIS_Encoding csJISEncoding }
8044 { Shift_JIS MS_Kanji csShiftJIS }
8045 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8046 EUC-JP }
8047 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8048 { ISO-10646-UCS-Basic csUnicodeASCII }
8049 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8050 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8051 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8052 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8053 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8054 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8055 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8056 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8057 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8058 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8059 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8060 { Ventura-US csVenturaUS }
8061 { Ventura-International csVenturaInternational }
8062 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8063 { PC8-Turkish csPC8Turkish }
8064 { IBM-Symbols csIBMSymbols }
8065 { IBM-Thai csIBMThai }
8066 { HP-Legal csHPLegal }
8067 { HP-Pi-font csHPPiFont }
8068 { HP-Math8 csHPMath8 }
8069 { Adobe-Symbol-Encoding csHPPSMath }
8070 { HP-DeskTop csHPDesktop }
8071 { Ventura-Math csVenturaMath }
8072 { Microsoft-Publishing csMicrosoftPublishing }
8073 { Windows-31J csWindows31J }
8074 { GB2312 csGB2312 }
8075 { Big5 csBig5 }
8078 proc tcl_encoding {enc} {
8079 global encoding_aliases
8080 set names [encoding names]
8081 set lcnames [string tolower $names]
8082 set enc [string tolower $enc]
8083 set i [lsearch -exact $lcnames $enc]
8084 if {$i < 0} {
8085 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8086 if {[regsub {^iso[-_]} $enc iso encx]} {
8087 set i [lsearch -exact $lcnames $encx]
8090 if {$i < 0} {
8091 foreach l $encoding_aliases {
8092 set ll [string tolower $l]
8093 if {[lsearch -exact $ll $enc] < 0} continue
8094 # look through the aliases for one that tcl knows about
8095 foreach e $ll {
8096 set i [lsearch -exact $lcnames $e]
8097 if {$i < 0} {
8098 if {[regsub {^iso[-_]} $e iso ex]} {
8099 set i [lsearch -exact $lcnames $ex]
8102 if {$i >= 0} break
8104 break
8107 if {$i >= 0} {
8108 return [lindex $names $i]
8110 return {}
8113 # defaults...
8114 set datemode 0
8115 set diffopts "-U 5 -p"
8116 set wrcomcmd "git diff-tree --stdin -p --pretty"
8118 set gitencoding {}
8119 catch {
8120 set gitencoding [exec git config --get i18n.commitencoding]
8122 if {$gitencoding == ""} {
8123 set gitencoding "utf-8"
8125 set tclencoding [tcl_encoding $gitencoding]
8126 if {$tclencoding == {}} {
8127 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8130 set mainfont {Helvetica 9}
8131 set textfont {Courier 9}
8132 set uifont {Helvetica 9 bold}
8133 set tabstop 8
8134 set findmergefiles 0
8135 set maxgraphpct 50
8136 set maxwidth 16
8137 set revlistorder 0
8138 set fastdate 0
8139 set uparrowlen 5
8140 set downarrowlen 5
8141 set mingaplen 100
8142 set cmitmode "patch"
8143 set wrapcomment "none"
8144 set showneartags 1
8145 set maxrefs 20
8146 set maxlinelen 200
8147 set showlocalchanges 1
8148 set datetimeformat "%Y-%m-%d %H:%M:%S"
8150 set colors {green red blue magenta darkgrey brown orange}
8151 set bgcolor white
8152 set fgcolor black
8153 set diffcolors {red "#00a000" blue}
8154 set diffcontext 3
8155 set selectbgcolor gray85
8157 catch {source ~/.gitk}
8159 font create optionfont -family sans-serif -size -12
8161 # check that we can find a .git directory somewhere...
8162 if {[catch {set gitdir [gitdir]}]} {
8163 show_error {} . "Cannot find a git repository here."
8164 exit 1
8166 if {![file isdirectory $gitdir]} {
8167 show_error {} . "Cannot find the git directory \"$gitdir\"."
8168 exit 1
8171 set revtreeargs {}
8172 set cmdline_files {}
8173 set i 0
8174 foreach arg $argv {
8175 switch -- $arg {
8176 "" { }
8177 "-d" { set datemode 1 }
8178 "--" {
8179 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8180 break
8182 default {
8183 lappend revtreeargs $arg
8186 incr i
8189 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8190 # no -- on command line, but some arguments (other than -d)
8191 if {[catch {
8192 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8193 set cmdline_files [split $f "\n"]
8194 set n [llength $cmdline_files]
8195 set revtreeargs [lrange $revtreeargs 0 end-$n]
8196 # Unfortunately git rev-parse doesn't produce an error when
8197 # something is both a revision and a filename. To be consistent
8198 # with git log and git rev-list, check revtreeargs for filenames.
8199 foreach arg $revtreeargs {
8200 if {[file exists $arg]} {
8201 show_error {} . "Ambiguous argument '$arg': both revision\
8202 and filename"
8203 exit 1
8206 } err]} {
8207 # unfortunately we get both stdout and stderr in $err,
8208 # so look for "fatal:".
8209 set i [string first "fatal:" $err]
8210 if {$i > 0} {
8211 set err [string range $err [expr {$i + 6}] end]
8213 show_error {} . "Bad arguments to gitk:\n$err"
8214 exit 1
8218 set nullid "0000000000000000000000000000000000000000"
8219 set nullid2 "0000000000000000000000000000000000000001"
8222 set runq {}
8223 set history {}
8224 set historyindex 0
8225 set fh_serial 0
8226 set nhl_names {}
8227 set highlight_paths {}
8228 set searchdirn -forwards
8229 set boldrows {}
8230 set boldnamerows {}
8231 set diffelide {0 0}
8232 set markingmatches 0
8233 set linkentercount 0
8234 set need_redisplay 0
8235 set nrows_drawn 0
8237 set nextviewnum 1
8238 set curview 0
8239 set selectedview 0
8240 set selectedhlview None
8241 set viewfiles(0) {}
8242 set viewperm(0) 0
8243 set viewargs(0) {}
8245 set cmdlineok 0
8246 set stopped 0
8247 set stuffsaved 0
8248 set patchnum 0
8249 set lookingforhead 0
8250 set localirow -1
8251 set localfrow -1
8252 set lserial 0
8253 setcoords
8254 makewindow
8255 # wait for the window to become visible
8256 tkwait visibility .
8257 wm title . "[file tail $argv0]: [file tail [pwd]]"
8258 readrefs
8260 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8261 # create a view for the files/dirs specified on the command line
8262 set curview 1
8263 set selectedview 1
8264 set nextviewnum 2
8265 set viewname(1) "Command line"
8266 set viewfiles(1) $cmdline_files
8267 set viewargs(1) $revtreeargs
8268 set viewperm(1) 0
8269 addviewmenu 1
8270 .bar.view entryconf Edit* -state normal
8271 .bar.view entryconf Delete* -state normal
8274 if {[info exists permviews]} {
8275 foreach v $permviews {
8276 set n $nextviewnum
8277 incr nextviewnum
8278 set viewname($n) [lindex $v 0]
8279 set viewfiles($n) [lindex $v 1]
8280 set viewargs($n) [lindex $v 2]
8281 set viewperm($n) 1
8282 addviewmenu $n
8285 getcommits