gitk: Establish and use global left-to-right ordering for commits
[git/gitweb.git] / gitk
blob40e5d31749c17a865780ec554a3cab3e0952b72b
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 vnextroot
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set vnextroot($view) 0
91 set order "--topo-order"
92 if {$datemode} {
93 set order "--date-order"
95 if {[catch {
96 set fd [open [concat | git log -z --pretty=raw $order --parents \
97 --boundary $viewargs($view) "--" $viewfiles($view)] r]
98 } err]} {
99 error_popup "Error executing git rev-list: $err"
100 exit 1
102 set commfd($view) $fd
103 set leftover($view) {}
104 set lookingforhead $showlocalchanges
105 fconfigure $fd -blocking 0 -translation lf -eofchar {}
106 if {$tclencoding != {}} {
107 fconfigure $fd -encoding $tclencoding
109 filerun $fd [list getcommitlines $fd $view]
110 nowbusy $view
113 proc stop_rev_list {} {
114 global commfd curview
116 if {![info exists commfd($curview)]} return
117 set fd $commfd($curview)
118 catch {
119 set pid [pid $fd]
120 exec kill $pid
122 catch {close $fd}
123 unset commfd($curview)
126 proc getcommits {} {
127 global phase canv mainfont curview
129 set phase getcommits
130 initlayout
131 start_rev_list $curview
132 show_status "Reading commits..."
135 # This makes a string representation of a positive integer which
136 # sorts as a string in numerical order
137 proc strrep {n} {
138 if {$n < 16} {
139 return [format "%x" $n]
140 } elseif {$n < 256} {
141 return [format "x%.2x" $n]
142 } elseif {$n < 65536} {
143 return [format "y%.4x" $n]
145 return [format "z%.8x" $n]
148 proc getcommitlines {fd view} {
149 global commitlisted
150 global leftover commfd
151 global displayorder commitidx commitrow commitdata
152 global parentlist children curview hlview
153 global vparentlist vdisporder vcmitlisted
154 global ordertok vnextroot
156 set stuff [read $fd 500000]
157 # git log doesn't terminate the last commit with a null...
158 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
159 set stuff "\0"
161 if {$stuff == {}} {
162 if {![eof $fd]} {
163 return 1
165 global viewname
166 unset commfd($view)
167 notbusy $view
168 # set it blocking so we wait for the process to terminate
169 fconfigure $fd -blocking 1
170 if {[catch {close $fd} err]} {
171 set fv {}
172 if {$view != $curview} {
173 set fv " for the \"$viewname($view)\" view"
175 if {[string range $err 0 4] == "usage"} {
176 set err "Gitk: error reading commits$fv:\
177 bad arguments to git rev-list."
178 if {$viewname($view) eq "Command line"} {
179 append err \
180 " (Note: arguments to gitk are passed to git rev-list\
181 to allow selection of commits to be displayed.)"
183 } else {
184 set err "Error reading commits$fv: $err"
186 error_popup $err
188 if {$view == $curview} {
189 run chewcommits $view
191 return 0
193 set start 0
194 set gotsome 0
195 while 1 {
196 set i [string first "\0" $stuff $start]
197 if {$i < 0} {
198 append leftover($view) [string range $stuff $start end]
199 break
201 if {$start == 0} {
202 set cmit $leftover($view)
203 append cmit [string range $stuff 0 [expr {$i - 1}]]
204 set leftover($view) {}
205 } else {
206 set cmit [string range $stuff $start [expr {$i - 1}]]
208 set start [expr {$i + 1}]
209 set j [string first "\n" $cmit]
210 set ok 0
211 set listed 1
212 if {$j >= 0 && [string match "commit *" $cmit]} {
213 set ids [string range $cmit 7 [expr {$j - 1}]]
214 if {[string match {[-<>]*} $ids]} {
215 switch -- [string index $ids 0] {
216 "-" {set listed 0}
217 "<" {set listed 2}
218 ">" {set listed 3}
220 set ids [string range $ids 1 end]
222 set ok 1
223 foreach id $ids {
224 if {[string length $id] != 40} {
225 set ok 0
226 break
230 if {!$ok} {
231 set shortcmit $cmit
232 if {[string length $shortcmit] > 80} {
233 set shortcmit "[string range $shortcmit 0 80]..."
235 error_popup "Can't parse git log output: {$shortcmit}"
236 exit 1
238 set id [lindex $ids 0]
239 if {![info exists ordertok($view,$id)]} {
240 set otok "o[strrep $vnextroot($view)]"
241 incr vnextroot($view)
242 set ordertok($view,$id) $otok
243 } else {
244 set otok $ordertok($view,$id)
246 if {$listed} {
247 set olds [lrange $ids 1 end]
248 if {[llength $olds] == 1} {
249 set p [lindex $olds 0]
250 lappend children($view,$p) $id
251 if {![info exists ordertok($view,$p)]} {
252 set ordertok($view,$p) $ordertok($view,$id)
254 } else {
255 set i 0
256 foreach p $olds {
257 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
258 lappend children($view,$p) $id
260 if {![info exists ordertok($view,$p)]} {
261 set ordertok($view,$p) "$otok[strrep $i]]"
263 incr i
266 } else {
267 set olds {}
269 if {![info exists children($view,$id)]} {
270 set children($view,$id) {}
272 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
273 set commitrow($view,$id) $commitidx($view)
274 incr commitidx($view)
275 if {$view == $curview} {
276 lappend parentlist $olds
277 lappend displayorder $id
278 lappend commitlisted $listed
279 } else {
280 lappend vparentlist($view) $olds
281 lappend vdisporder($view) $id
282 lappend vcmitlisted($view) $listed
284 set gotsome 1
286 if {$gotsome} {
287 run chewcommits $view
289 return 2
292 proc chewcommits {view} {
293 global curview hlview commfd
294 global selectedline pending_select
296 set more 0
297 if {$view == $curview} {
298 set allread [expr {![info exists commfd($view)]}]
299 set tlimit [expr {[clock clicks -milliseconds] + 50}]
300 set more [layoutmore $tlimit $allread]
301 if {$allread && !$more} {
302 global displayorder commitidx phase
303 global numcommits startmsecs
305 if {[info exists pending_select]} {
306 set row [first_real_row]
307 selectline $row 1
309 if {$commitidx($curview) > 0} {
310 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
311 #puts "overall $ms ms for $numcommits commits"
312 } else {
313 show_status "No commits selected"
315 notbusy layout
316 set phase {}
319 if {[info exists hlview] && $view == $hlview} {
320 vhighlightmore
322 return $more
325 proc readcommit {id} {
326 if {[catch {set contents [exec git cat-file commit $id]}]} return
327 parsecommit $id $contents 0
330 proc updatecommits {} {
331 global viewdata curview phase displayorder
332 global children commitrow selectedline thickerline
334 if {$phase ne {}} {
335 stop_rev_list
336 set phase {}
338 set n $curview
339 foreach id $displayorder {
340 catch {unset children($n,$id)}
341 catch {unset commitrow($n,$id)}
343 set curview -1
344 catch {unset selectedline}
345 catch {unset thickerline}
346 catch {unset viewdata($n)}
347 readrefs
348 changedrefs
349 regetallcommits
350 showview $n
353 proc parsecommit {id contents listed} {
354 global commitinfo cdate
356 set inhdr 1
357 set comment {}
358 set headline {}
359 set auname {}
360 set audate {}
361 set comname {}
362 set comdate {}
363 set hdrend [string first "\n\n" $contents]
364 if {$hdrend < 0} {
365 # should never happen...
366 set hdrend [string length $contents]
368 set header [string range $contents 0 [expr {$hdrend - 1}]]
369 set comment [string range $contents [expr {$hdrend + 2}] end]
370 foreach line [split $header "\n"] {
371 set tag [lindex $line 0]
372 if {$tag == "author"} {
373 set audate [lindex $line end-1]
374 set auname [lrange $line 1 end-2]
375 } elseif {$tag == "committer"} {
376 set comdate [lindex $line end-1]
377 set comname [lrange $line 1 end-2]
380 set headline {}
381 # take the first non-blank line of the comment as the headline
382 set headline [string trimleft $comment]
383 set i [string first "\n" $headline]
384 if {$i >= 0} {
385 set headline [string range $headline 0 $i]
387 set headline [string trimright $headline]
388 set i [string first "\r" $headline]
389 if {$i >= 0} {
390 set headline [string trimright [string range $headline 0 $i]]
392 if {!$listed} {
393 # git rev-list indents the comment by 4 spaces;
394 # if we got this via git cat-file, add the indentation
395 set newcomment {}
396 foreach line [split $comment "\n"] {
397 append newcomment " "
398 append newcomment $line
399 append newcomment "\n"
401 set comment $newcomment
403 if {$comdate != {}} {
404 set cdate($id) $comdate
406 set commitinfo($id) [list $headline $auname $audate \
407 $comname $comdate $comment]
410 proc getcommit {id} {
411 global commitdata commitinfo
413 if {[info exists commitdata($id)]} {
414 parsecommit $id $commitdata($id) 1
415 } else {
416 readcommit $id
417 if {![info exists commitinfo($id)]} {
418 set commitinfo($id) {"No commit information available"}
421 return 1
424 proc readrefs {} {
425 global tagids idtags headids idheads tagobjid
426 global otherrefids idotherrefs mainhead mainheadid
428 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
429 catch {unset $v}
431 set refd [open [list | git show-ref -d] r]
432 while {[gets $refd line] >= 0} {
433 if {[string index $line 40] ne " "} continue
434 set id [string range $line 0 39]
435 set ref [string range $line 41 end]
436 if {![string match "refs/*" $ref]} continue
437 set name [string range $ref 5 end]
438 if {[string match "remotes/*" $name]} {
439 if {![string match "*/HEAD" $name]} {
440 set headids($name) $id
441 lappend idheads($id) $name
443 } elseif {[string match "heads/*" $name]} {
444 set name [string range $name 6 end]
445 set headids($name) $id
446 lappend idheads($id) $name
447 } elseif {[string match "tags/*" $name]} {
448 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
449 # which is what we want since the former is the commit ID
450 set name [string range $name 5 end]
451 if {[string match "*^{}" $name]} {
452 set name [string range $name 0 end-3]
453 } else {
454 set tagobjid($name) $id
456 set tagids($name) $id
457 lappend idtags($id) $name
458 } else {
459 set otherrefids($name) $id
460 lappend idotherrefs($id) $name
463 close $refd
464 set mainhead {}
465 set mainheadid {}
466 catch {
467 set thehead [exec git symbolic-ref HEAD]
468 if {[string match "refs/heads/*" $thehead]} {
469 set mainhead [string range $thehead 11 end]
470 if {[info exists headids($mainhead)]} {
471 set mainheadid $headids($mainhead)
477 # skip over fake commits
478 proc first_real_row {} {
479 global nullid nullid2 displayorder numcommits
481 for {set row 0} {$row < $numcommits} {incr row} {
482 set id [lindex $displayorder $row]
483 if {$id ne $nullid && $id ne $nullid2} {
484 break
487 return $row
490 # update things for a head moved to a child of its previous location
491 proc movehead {id name} {
492 global headids idheads
494 removehead $headids($name) $name
495 set headids($name) $id
496 lappend idheads($id) $name
499 # update things when a head has been removed
500 proc removehead {id name} {
501 global headids idheads
503 if {$idheads($id) eq $name} {
504 unset idheads($id)
505 } else {
506 set i [lsearch -exact $idheads($id) $name]
507 if {$i >= 0} {
508 set idheads($id) [lreplace $idheads($id) $i $i]
511 unset headids($name)
514 proc show_error {w top msg} {
515 message $w.m -text $msg -justify center -aspect 400
516 pack $w.m -side top -fill x -padx 20 -pady 20
517 button $w.ok -text OK -command "destroy $top"
518 pack $w.ok -side bottom -fill x
519 bind $top <Visibility> "grab $top; focus $top"
520 bind $top <Key-Return> "destroy $top"
521 tkwait window $top
524 proc error_popup msg {
525 set w .error
526 toplevel $w
527 wm transient $w .
528 show_error $w $w $msg
531 proc confirm_popup msg {
532 global confirm_ok
533 set confirm_ok 0
534 set w .confirm
535 toplevel $w
536 wm transient $w .
537 message $w.m -text $msg -justify center -aspect 400
538 pack $w.m -side top -fill x -padx 20 -pady 20
539 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
540 pack $w.ok -side left -fill x
541 button $w.cancel -text Cancel -command "destroy $w"
542 pack $w.cancel -side right -fill x
543 bind $w <Visibility> "grab $w; focus $w"
544 tkwait window $w
545 return $confirm_ok
548 proc makewindow {} {
549 global canv canv2 canv3 linespc charspc ctext cflist
550 global textfont mainfont uifont tabstop
551 global findtype findtypemenu findloc findstring fstring geometry
552 global entries sha1entry sha1string sha1but
553 global maincursor textcursor curtextcursor
554 global rowctxmenu fakerowmenu mergemax wrapcomment
555 global highlight_files gdttype
556 global searchstring sstring
557 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
558 global headctxmenu
560 menu .bar
561 .bar add cascade -label "File" -menu .bar.file
562 .bar configure -font $uifont
563 menu .bar.file
564 .bar.file add command -label "Update" -command updatecommits
565 .bar.file add command -label "Reread references" -command rereadrefs
566 .bar.file add command -label "Quit" -command doquit
567 .bar.file configure -font $uifont
568 menu .bar.edit
569 .bar add cascade -label "Edit" -menu .bar.edit
570 .bar.edit add command -label "Preferences" -command doprefs
571 .bar.edit configure -font $uifont
573 menu .bar.view -font $uifont
574 .bar add cascade -label "View" -menu .bar.view
575 .bar.view add command -label "New view..." -command {newview 0}
576 .bar.view add command -label "Edit view..." -command editview \
577 -state disabled
578 .bar.view add command -label "Delete view" -command delview -state disabled
579 .bar.view add separator
580 .bar.view add radiobutton -label "All files" -command {showview 0} \
581 -variable selectedview -value 0
583 menu .bar.help
584 .bar add cascade -label "Help" -menu .bar.help
585 .bar.help add command -label "About gitk" -command about
586 .bar.help add command -label "Key bindings" -command keys
587 .bar.help configure -font $uifont
588 . configure -menu .bar
590 # the gui has upper and lower half, parts of a paned window.
591 panedwindow .ctop -orient vertical
593 # possibly use assumed geometry
594 if {![info exists geometry(pwsash0)]} {
595 set geometry(topheight) [expr {15 * $linespc}]
596 set geometry(topwidth) [expr {80 * $charspc}]
597 set geometry(botheight) [expr {15 * $linespc}]
598 set geometry(botwidth) [expr {50 * $charspc}]
599 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
600 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
603 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
604 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
605 frame .tf.histframe
606 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
608 # create three canvases
609 set cscroll .tf.histframe.csb
610 set canv .tf.histframe.pwclist.canv
611 canvas $canv \
612 -selectbackground $selectbgcolor \
613 -background $bgcolor -bd 0 \
614 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
615 .tf.histframe.pwclist add $canv
616 set canv2 .tf.histframe.pwclist.canv2
617 canvas $canv2 \
618 -selectbackground $selectbgcolor \
619 -background $bgcolor -bd 0 -yscrollincr $linespc
620 .tf.histframe.pwclist add $canv2
621 set canv3 .tf.histframe.pwclist.canv3
622 canvas $canv3 \
623 -selectbackground $selectbgcolor \
624 -background $bgcolor -bd 0 -yscrollincr $linespc
625 .tf.histframe.pwclist add $canv3
626 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
627 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
629 # a scroll bar to rule them
630 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
631 pack $cscroll -side right -fill y
632 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
633 lappend bglist $canv $canv2 $canv3
634 pack .tf.histframe.pwclist -fill both -expand 1 -side left
636 # we have two button bars at bottom of top frame. Bar 1
637 frame .tf.bar
638 frame .tf.lbar -height 15
640 set sha1entry .tf.bar.sha1
641 set entries $sha1entry
642 set sha1but .tf.bar.sha1label
643 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
644 -command gotocommit -width 8 -font $uifont
645 $sha1but conf -disabledforeground [$sha1but cget -foreground]
646 pack .tf.bar.sha1label -side left
647 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
648 trace add variable sha1string write sha1change
649 pack $sha1entry -side left -pady 2
651 image create bitmap bm-left -data {
652 #define left_width 16
653 #define left_height 16
654 static unsigned char left_bits[] = {
655 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
656 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
657 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
659 image create bitmap bm-right -data {
660 #define right_width 16
661 #define right_height 16
662 static unsigned char right_bits[] = {
663 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
664 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
665 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
667 button .tf.bar.leftbut -image bm-left -command goback \
668 -state disabled -width 26
669 pack .tf.bar.leftbut -side left -fill y
670 button .tf.bar.rightbut -image bm-right -command goforw \
671 -state disabled -width 26
672 pack .tf.bar.rightbut -side left -fill y
674 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
675 pack .tf.bar.findbut -side left
676 set findstring {}
677 set fstring .tf.bar.findstring
678 lappend entries $fstring
679 entry $fstring -width 30 -font $textfont -textvariable findstring
680 trace add variable findstring write find_change
681 pack $fstring -side left -expand 1 -fill x -in .tf.bar
682 set findtype Exact
683 set findtypemenu [tk_optionMenu .tf.bar.findtype \
684 findtype Exact IgnCase Regexp]
685 trace add variable findtype write find_change
686 .tf.bar.findtype configure -font $uifont
687 .tf.bar.findtype.menu configure -font $uifont
688 set findloc "All fields"
689 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
690 Comments Author Committer
691 trace add variable findloc write find_change
692 .tf.bar.findloc configure -font $uifont
693 .tf.bar.findloc.menu configure -font $uifont
694 pack .tf.bar.findloc -side right
695 pack .tf.bar.findtype -side right
697 # build up the bottom bar of upper window
698 label .tf.lbar.flabel -text "Highlight: Commits " \
699 -font $uifont
700 pack .tf.lbar.flabel -side left -fill y
701 set gdttype "touching paths:"
702 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
703 "adding/removing string:"]
704 trace add variable gdttype write hfiles_change
705 $gm conf -font $uifont
706 .tf.lbar.gdttype conf -font $uifont
707 pack .tf.lbar.gdttype -side left -fill y
708 entry .tf.lbar.fent -width 25 -font $textfont \
709 -textvariable highlight_files
710 trace add variable highlight_files write hfiles_change
711 lappend entries .tf.lbar.fent
712 pack .tf.lbar.fent -side left -fill x -expand 1
713 label .tf.lbar.vlabel -text " OR in view" -font $uifont
714 pack .tf.lbar.vlabel -side left -fill y
715 global viewhlmenu selectedhlview
716 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
717 $viewhlmenu entryconf None -command delvhighlight
718 $viewhlmenu conf -font $uifont
719 .tf.lbar.vhl conf -font $uifont
720 pack .tf.lbar.vhl -side left -fill y
721 label .tf.lbar.rlabel -text " OR " -font $uifont
722 pack .tf.lbar.rlabel -side left -fill y
723 global highlight_related
724 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
725 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
726 $m conf -font $uifont
727 .tf.lbar.relm conf -font $uifont
728 trace add variable highlight_related write vrel_change
729 pack .tf.lbar.relm -side left -fill y
731 # Finish putting the upper half of the viewer together
732 pack .tf.lbar -in .tf -side bottom -fill x
733 pack .tf.bar -in .tf -side bottom -fill x
734 pack .tf.histframe -fill both -side top -expand 1
735 .ctop add .tf
736 .ctop paneconfigure .tf -height $geometry(topheight)
737 .ctop paneconfigure .tf -width $geometry(topwidth)
739 # now build up the bottom
740 panedwindow .pwbottom -orient horizontal
742 # lower left, a text box over search bar, scroll bar to the right
743 # if we know window height, then that will set the lower text height, otherwise
744 # we set lower text height which will drive window height
745 if {[info exists geometry(main)]} {
746 frame .bleft -width $geometry(botwidth)
747 } else {
748 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
750 frame .bleft.top
751 frame .bleft.mid
753 button .bleft.top.search -text "Search" -command dosearch \
754 -font $uifont
755 pack .bleft.top.search -side left -padx 5
756 set sstring .bleft.top.sstring
757 entry $sstring -width 20 -font $textfont -textvariable searchstring
758 lappend entries $sstring
759 trace add variable searchstring write incrsearch
760 pack $sstring -side left -expand 1 -fill x
761 radiobutton .bleft.mid.diff -text "Diff" \
762 -command changediffdisp -variable diffelide -value {0 0}
763 radiobutton .bleft.mid.old -text "Old version" \
764 -command changediffdisp -variable diffelide -value {0 1}
765 radiobutton .bleft.mid.new -text "New version" \
766 -command changediffdisp -variable diffelide -value {1 0}
767 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
768 set ctext .bleft.ctext
769 text $ctext -background $bgcolor -foreground $fgcolor \
770 -tabs "[expr {$tabstop * $charspc}]" \
771 -state disabled -font $textfont \
772 -yscrollcommand scrolltext -wrap none
773 scrollbar .bleft.sb -command "$ctext yview"
774 pack .bleft.top -side top -fill x
775 pack .bleft.mid -side top -fill x
776 pack .bleft.sb -side right -fill y
777 pack $ctext -side left -fill both -expand 1
778 lappend bglist $ctext
779 lappend fglist $ctext
781 $ctext tag conf comment -wrap $wrapcomment
782 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
783 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
784 $ctext tag conf d0 -fore [lindex $diffcolors 0]
785 $ctext tag conf d1 -fore [lindex $diffcolors 1]
786 $ctext tag conf m0 -fore red
787 $ctext tag conf m1 -fore blue
788 $ctext tag conf m2 -fore green
789 $ctext tag conf m3 -fore purple
790 $ctext tag conf m4 -fore brown
791 $ctext tag conf m5 -fore "#009090"
792 $ctext tag conf m6 -fore magenta
793 $ctext tag conf m7 -fore "#808000"
794 $ctext tag conf m8 -fore "#009000"
795 $ctext tag conf m9 -fore "#ff0080"
796 $ctext tag conf m10 -fore cyan
797 $ctext tag conf m11 -fore "#b07070"
798 $ctext tag conf m12 -fore "#70b0f0"
799 $ctext tag conf m13 -fore "#70f0b0"
800 $ctext tag conf m14 -fore "#f0b070"
801 $ctext tag conf m15 -fore "#ff70b0"
802 $ctext tag conf mmax -fore darkgrey
803 set mergemax 16
804 $ctext tag conf mresult -font [concat $textfont bold]
805 $ctext tag conf msep -font [concat $textfont bold]
806 $ctext tag conf found -back yellow
808 .pwbottom add .bleft
809 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
811 # lower right
812 frame .bright
813 frame .bright.mode
814 radiobutton .bright.mode.patch -text "Patch" \
815 -command reselectline -variable cmitmode -value "patch"
816 .bright.mode.patch configure -font $uifont
817 radiobutton .bright.mode.tree -text "Tree" \
818 -command reselectline -variable cmitmode -value "tree"
819 .bright.mode.tree configure -font $uifont
820 grid .bright.mode.patch .bright.mode.tree -sticky ew
821 pack .bright.mode -side top -fill x
822 set cflist .bright.cfiles
823 set indent [font measure $mainfont "nn"]
824 text $cflist \
825 -selectbackground $selectbgcolor \
826 -background $bgcolor -foreground $fgcolor \
827 -font $mainfont \
828 -tabs [list $indent [expr {2 * $indent}]] \
829 -yscrollcommand ".bright.sb set" \
830 -cursor [. cget -cursor] \
831 -spacing1 1 -spacing3 1
832 lappend bglist $cflist
833 lappend fglist $cflist
834 scrollbar .bright.sb -command "$cflist yview"
835 pack .bright.sb -side right -fill y
836 pack $cflist -side left -fill both -expand 1
837 $cflist tag configure highlight \
838 -background [$cflist cget -selectbackground]
839 $cflist tag configure bold -font [concat $mainfont bold]
841 .pwbottom add .bright
842 .ctop add .pwbottom
844 # restore window position if known
845 if {[info exists geometry(main)]} {
846 wm geometry . "$geometry(main)"
849 if {[tk windowingsystem] eq {aqua}} {
850 set M1B M1
851 } else {
852 set M1B Control
855 bind .pwbottom <Configure> {resizecdetpanes %W %w}
856 pack .ctop -fill both -expand 1
857 bindall <1> {selcanvline %W %x %y}
858 #bindall <B1-Motion> {selcanvline %W %x %y}
859 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
860 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
861 bindall <2> "canvscan mark %W %x %y"
862 bindall <B2-Motion> "canvscan dragto %W %x %y"
863 bindkey <Home> selfirstline
864 bindkey <End> sellastline
865 bind . <Key-Up> "selnextline -1"
866 bind . <Key-Down> "selnextline 1"
867 bind . <Shift-Key-Up> "next_highlight -1"
868 bind . <Shift-Key-Down> "next_highlight 1"
869 bindkey <Key-Right> "goforw"
870 bindkey <Key-Left> "goback"
871 bind . <Key-Prior> "selnextpage -1"
872 bind . <Key-Next> "selnextpage 1"
873 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
874 bind . <$M1B-End> "allcanvs yview moveto 1.0"
875 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
876 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
877 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
878 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
879 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
880 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
881 bindkey <Key-space> "$ctext yview scroll 1 pages"
882 bindkey p "selnextline -1"
883 bindkey n "selnextline 1"
884 bindkey z "goback"
885 bindkey x "goforw"
886 bindkey i "selnextline -1"
887 bindkey k "selnextline 1"
888 bindkey j "goback"
889 bindkey l "goforw"
890 bindkey b "$ctext yview scroll -1 pages"
891 bindkey d "$ctext yview scroll 18 units"
892 bindkey u "$ctext yview scroll -18 units"
893 bindkey / {findnext 1}
894 bindkey <Key-Return> {findnext 0}
895 bindkey ? findprev
896 bindkey f nextfile
897 bindkey <F5> updatecommits
898 bind . <$M1B-q> doquit
899 bind . <$M1B-f> dofind
900 bind . <$M1B-g> {findnext 0}
901 bind . <$M1B-r> dosearchback
902 bind . <$M1B-s> dosearch
903 bind . <$M1B-equal> {incrfont 1}
904 bind . <$M1B-KP_Add> {incrfont 1}
905 bind . <$M1B-minus> {incrfont -1}
906 bind . <$M1B-KP_Subtract> {incrfont -1}
907 wm protocol . WM_DELETE_WINDOW doquit
908 bind . <Button-1> "click %W"
909 bind $fstring <Key-Return> dofind
910 bind $sha1entry <Key-Return> gotocommit
911 bind $sha1entry <<PasteSelection>> clearsha1
912 bind $cflist <1> {sel_flist %W %x %y; break}
913 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
914 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
915 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
917 set maincursor [. cget -cursor]
918 set textcursor [$ctext cget -cursor]
919 set curtextcursor $textcursor
921 set rowctxmenu .rowctxmenu
922 menu $rowctxmenu -tearoff 0
923 $rowctxmenu add command -label "Diff this -> selected" \
924 -command {diffvssel 0}
925 $rowctxmenu add command -label "Diff selected -> this" \
926 -command {diffvssel 1}
927 $rowctxmenu add command -label "Make patch" -command mkpatch
928 $rowctxmenu add command -label "Create tag" -command mktag
929 $rowctxmenu add command -label "Write commit to file" -command writecommit
930 $rowctxmenu add command -label "Create new branch" -command mkbranch
931 $rowctxmenu add command -label "Cherry-pick this commit" \
932 -command cherrypick
933 $rowctxmenu add command -label "Reset HEAD branch to here" \
934 -command resethead
936 set fakerowmenu .fakerowmenu
937 menu $fakerowmenu -tearoff 0
938 $fakerowmenu add command -label "Diff this -> selected" \
939 -command {diffvssel 0}
940 $fakerowmenu add command -label "Diff selected -> this" \
941 -command {diffvssel 1}
942 $fakerowmenu add command -label "Make patch" -command mkpatch
943 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
944 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
945 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
947 set headctxmenu .headctxmenu
948 menu $headctxmenu -tearoff 0
949 $headctxmenu add command -label "Check out this branch" \
950 -command cobranch
951 $headctxmenu add command -label "Remove this branch" \
952 -command rmbranch
954 global flist_menu
955 set flist_menu .flistctxmenu
956 menu $flist_menu -tearoff 0
957 $flist_menu add command -label "Highlight this too" \
958 -command {flist_hl 0}
959 $flist_menu add command -label "Highlight this only" \
960 -command {flist_hl 1}
963 # mouse-2 makes all windows scan vertically, but only the one
964 # the cursor is in scans horizontally
965 proc canvscan {op w x y} {
966 global canv canv2 canv3
967 foreach c [list $canv $canv2 $canv3] {
968 if {$c == $w} {
969 $c scan $op $x $y
970 } else {
971 $c scan $op 0 $y
976 proc scrollcanv {cscroll f0 f1} {
977 $cscroll set $f0 $f1
978 drawfrac $f0 $f1
979 flushhighlights
982 # when we make a key binding for the toplevel, make sure
983 # it doesn't get triggered when that key is pressed in the
984 # find string entry widget.
985 proc bindkey {ev script} {
986 global entries
987 bind . $ev $script
988 set escript [bind Entry $ev]
989 if {$escript == {}} {
990 set escript [bind Entry <Key>]
992 foreach e $entries {
993 bind $e $ev "$escript; break"
997 # set the focus back to the toplevel for any click outside
998 # the entry widgets
999 proc click {w} {
1000 global entries
1001 foreach e $entries {
1002 if {$w == $e} return
1004 focus .
1007 proc savestuff {w} {
1008 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
1009 global stuffsaved findmergefiles maxgraphpct
1010 global maxwidth showneartags showlocalchanges
1011 global viewname viewfiles viewargs viewperm nextviewnum
1012 global cmitmode wrapcomment
1013 global colors bgcolor fgcolor diffcolors selectbgcolor
1015 if {$stuffsaved} return
1016 if {![winfo viewable .]} return
1017 catch {
1018 set f [open "~/.gitk-new" w]
1019 puts $f [list set mainfont $mainfont]
1020 puts $f [list set textfont $textfont]
1021 puts $f [list set uifont $uifont]
1022 puts $f [list set tabstop $tabstop]
1023 puts $f [list set findmergefiles $findmergefiles]
1024 puts $f [list set maxgraphpct $maxgraphpct]
1025 puts $f [list set maxwidth $maxwidth]
1026 puts $f [list set cmitmode $cmitmode]
1027 puts $f [list set wrapcomment $wrapcomment]
1028 puts $f [list set showneartags $showneartags]
1029 puts $f [list set showlocalchanges $showlocalchanges]
1030 puts $f [list set bgcolor $bgcolor]
1031 puts $f [list set fgcolor $fgcolor]
1032 puts $f [list set colors $colors]
1033 puts $f [list set diffcolors $diffcolors]
1034 puts $f [list set selectbgcolor $selectbgcolor]
1036 puts $f "set geometry(main) [wm geometry .]"
1037 puts $f "set geometry(topwidth) [winfo width .tf]"
1038 puts $f "set geometry(topheight) [winfo height .tf]"
1039 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1040 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1041 puts $f "set geometry(botwidth) [winfo width .bleft]"
1042 puts $f "set geometry(botheight) [winfo height .bleft]"
1044 puts -nonewline $f "set permviews {"
1045 for {set v 0} {$v < $nextviewnum} {incr v} {
1046 if {$viewperm($v)} {
1047 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1050 puts $f "}"
1051 close $f
1052 file rename -force "~/.gitk-new" "~/.gitk"
1054 set stuffsaved 1
1057 proc resizeclistpanes {win w} {
1058 global oldwidth
1059 if {[info exists oldwidth($win)]} {
1060 set s0 [$win sash coord 0]
1061 set s1 [$win sash coord 1]
1062 if {$w < 60} {
1063 set sash0 [expr {int($w/2 - 2)}]
1064 set sash1 [expr {int($w*5/6 - 2)}]
1065 } else {
1066 set factor [expr {1.0 * $w / $oldwidth($win)}]
1067 set sash0 [expr {int($factor * [lindex $s0 0])}]
1068 set sash1 [expr {int($factor * [lindex $s1 0])}]
1069 if {$sash0 < 30} {
1070 set sash0 30
1072 if {$sash1 < $sash0 + 20} {
1073 set sash1 [expr {$sash0 + 20}]
1075 if {$sash1 > $w - 10} {
1076 set sash1 [expr {$w - 10}]
1077 if {$sash0 > $sash1 - 20} {
1078 set sash0 [expr {$sash1 - 20}]
1082 $win sash place 0 $sash0 [lindex $s0 1]
1083 $win sash place 1 $sash1 [lindex $s1 1]
1085 set oldwidth($win) $w
1088 proc resizecdetpanes {win w} {
1089 global oldwidth
1090 if {[info exists oldwidth($win)]} {
1091 set s0 [$win sash coord 0]
1092 if {$w < 60} {
1093 set sash0 [expr {int($w*3/4 - 2)}]
1094 } else {
1095 set factor [expr {1.0 * $w / $oldwidth($win)}]
1096 set sash0 [expr {int($factor * [lindex $s0 0])}]
1097 if {$sash0 < 45} {
1098 set sash0 45
1100 if {$sash0 > $w - 15} {
1101 set sash0 [expr {$w - 15}]
1104 $win sash place 0 $sash0 [lindex $s0 1]
1106 set oldwidth($win) $w
1109 proc allcanvs args {
1110 global canv canv2 canv3
1111 eval $canv $args
1112 eval $canv2 $args
1113 eval $canv3 $args
1116 proc bindall {event action} {
1117 global canv canv2 canv3
1118 bind $canv $event $action
1119 bind $canv2 $event $action
1120 bind $canv3 $event $action
1123 proc about {} {
1124 global uifont
1125 set w .about
1126 if {[winfo exists $w]} {
1127 raise $w
1128 return
1130 toplevel $w
1131 wm title $w "About gitk"
1132 message $w.m -text {
1133 Gitk - a commit viewer for git
1135 Copyright © 2005-2006 Paul Mackerras
1137 Use and redistribute under the terms of the GNU General Public License} \
1138 -justify center -aspect 400 -border 2 -bg white -relief groove
1139 pack $w.m -side top -fill x -padx 2 -pady 2
1140 $w.m configure -font $uifont
1141 button $w.ok -text Close -command "destroy $w" -default active
1142 pack $w.ok -side bottom
1143 $w.ok configure -font $uifont
1144 bind $w <Visibility> "focus $w.ok"
1145 bind $w <Key-Escape> "destroy $w"
1146 bind $w <Key-Return> "destroy $w"
1149 proc keys {} {
1150 global uifont
1151 set w .keys
1152 if {[winfo exists $w]} {
1153 raise $w
1154 return
1156 if {[tk windowingsystem] eq {aqua}} {
1157 set M1T Cmd
1158 } else {
1159 set M1T Ctrl
1161 toplevel $w
1162 wm title $w "Gitk key bindings"
1163 message $w.m -text "
1164 Gitk key bindings:
1166 <$M1T-Q> Quit
1167 <Home> Move to first commit
1168 <End> Move to last commit
1169 <Up>, p, i Move up one commit
1170 <Down>, n, k Move down one commit
1171 <Left>, z, j Go back in history list
1172 <Right>, x, l Go forward in history list
1173 <PageUp> Move up one page in commit list
1174 <PageDown> Move down one page in commit list
1175 <$M1T-Home> Scroll to top of commit list
1176 <$M1T-End> Scroll to bottom of commit list
1177 <$M1T-Up> Scroll commit list up one line
1178 <$M1T-Down> Scroll commit list down one line
1179 <$M1T-PageUp> Scroll commit list up one page
1180 <$M1T-PageDown> Scroll commit list down one page
1181 <Shift-Up> Move to previous highlighted line
1182 <Shift-Down> Move to next highlighted line
1183 <Delete>, b Scroll diff view up one page
1184 <Backspace> Scroll diff view up one page
1185 <Space> Scroll diff view down one page
1186 u Scroll diff view up 18 lines
1187 d Scroll diff view down 18 lines
1188 <$M1T-F> Find
1189 <$M1T-G> Move to next find hit
1190 <Return> Move to next find hit
1191 / Move to next find hit, or redo find
1192 ? Move to previous find hit
1193 f Scroll diff view to next file
1194 <$M1T-S> Search for next hit in diff view
1195 <$M1T-R> Search for previous hit in diff view
1196 <$M1T-KP+> Increase font size
1197 <$M1T-plus> Increase font size
1198 <$M1T-KP-> Decrease font size
1199 <$M1T-minus> Decrease font size
1200 <F5> Update
1202 -justify left -bg white -border 2 -relief groove
1203 pack $w.m -side top -fill both -padx 2 -pady 2
1204 $w.m configure -font $uifont
1205 button $w.ok -text Close -command "destroy $w" -default active
1206 pack $w.ok -side bottom
1207 $w.ok configure -font $uifont
1208 bind $w <Visibility> "focus $w.ok"
1209 bind $w <Key-Escape> "destroy $w"
1210 bind $w <Key-Return> "destroy $w"
1213 # Procedures for manipulating the file list window at the
1214 # bottom right of the overall window.
1216 proc treeview {w l openlevs} {
1217 global treecontents treediropen treeheight treeparent treeindex
1219 set ix 0
1220 set treeindex() 0
1221 set lev 0
1222 set prefix {}
1223 set prefixend -1
1224 set prefendstack {}
1225 set htstack {}
1226 set ht 0
1227 set treecontents() {}
1228 $w conf -state normal
1229 foreach f $l {
1230 while {[string range $f 0 $prefixend] ne $prefix} {
1231 if {$lev <= $openlevs} {
1232 $w mark set e:$treeindex($prefix) "end -1c"
1233 $w mark gravity e:$treeindex($prefix) left
1235 set treeheight($prefix) $ht
1236 incr ht [lindex $htstack end]
1237 set htstack [lreplace $htstack end end]
1238 set prefixend [lindex $prefendstack end]
1239 set prefendstack [lreplace $prefendstack end end]
1240 set prefix [string range $prefix 0 $prefixend]
1241 incr lev -1
1243 set tail [string range $f [expr {$prefixend+1}] end]
1244 while {[set slash [string first "/" $tail]] >= 0} {
1245 lappend htstack $ht
1246 set ht 0
1247 lappend prefendstack $prefixend
1248 incr prefixend [expr {$slash + 1}]
1249 set d [string range $tail 0 $slash]
1250 lappend treecontents($prefix) $d
1251 set oldprefix $prefix
1252 append prefix $d
1253 set treecontents($prefix) {}
1254 set treeindex($prefix) [incr ix]
1255 set treeparent($prefix) $oldprefix
1256 set tail [string range $tail [expr {$slash+1}] end]
1257 if {$lev <= $openlevs} {
1258 set ht 1
1259 set treediropen($prefix) [expr {$lev < $openlevs}]
1260 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1261 $w mark set d:$ix "end -1c"
1262 $w mark gravity d:$ix left
1263 set str "\n"
1264 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1265 $w insert end $str
1266 $w image create end -align center -image $bm -padx 1 \
1267 -name a:$ix
1268 $w insert end $d [highlight_tag $prefix]
1269 $w mark set s:$ix "end -1c"
1270 $w mark gravity s:$ix left
1272 incr lev
1274 if {$tail ne {}} {
1275 if {$lev <= $openlevs} {
1276 incr ht
1277 set str "\n"
1278 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1279 $w insert end $str
1280 $w insert end $tail [highlight_tag $f]
1282 lappend treecontents($prefix) $tail
1285 while {$htstack ne {}} {
1286 set treeheight($prefix) $ht
1287 incr ht [lindex $htstack end]
1288 set htstack [lreplace $htstack end end]
1289 set prefixend [lindex $prefendstack end]
1290 set prefendstack [lreplace $prefendstack end end]
1291 set prefix [string range $prefix 0 $prefixend]
1293 $w conf -state disabled
1296 proc linetoelt {l} {
1297 global treeheight treecontents
1299 set y 2
1300 set prefix {}
1301 while {1} {
1302 foreach e $treecontents($prefix) {
1303 if {$y == $l} {
1304 return "$prefix$e"
1306 set n 1
1307 if {[string index $e end] eq "/"} {
1308 set n $treeheight($prefix$e)
1309 if {$y + $n > $l} {
1310 append prefix $e
1311 incr y
1312 break
1315 incr y $n
1320 proc highlight_tree {y prefix} {
1321 global treeheight treecontents cflist
1323 foreach e $treecontents($prefix) {
1324 set path $prefix$e
1325 if {[highlight_tag $path] ne {}} {
1326 $cflist tag add bold $y.0 "$y.0 lineend"
1328 incr y
1329 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1330 set y [highlight_tree $y $path]
1333 return $y
1336 proc treeclosedir {w dir} {
1337 global treediropen treeheight treeparent treeindex
1339 set ix $treeindex($dir)
1340 $w conf -state normal
1341 $w delete s:$ix e:$ix
1342 set treediropen($dir) 0
1343 $w image configure a:$ix -image tri-rt
1344 $w conf -state disabled
1345 set n [expr {1 - $treeheight($dir)}]
1346 while {$dir ne {}} {
1347 incr treeheight($dir) $n
1348 set dir $treeparent($dir)
1352 proc treeopendir {w dir} {
1353 global treediropen treeheight treeparent treecontents treeindex
1355 set ix $treeindex($dir)
1356 $w conf -state normal
1357 $w image configure a:$ix -image tri-dn
1358 $w mark set e:$ix s:$ix
1359 $w mark gravity e:$ix right
1360 set lev 0
1361 set str "\n"
1362 set n [llength $treecontents($dir)]
1363 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1364 incr lev
1365 append str "\t"
1366 incr treeheight($x) $n
1368 foreach e $treecontents($dir) {
1369 set de $dir$e
1370 if {[string index $e end] eq "/"} {
1371 set iy $treeindex($de)
1372 $w mark set d:$iy e:$ix
1373 $w mark gravity d:$iy left
1374 $w insert e:$ix $str
1375 set treediropen($de) 0
1376 $w image create e:$ix -align center -image tri-rt -padx 1 \
1377 -name a:$iy
1378 $w insert e:$ix $e [highlight_tag $de]
1379 $w mark set s:$iy e:$ix
1380 $w mark gravity s:$iy left
1381 set treeheight($de) 1
1382 } else {
1383 $w insert e:$ix $str
1384 $w insert e:$ix $e [highlight_tag $de]
1387 $w mark gravity e:$ix left
1388 $w conf -state disabled
1389 set treediropen($dir) 1
1390 set top [lindex [split [$w index @0,0] .] 0]
1391 set ht [$w cget -height]
1392 set l [lindex [split [$w index s:$ix] .] 0]
1393 if {$l < $top} {
1394 $w yview $l.0
1395 } elseif {$l + $n + 1 > $top + $ht} {
1396 set top [expr {$l + $n + 2 - $ht}]
1397 if {$l < $top} {
1398 set top $l
1400 $w yview $top.0
1404 proc treeclick {w x y} {
1405 global treediropen cmitmode ctext cflist cflist_top
1407 if {$cmitmode ne "tree"} return
1408 if {![info exists cflist_top]} return
1409 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1410 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1411 $cflist tag add highlight $l.0 "$l.0 lineend"
1412 set cflist_top $l
1413 if {$l == 1} {
1414 $ctext yview 1.0
1415 return
1417 set e [linetoelt $l]
1418 if {[string index $e end] ne "/"} {
1419 showfile $e
1420 } elseif {$treediropen($e)} {
1421 treeclosedir $w $e
1422 } else {
1423 treeopendir $w $e
1427 proc setfilelist {id} {
1428 global treefilelist cflist
1430 treeview $cflist $treefilelist($id) 0
1433 image create bitmap tri-rt -background black -foreground blue -data {
1434 #define tri-rt_width 13
1435 #define tri-rt_height 13
1436 static unsigned char tri-rt_bits[] = {
1437 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1438 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1439 0x00, 0x00};
1440 } -maskdata {
1441 #define tri-rt-mask_width 13
1442 #define tri-rt-mask_height 13
1443 static unsigned char tri-rt-mask_bits[] = {
1444 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1445 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1446 0x08, 0x00};
1448 image create bitmap tri-dn -background black -foreground blue -data {
1449 #define tri-dn_width 13
1450 #define tri-dn_height 13
1451 static unsigned char tri-dn_bits[] = {
1452 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1453 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1454 0x00, 0x00};
1455 } -maskdata {
1456 #define tri-dn-mask_width 13
1457 #define tri-dn-mask_height 13
1458 static unsigned char tri-dn-mask_bits[] = {
1459 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1460 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1461 0x00, 0x00};
1464 proc init_flist {first} {
1465 global cflist cflist_top selectedline difffilestart
1467 $cflist conf -state normal
1468 $cflist delete 0.0 end
1469 if {$first ne {}} {
1470 $cflist insert end $first
1471 set cflist_top 1
1472 $cflist tag add highlight 1.0 "1.0 lineend"
1473 } else {
1474 catch {unset cflist_top}
1476 $cflist conf -state disabled
1477 set difffilestart {}
1480 proc highlight_tag {f} {
1481 global highlight_paths
1483 foreach p $highlight_paths {
1484 if {[string match $p $f]} {
1485 return "bold"
1488 return {}
1491 proc highlight_filelist {} {
1492 global cmitmode cflist
1494 $cflist conf -state normal
1495 if {$cmitmode ne "tree"} {
1496 set end [lindex [split [$cflist index end] .] 0]
1497 for {set l 2} {$l < $end} {incr l} {
1498 set line [$cflist get $l.0 "$l.0 lineend"]
1499 if {[highlight_tag $line] ne {}} {
1500 $cflist tag add bold $l.0 "$l.0 lineend"
1503 } else {
1504 highlight_tree 2 {}
1506 $cflist conf -state disabled
1509 proc unhighlight_filelist {} {
1510 global cflist
1512 $cflist conf -state normal
1513 $cflist tag remove bold 1.0 end
1514 $cflist conf -state disabled
1517 proc add_flist {fl} {
1518 global cflist
1520 $cflist conf -state normal
1521 foreach f $fl {
1522 $cflist insert end "\n"
1523 $cflist insert end $f [highlight_tag $f]
1525 $cflist conf -state disabled
1528 proc sel_flist {w x y} {
1529 global ctext difffilestart cflist cflist_top cmitmode
1531 if {$cmitmode eq "tree"} return
1532 if {![info exists cflist_top]} return
1533 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1534 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1535 $cflist tag add highlight $l.0 "$l.0 lineend"
1536 set cflist_top $l
1537 if {$l == 1} {
1538 $ctext yview 1.0
1539 } else {
1540 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1544 proc pop_flist_menu {w X Y x y} {
1545 global ctext cflist cmitmode flist_menu flist_menu_file
1546 global treediffs diffids
1548 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1549 if {$l <= 1} return
1550 if {$cmitmode eq "tree"} {
1551 set e [linetoelt $l]
1552 if {[string index $e end] eq "/"} return
1553 } else {
1554 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1556 set flist_menu_file $e
1557 tk_popup $flist_menu $X $Y
1560 proc flist_hl {only} {
1561 global flist_menu_file highlight_files
1563 set x [shellquote $flist_menu_file]
1564 if {$only || $highlight_files eq {}} {
1565 set highlight_files $x
1566 } else {
1567 append highlight_files " " $x
1571 # Functions for adding and removing shell-type quoting
1573 proc shellquote {str} {
1574 if {![string match "*\['\"\\ \t]*" $str]} {
1575 return $str
1577 if {![string match "*\['\"\\]*" $str]} {
1578 return "\"$str\""
1580 if {![string match "*'*" $str]} {
1581 return "'$str'"
1583 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1586 proc shellarglist {l} {
1587 set str {}
1588 foreach a $l {
1589 if {$str ne {}} {
1590 append str " "
1592 append str [shellquote $a]
1594 return $str
1597 proc shelldequote {str} {
1598 set ret {}
1599 set used -1
1600 while {1} {
1601 incr used
1602 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1603 append ret [string range $str $used end]
1604 set used [string length $str]
1605 break
1607 set first [lindex $first 0]
1608 set ch [string index $str $first]
1609 if {$first > $used} {
1610 append ret [string range $str $used [expr {$first - 1}]]
1611 set used $first
1613 if {$ch eq " " || $ch eq "\t"} break
1614 incr used
1615 if {$ch eq "'"} {
1616 set first [string first "'" $str $used]
1617 if {$first < 0} {
1618 error "unmatched single-quote"
1620 append ret [string range $str $used [expr {$first - 1}]]
1621 set used $first
1622 continue
1624 if {$ch eq "\\"} {
1625 if {$used >= [string length $str]} {
1626 error "trailing backslash"
1628 append ret [string index $str $used]
1629 continue
1631 # here ch == "\""
1632 while {1} {
1633 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1634 error "unmatched double-quote"
1636 set first [lindex $first 0]
1637 set ch [string index $str $first]
1638 if {$first > $used} {
1639 append ret [string range $str $used [expr {$first - 1}]]
1640 set used $first
1642 if {$ch eq "\""} break
1643 incr used
1644 append ret [string index $str $used]
1645 incr used
1648 return [list $used $ret]
1651 proc shellsplit {str} {
1652 set l {}
1653 while {1} {
1654 set str [string trimleft $str]
1655 if {$str eq {}} break
1656 set dq [shelldequote $str]
1657 set n [lindex $dq 0]
1658 set word [lindex $dq 1]
1659 set str [string range $str $n end]
1660 lappend l $word
1662 return $l
1665 # Code to implement multiple views
1667 proc newview {ishighlight} {
1668 global nextviewnum newviewname newviewperm uifont newishighlight
1669 global newviewargs revtreeargs
1671 set newishighlight $ishighlight
1672 set top .gitkview
1673 if {[winfo exists $top]} {
1674 raise $top
1675 return
1677 set newviewname($nextviewnum) "View $nextviewnum"
1678 set newviewperm($nextviewnum) 0
1679 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1680 vieweditor $top $nextviewnum "Gitk view definition"
1683 proc editview {} {
1684 global curview
1685 global viewname viewperm newviewname newviewperm
1686 global viewargs newviewargs
1688 set top .gitkvedit-$curview
1689 if {[winfo exists $top]} {
1690 raise $top
1691 return
1693 set newviewname($curview) $viewname($curview)
1694 set newviewperm($curview) $viewperm($curview)
1695 set newviewargs($curview) [shellarglist $viewargs($curview)]
1696 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1699 proc vieweditor {top n title} {
1700 global newviewname newviewperm viewfiles
1701 global uifont
1703 toplevel $top
1704 wm title $top $title
1705 label $top.nl -text "Name" -font $uifont
1706 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1707 grid $top.nl $top.name -sticky w -pady 5
1708 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1709 -font $uifont
1710 grid $top.perm - -pady 5 -sticky w
1711 message $top.al -aspect 1000 -font $uifont \
1712 -text "Commits to include (arguments to git rev-list):"
1713 grid $top.al - -sticky w -pady 5
1714 entry $top.args -width 50 -textvariable newviewargs($n) \
1715 -background white -font $uifont
1716 grid $top.args - -sticky ew -padx 5
1717 message $top.l -aspect 1000 -font $uifont \
1718 -text "Enter files and directories to include, one per line:"
1719 grid $top.l - -sticky w
1720 text $top.t -width 40 -height 10 -background white -font $uifont
1721 if {[info exists viewfiles($n)]} {
1722 foreach f $viewfiles($n) {
1723 $top.t insert end $f
1724 $top.t insert end "\n"
1726 $top.t delete {end - 1c} end
1727 $top.t mark set insert 0.0
1729 grid $top.t - -sticky ew -padx 5
1730 frame $top.buts
1731 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1732 -font $uifont
1733 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1734 -font $uifont
1735 grid $top.buts.ok $top.buts.can
1736 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1737 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1738 grid $top.buts - -pady 10 -sticky ew
1739 focus $top.t
1742 proc doviewmenu {m first cmd op argv} {
1743 set nmenu [$m index end]
1744 for {set i $first} {$i <= $nmenu} {incr i} {
1745 if {[$m entrycget $i -command] eq $cmd} {
1746 eval $m $op $i $argv
1747 break
1752 proc allviewmenus {n op args} {
1753 global viewhlmenu
1755 doviewmenu .bar.view 5 [list showview $n] $op $args
1756 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1759 proc newviewok {top n} {
1760 global nextviewnum newviewperm newviewname newishighlight
1761 global viewname viewfiles viewperm selectedview curview
1762 global viewargs newviewargs viewhlmenu
1764 if {[catch {
1765 set newargs [shellsplit $newviewargs($n)]
1766 } err]} {
1767 error_popup "Error in commit selection arguments: $err"
1768 wm raise $top
1769 focus $top
1770 return
1772 set files {}
1773 foreach f [split [$top.t get 0.0 end] "\n"] {
1774 set ft [string trim $f]
1775 if {$ft ne {}} {
1776 lappend files $ft
1779 if {![info exists viewfiles($n)]} {
1780 # creating a new view
1781 incr nextviewnum
1782 set viewname($n) $newviewname($n)
1783 set viewperm($n) $newviewperm($n)
1784 set viewfiles($n) $files
1785 set viewargs($n) $newargs
1786 addviewmenu $n
1787 if {!$newishighlight} {
1788 run showview $n
1789 } else {
1790 run addvhighlight $n
1792 } else {
1793 # editing an existing view
1794 set viewperm($n) $newviewperm($n)
1795 if {$newviewname($n) ne $viewname($n)} {
1796 set viewname($n) $newviewname($n)
1797 doviewmenu .bar.view 5 [list showview $n] \
1798 entryconf [list -label $viewname($n)]
1799 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1800 entryconf [list -label $viewname($n) -value $viewname($n)]
1802 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1803 set viewfiles($n) $files
1804 set viewargs($n) $newargs
1805 if {$curview == $n} {
1806 run updatecommits
1810 catch {destroy $top}
1813 proc delview {} {
1814 global curview viewdata viewperm hlview selectedhlview
1816 if {$curview == 0} return
1817 if {[info exists hlview] && $hlview == $curview} {
1818 set selectedhlview None
1819 unset hlview
1821 allviewmenus $curview delete
1822 set viewdata($curview) {}
1823 set viewperm($curview) 0
1824 showview 0
1827 proc addviewmenu {n} {
1828 global viewname viewhlmenu
1830 .bar.view add radiobutton -label $viewname($n) \
1831 -command [list showview $n] -variable selectedview -value $n
1832 $viewhlmenu add radiobutton -label $viewname($n) \
1833 -command [list addvhighlight $n] -variable selectedhlview
1836 proc flatten {var} {
1837 global $var
1839 set ret {}
1840 foreach i [array names $var] {
1841 lappend ret $i [set $var\($i\)]
1843 return $ret
1846 proc unflatten {var l} {
1847 global $var
1849 catch {unset $var}
1850 foreach {i v} $l {
1851 set $var\($i\) $v
1855 proc showview {n} {
1856 global curview viewdata viewfiles
1857 global displayorder parentlist rowidlist
1858 global colormap rowtextx commitrow nextcolor canvxmax
1859 global numcommits rowrangelist commitlisted idrowranges rowchk
1860 global selectedline currentid canv canvy0
1861 global treediffs
1862 global pending_select phase
1863 global commitidx rowlaidout rowoptim
1864 global commfd
1865 global selectedview selectfirst
1866 global vparentlist vdisporder vcmitlisted
1867 global hlview selectedhlview
1869 if {$n == $curview} return
1870 set selid {}
1871 if {[info exists selectedline]} {
1872 set selid $currentid
1873 set y [yc $selectedline]
1874 set ymax [lindex [$canv cget -scrollregion] 3]
1875 set span [$canv yview]
1876 set ytop [expr {[lindex $span 0] * $ymax}]
1877 set ybot [expr {[lindex $span 1] * $ymax}]
1878 if {$ytop < $y && $y < $ybot} {
1879 set yscreen [expr {$y - $ytop}]
1880 } else {
1881 set yscreen [expr {($ybot - $ytop) / 2}]
1883 } elseif {[info exists pending_select]} {
1884 set selid $pending_select
1885 unset pending_select
1887 unselectline
1888 normalline
1889 if {$curview >= 0} {
1890 set vparentlist($curview) $parentlist
1891 set vdisporder($curview) $displayorder
1892 set vcmitlisted($curview) $commitlisted
1893 if {$phase ne {}} {
1894 set viewdata($curview) \
1895 [list $phase $rowidlist {} $rowrangelist \
1896 [flatten idrowranges] [flatten idinlist] \
1897 $rowlaidout $rowoptim $numcommits]
1898 } elseif {![info exists viewdata($curview)]
1899 || [lindex $viewdata($curview) 0] ne {}} {
1900 set viewdata($curview) \
1901 [list {} $rowidlist {} $rowrangelist]
1904 catch {unset treediffs}
1905 clear_display
1906 if {[info exists hlview] && $hlview == $n} {
1907 unset hlview
1908 set selectedhlview None
1911 set curview $n
1912 set selectedview $n
1913 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1914 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1916 if {![info exists viewdata($n)]} {
1917 if {$selid ne {}} {
1918 set pending_select $selid
1920 getcommits
1921 return
1924 set v $viewdata($n)
1925 set phase [lindex $v 0]
1926 set displayorder $vdisporder($n)
1927 set parentlist $vparentlist($n)
1928 set commitlisted $vcmitlisted($n)
1929 set rowidlist [lindex $v 1]
1930 set rowrangelist [lindex $v 3]
1931 if {$phase eq {}} {
1932 set numcommits [llength $displayorder]
1933 catch {unset idrowranges}
1934 } else {
1935 unflatten idrowranges [lindex $v 4]
1936 unflatten idinlist [lindex $v 5]
1937 set rowlaidout [lindex $v 6]
1938 set rowoptim [lindex $v 7]
1939 set numcommits [lindex $v 8]
1940 catch {unset rowchk}
1943 catch {unset colormap}
1944 catch {unset rowtextx}
1945 set nextcolor 0
1946 set canvxmax [$canv cget -width]
1947 set curview $n
1948 set row 0
1949 setcanvscroll
1950 set yf 0
1951 set row {}
1952 set selectfirst 0
1953 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1954 set row $commitrow($n,$selid)
1955 # try to get the selected row in the same position on the screen
1956 set ymax [lindex [$canv cget -scrollregion] 3]
1957 set ytop [expr {[yc $row] - $yscreen}]
1958 if {$ytop < 0} {
1959 set ytop 0
1961 set yf [expr {$ytop * 1.0 / $ymax}]
1963 allcanvs yview moveto $yf
1964 drawvisible
1965 if {$row ne {}} {
1966 selectline $row 0
1967 } elseif {$selid ne {}} {
1968 set pending_select $selid
1969 } else {
1970 set row [first_real_row]
1971 if {$row < $numcommits} {
1972 selectline $row 0
1973 } else {
1974 set selectfirst 1
1977 if {$phase ne {}} {
1978 if {$phase eq "getcommits"} {
1979 show_status "Reading commits..."
1981 run chewcommits $n
1982 } elseif {$numcommits == 0} {
1983 show_status "No commits selected"
1987 # Stuff relating to the highlighting facility
1989 proc ishighlighted {row} {
1990 global vhighlights fhighlights nhighlights rhighlights
1992 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1993 return $nhighlights($row)
1995 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1996 return $vhighlights($row)
1998 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1999 return $fhighlights($row)
2001 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2002 return $rhighlights($row)
2004 return 0
2007 proc bolden {row font} {
2008 global canv linehtag selectedline boldrows
2010 lappend boldrows $row
2011 $canv itemconf $linehtag($row) -font $font
2012 if {[info exists selectedline] && $row == $selectedline} {
2013 $canv delete secsel
2014 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2015 -outline {{}} -tags secsel \
2016 -fill [$canv cget -selectbackground]]
2017 $canv lower $t
2021 proc bolden_name {row font} {
2022 global canv2 linentag selectedline boldnamerows
2024 lappend boldnamerows $row
2025 $canv2 itemconf $linentag($row) -font $font
2026 if {[info exists selectedline] && $row == $selectedline} {
2027 $canv2 delete secsel
2028 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2029 -outline {{}} -tags secsel \
2030 -fill [$canv2 cget -selectbackground]]
2031 $canv2 lower $t
2035 proc unbolden {} {
2036 global mainfont boldrows
2038 set stillbold {}
2039 foreach row $boldrows {
2040 if {![ishighlighted $row]} {
2041 bolden $row $mainfont
2042 } else {
2043 lappend stillbold $row
2046 set boldrows $stillbold
2049 proc addvhighlight {n} {
2050 global hlview curview viewdata vhl_done vhighlights commitidx
2052 if {[info exists hlview]} {
2053 delvhighlight
2055 set hlview $n
2056 if {$n != $curview && ![info exists viewdata($n)]} {
2057 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
2058 set vparentlist($n) {}
2059 set vdisporder($n) {}
2060 set vcmitlisted($n) {}
2061 start_rev_list $n
2063 set vhl_done $commitidx($hlview)
2064 if {$vhl_done > 0} {
2065 drawvisible
2069 proc delvhighlight {} {
2070 global hlview vhighlights
2072 if {![info exists hlview]} return
2073 unset hlview
2074 catch {unset vhighlights}
2075 unbolden
2078 proc vhighlightmore {} {
2079 global hlview vhl_done commitidx vhighlights
2080 global displayorder vdisporder curview mainfont
2082 set font [concat $mainfont bold]
2083 set max $commitidx($hlview)
2084 if {$hlview == $curview} {
2085 set disp $displayorder
2086 } else {
2087 set disp $vdisporder($hlview)
2089 set vr [visiblerows]
2090 set r0 [lindex $vr 0]
2091 set r1 [lindex $vr 1]
2092 for {set i $vhl_done} {$i < $max} {incr i} {
2093 set id [lindex $disp $i]
2094 if {[info exists commitrow($curview,$id)]} {
2095 set row $commitrow($curview,$id)
2096 if {$r0 <= $row && $row <= $r1} {
2097 if {![highlighted $row]} {
2098 bolden $row $font
2100 set vhighlights($row) 1
2104 set vhl_done $max
2107 proc askvhighlight {row id} {
2108 global hlview vhighlights commitrow iddrawn mainfont
2110 if {[info exists commitrow($hlview,$id)]} {
2111 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2112 bolden $row [concat $mainfont bold]
2114 set vhighlights($row) 1
2115 } else {
2116 set vhighlights($row) 0
2120 proc hfiles_change {name ix op} {
2121 global highlight_files filehighlight fhighlights fh_serial
2122 global mainfont highlight_paths
2124 if {[info exists filehighlight]} {
2125 # delete previous highlights
2126 catch {close $filehighlight}
2127 unset filehighlight
2128 catch {unset fhighlights}
2129 unbolden
2130 unhighlight_filelist
2132 set highlight_paths {}
2133 after cancel do_file_hl $fh_serial
2134 incr fh_serial
2135 if {$highlight_files ne {}} {
2136 after 300 do_file_hl $fh_serial
2140 proc makepatterns {l} {
2141 set ret {}
2142 foreach e $l {
2143 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2144 if {[string index $ee end] eq "/"} {
2145 lappend ret "$ee*"
2146 } else {
2147 lappend ret $ee
2148 lappend ret "$ee/*"
2151 return $ret
2154 proc do_file_hl {serial} {
2155 global highlight_files filehighlight highlight_paths gdttype fhl_list
2157 if {$gdttype eq "touching paths:"} {
2158 if {[catch {set paths [shellsplit $highlight_files]}]} return
2159 set highlight_paths [makepatterns $paths]
2160 highlight_filelist
2161 set gdtargs [concat -- $paths]
2162 } else {
2163 set gdtargs [list "-S$highlight_files"]
2165 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2166 set filehighlight [open $cmd r+]
2167 fconfigure $filehighlight -blocking 0
2168 filerun $filehighlight readfhighlight
2169 set fhl_list {}
2170 drawvisible
2171 flushhighlights
2174 proc flushhighlights {} {
2175 global filehighlight fhl_list
2177 if {[info exists filehighlight]} {
2178 lappend fhl_list {}
2179 puts $filehighlight ""
2180 flush $filehighlight
2184 proc askfilehighlight {row id} {
2185 global filehighlight fhighlights fhl_list
2187 lappend fhl_list $id
2188 set fhighlights($row) -1
2189 puts $filehighlight $id
2192 proc readfhighlight {} {
2193 global filehighlight fhighlights commitrow curview mainfont iddrawn
2194 global fhl_list
2196 if {![info exists filehighlight]} {
2197 return 0
2199 set nr 0
2200 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2201 set line [string trim $line]
2202 set i [lsearch -exact $fhl_list $line]
2203 if {$i < 0} continue
2204 for {set j 0} {$j < $i} {incr j} {
2205 set id [lindex $fhl_list $j]
2206 if {[info exists commitrow($curview,$id)]} {
2207 set fhighlights($commitrow($curview,$id)) 0
2210 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2211 if {$line eq {}} continue
2212 if {![info exists commitrow($curview,$line)]} continue
2213 set row $commitrow($curview,$line)
2214 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2215 bolden $row [concat $mainfont bold]
2217 set fhighlights($row) 1
2219 if {[eof $filehighlight]} {
2220 # strange...
2221 puts "oops, git diff-tree died"
2222 catch {close $filehighlight}
2223 unset filehighlight
2224 return 0
2226 next_hlcont
2227 return 1
2230 proc find_change {name ix op} {
2231 global nhighlights mainfont boldnamerows
2232 global findstring findpattern findtype
2234 # delete previous highlights, if any
2235 foreach row $boldnamerows {
2236 bolden_name $row $mainfont
2238 set boldnamerows {}
2239 catch {unset nhighlights}
2240 unbolden
2241 unmarkmatches
2242 if {$findtype ne "Regexp"} {
2243 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2244 $findstring]
2245 set findpattern "*$e*"
2247 drawvisible
2250 proc doesmatch {f} {
2251 global findtype findstring findpattern
2253 if {$findtype eq "Regexp"} {
2254 return [regexp $findstring $f]
2255 } elseif {$findtype eq "IgnCase"} {
2256 return [string match -nocase $findpattern $f]
2257 } else {
2258 return [string match $findpattern $f]
2262 proc askfindhighlight {row id} {
2263 global nhighlights commitinfo iddrawn mainfont
2264 global findloc
2265 global markingmatches
2267 if {![info exists commitinfo($id)]} {
2268 getcommit $id
2270 set info $commitinfo($id)
2271 set isbold 0
2272 set fldtypes {Headline Author Date Committer CDate Comments}
2273 foreach f $info ty $fldtypes {
2274 if {($findloc eq "All fields" || $findloc eq $ty) &&
2275 [doesmatch $f]} {
2276 if {$ty eq "Author"} {
2277 set isbold 2
2278 break
2280 set isbold 1
2283 if {$isbold && [info exists iddrawn($id)]} {
2284 set f [concat $mainfont bold]
2285 if {![ishighlighted $row]} {
2286 bolden $row $f
2287 if {$isbold > 1} {
2288 bolden_name $row $f
2291 if {$markingmatches} {
2292 markrowmatches $row $id
2295 set nhighlights($row) $isbold
2298 proc markrowmatches {row id} {
2299 global canv canv2 linehtag linentag commitinfo findloc
2301 set headline [lindex $commitinfo($id) 0]
2302 set author [lindex $commitinfo($id) 1]
2303 $canv delete match$row
2304 $canv2 delete match$row
2305 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2306 set m [findmatches $headline]
2307 if {$m ne {}} {
2308 markmatches $canv $row $headline $linehtag($row) $m \
2309 [$canv itemcget $linehtag($row) -font] $row
2312 if {$findloc eq "All fields" || $findloc eq "Author"} {
2313 set m [findmatches $author]
2314 if {$m ne {}} {
2315 markmatches $canv2 $row $author $linentag($row) $m \
2316 [$canv2 itemcget $linentag($row) -font] $row
2321 proc vrel_change {name ix op} {
2322 global highlight_related
2324 rhighlight_none
2325 if {$highlight_related ne "None"} {
2326 run drawvisible
2330 # prepare for testing whether commits are descendents or ancestors of a
2331 proc rhighlight_sel {a} {
2332 global descendent desc_todo ancestor anc_todo
2333 global highlight_related rhighlights
2335 catch {unset descendent}
2336 set desc_todo [list $a]
2337 catch {unset ancestor}
2338 set anc_todo [list $a]
2339 if {$highlight_related ne "None"} {
2340 rhighlight_none
2341 run drawvisible
2345 proc rhighlight_none {} {
2346 global rhighlights
2348 catch {unset rhighlights}
2349 unbolden
2352 proc is_descendent {a} {
2353 global curview children commitrow descendent desc_todo
2355 set v $curview
2356 set la $commitrow($v,$a)
2357 set todo $desc_todo
2358 set leftover {}
2359 set done 0
2360 for {set i 0} {$i < [llength $todo]} {incr i} {
2361 set do [lindex $todo $i]
2362 if {$commitrow($v,$do) < $la} {
2363 lappend leftover $do
2364 continue
2366 foreach nk $children($v,$do) {
2367 if {![info exists descendent($nk)]} {
2368 set descendent($nk) 1
2369 lappend todo $nk
2370 if {$nk eq $a} {
2371 set done 1
2375 if {$done} {
2376 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2377 return
2380 set descendent($a) 0
2381 set desc_todo $leftover
2384 proc is_ancestor {a} {
2385 global curview parentlist commitrow ancestor anc_todo
2387 set v $curview
2388 set la $commitrow($v,$a)
2389 set todo $anc_todo
2390 set leftover {}
2391 set done 0
2392 for {set i 0} {$i < [llength $todo]} {incr i} {
2393 set do [lindex $todo $i]
2394 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2395 lappend leftover $do
2396 continue
2398 foreach np [lindex $parentlist $commitrow($v,$do)] {
2399 if {![info exists ancestor($np)]} {
2400 set ancestor($np) 1
2401 lappend todo $np
2402 if {$np eq $a} {
2403 set done 1
2407 if {$done} {
2408 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2409 return
2412 set ancestor($a) 0
2413 set anc_todo $leftover
2416 proc askrelhighlight {row id} {
2417 global descendent highlight_related iddrawn mainfont rhighlights
2418 global selectedline ancestor
2420 if {![info exists selectedline]} return
2421 set isbold 0
2422 if {$highlight_related eq "Descendent" ||
2423 $highlight_related eq "Not descendent"} {
2424 if {![info exists descendent($id)]} {
2425 is_descendent $id
2427 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2428 set isbold 1
2430 } elseif {$highlight_related eq "Ancestor" ||
2431 $highlight_related eq "Not ancestor"} {
2432 if {![info exists ancestor($id)]} {
2433 is_ancestor $id
2435 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2436 set isbold 1
2439 if {[info exists iddrawn($id)]} {
2440 if {$isbold && ![ishighlighted $row]} {
2441 bolden $row [concat $mainfont bold]
2444 set rhighlights($row) $isbold
2447 proc next_hlcont {} {
2448 global fhl_row fhl_dirn displayorder numcommits
2449 global vhighlights fhighlights nhighlights rhighlights
2450 global hlview filehighlight findstring highlight_related
2452 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2453 set row $fhl_row
2454 while {1} {
2455 if {$row < 0 || $row >= $numcommits} {
2456 bell
2457 set fhl_dirn 0
2458 return
2460 set id [lindex $displayorder $row]
2461 if {[info exists hlview]} {
2462 if {![info exists vhighlights($row)]} {
2463 askvhighlight $row $id
2465 if {$vhighlights($row) > 0} break
2467 if {$findstring ne {}} {
2468 if {![info exists nhighlights($row)]} {
2469 askfindhighlight $row $id
2471 if {$nhighlights($row) > 0} break
2473 if {$highlight_related ne "None"} {
2474 if {![info exists rhighlights($row)]} {
2475 askrelhighlight $row $id
2477 if {$rhighlights($row) > 0} break
2479 if {[info exists filehighlight]} {
2480 if {![info exists fhighlights($row)]} {
2481 # ask for a few more while we're at it...
2482 set r $row
2483 for {set n 0} {$n < 100} {incr n} {
2484 if {![info exists fhighlights($r)]} {
2485 askfilehighlight $r [lindex $displayorder $r]
2487 incr r $fhl_dirn
2488 if {$r < 0 || $r >= $numcommits} break
2490 flushhighlights
2492 if {$fhighlights($row) < 0} {
2493 set fhl_row $row
2494 return
2496 if {$fhighlights($row) > 0} break
2498 incr row $fhl_dirn
2500 set fhl_dirn 0
2501 selectline $row 1
2504 proc next_highlight {dirn} {
2505 global selectedline fhl_row fhl_dirn
2506 global hlview filehighlight findstring highlight_related
2508 if {![info exists selectedline]} return
2509 if {!([info exists hlview] || $findstring ne {} ||
2510 $highlight_related ne "None" || [info exists filehighlight])} return
2511 set fhl_row [expr {$selectedline + $dirn}]
2512 set fhl_dirn $dirn
2513 next_hlcont
2516 proc cancel_next_highlight {} {
2517 global fhl_dirn
2519 set fhl_dirn 0
2522 # Graph layout functions
2524 proc shortids {ids} {
2525 set res {}
2526 foreach id $ids {
2527 if {[llength $id] > 1} {
2528 lappend res [shortids $id]
2529 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2530 lappend res [string range $id 0 7]
2531 } else {
2532 lappend res $id
2535 return $res
2538 proc incrange {l x o} {
2539 set n [llength $l]
2540 while {$x < $n} {
2541 set e [lindex $l $x]
2542 if {$e ne {}} {
2543 lset l $x [expr {$e + $o}]
2545 incr x
2547 return $l
2550 proc ntimes {n o} {
2551 set ret {}
2552 for {} {$n > 0} {incr n -1} {
2553 lappend ret $o
2555 return $ret
2558 proc usedinrange {id l1 l2} {
2559 global children commitrow curview
2561 if {[info exists commitrow($curview,$id)]} {
2562 set r $commitrow($curview,$id)
2563 if {$l1 <= $r && $r <= $l2} {
2564 return [expr {$r - $l1 + 1}]
2567 set kids $children($curview,$id)
2568 foreach c $kids {
2569 set r $commitrow($curview,$c)
2570 if {$l1 <= $r && $r <= $l2} {
2571 return [expr {$r - $l1 + 1}]
2574 return 0
2577 # Work out where id should go in idlist so that order-token
2578 # values increase from left to right
2579 proc idcol {idlist id {i 0}} {
2580 global ordertok curview
2582 set t $ordertok($curview,$id)
2583 if {$i >= [llength $idlist] ||
2584 $t < $ordertok($curview,[lindex $idlist $i])} {
2585 if {$i > [llength $idlist]} {
2586 set i [llength $idlist]
2588 while {[incr i -1] >= 0 &&
2589 $t < $ordertok($curview,[lindex $idlist $i])} {}
2590 incr i
2591 } else {
2592 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2593 while {[incr i] < [llength $idlist] &&
2594 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2597 return $i
2600 proc makeuparrow {oid y x} {
2601 global rowidlist uparrowlen idrowranges displayorder
2603 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2604 incr y -1
2605 set idl [lindex $rowidlist $y]
2606 set x [idcol $idl $oid $x]
2607 lset rowidlist $y [linsert $idl $x $oid]
2609 lappend idrowranges($oid) [lindex $displayorder $y]
2612 proc initlayout {} {
2613 global rowidlist displayorder commitlisted
2614 global rowlaidout rowoptim
2615 global idinlist rowchk rowrangelist idrowranges
2616 global numcommits canvxmax canv
2617 global nextcolor
2618 global parentlist
2619 global colormap rowtextx
2620 global selectfirst
2622 set numcommits 0
2623 set displayorder {}
2624 set commitlisted {}
2625 set parentlist {}
2626 set rowrangelist {}
2627 set nextcolor 0
2628 set rowidlist {{}}
2629 catch {unset idinlist}
2630 catch {unset rowchk}
2631 set rowlaidout 0
2632 set rowoptim 0
2633 set canvxmax [$canv cget -width]
2634 catch {unset colormap}
2635 catch {unset rowtextx}
2636 catch {unset idrowranges}
2637 set selectfirst 1
2640 proc setcanvscroll {} {
2641 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2643 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2644 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2645 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2646 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2649 proc visiblerows {} {
2650 global canv numcommits linespc
2652 set ymax [lindex [$canv cget -scrollregion] 3]
2653 if {$ymax eq {} || $ymax == 0} return
2654 set f [$canv yview]
2655 set y0 [expr {int([lindex $f 0] * $ymax)}]
2656 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2657 if {$r0 < 0} {
2658 set r0 0
2660 set y1 [expr {int([lindex $f 1] * $ymax)}]
2661 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2662 if {$r1 >= $numcommits} {
2663 set r1 [expr {$numcommits - 1}]
2665 return [list $r0 $r1]
2668 proc layoutmore {tmax allread} {
2669 global rowlaidout rowoptim commitidx numcommits optim_delay
2670 global uparrowlen curview rowidlist idinlist
2672 set showlast 0
2673 set showdelay $optim_delay
2674 set optdelay [expr {$uparrowlen + 1}]
2675 while {1} {
2676 if {$rowoptim - $showdelay > $numcommits} {
2677 showstuff [expr {$rowoptim - $showdelay}] $showlast
2678 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2679 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2680 if {$nr > 100} {
2681 set nr 100
2683 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2684 incr rowoptim $nr
2685 } elseif {$commitidx($curview) > $rowlaidout} {
2686 set nr [expr {$commitidx($curview) - $rowlaidout}]
2687 # may need to increase this threshold if uparrowlen or
2688 # mingaplen are increased...
2689 if {$nr > 200} {
2690 set nr 200
2692 set row $rowlaidout
2693 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2694 if {$rowlaidout == $row} {
2695 return 0
2697 } elseif {$allread} {
2698 set optdelay 0
2699 set nrows $commitidx($curview)
2700 if {[lindex $rowidlist $nrows] ne {} ||
2701 [array names idinlist] ne {}} {
2702 layouttail
2703 set rowlaidout $commitidx($curview)
2704 } elseif {$rowoptim == $nrows} {
2705 set showdelay 0
2706 set showlast 1
2707 if {$numcommits == $nrows} {
2708 return 0
2711 } else {
2712 return 0
2714 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2715 return 1
2720 proc showstuff {canshow last} {
2721 global numcommits commitrow pending_select selectedline curview
2722 global lookingforhead mainheadid displayorder selectfirst
2723 global lastscrollset
2725 if {$numcommits == 0} {
2726 global phase
2727 set phase "incrdraw"
2728 allcanvs delete all
2730 set r0 $numcommits
2731 set prev $numcommits
2732 set numcommits $canshow
2733 set t [clock clicks -milliseconds]
2734 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2735 set lastscrollset $t
2736 setcanvscroll
2738 set rows [visiblerows]
2739 set r1 [lindex $rows 1]
2740 if {$r1 >= $canshow} {
2741 set r1 [expr {$canshow - 1}]
2743 if {$r0 <= $r1} {
2744 drawcommits $r0 $r1
2746 if {[info exists pending_select] &&
2747 [info exists commitrow($curview,$pending_select)] &&
2748 $commitrow($curview,$pending_select) < $numcommits} {
2749 selectline $commitrow($curview,$pending_select) 1
2751 if {$selectfirst} {
2752 if {[info exists selectedline] || [info exists pending_select]} {
2753 set selectfirst 0
2754 } else {
2755 set l [first_real_row]
2756 selectline $l 1
2757 set selectfirst 0
2760 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2761 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2762 set lookingforhead 0
2763 dodiffindex
2767 proc doshowlocalchanges {} {
2768 global lookingforhead curview mainheadid phase commitrow
2770 if {[info exists commitrow($curview,$mainheadid)] &&
2771 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2772 dodiffindex
2773 } elseif {$phase ne {}} {
2774 set lookingforhead 1
2778 proc dohidelocalchanges {} {
2779 global lookingforhead localfrow localirow lserial
2781 set lookingforhead 0
2782 if {$localfrow >= 0} {
2783 removerow $localfrow
2784 set localfrow -1
2785 if {$localirow > 0} {
2786 incr localirow -1
2789 if {$localirow >= 0} {
2790 removerow $localirow
2791 set localirow -1
2793 incr lserial
2796 # spawn off a process to do git diff-index --cached HEAD
2797 proc dodiffindex {} {
2798 global localirow localfrow lserial
2800 incr lserial
2801 set localfrow -1
2802 set localirow -1
2803 set fd [open "|git diff-index --cached HEAD" r]
2804 fconfigure $fd -blocking 0
2805 filerun $fd [list readdiffindex $fd $lserial]
2808 proc readdiffindex {fd serial} {
2809 global localirow commitrow mainheadid nullid2 curview
2810 global commitinfo commitdata lserial
2812 set isdiff 1
2813 if {[gets $fd line] < 0} {
2814 if {![eof $fd]} {
2815 return 1
2817 set isdiff 0
2819 # we only need to see one line and we don't really care what it says...
2820 close $fd
2822 # now see if there are any local changes not checked in to the index
2823 if {$serial == $lserial} {
2824 set fd [open "|git diff-files" r]
2825 fconfigure $fd -blocking 0
2826 filerun $fd [list readdifffiles $fd $serial]
2829 if {$isdiff && $serial == $lserial && $localirow == -1} {
2830 # add the line for the changes in the index to the graph
2831 set localirow $commitrow($curview,$mainheadid)
2832 set hl "Local changes checked in to index but not committed"
2833 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2834 set commitdata($nullid2) "\n $hl\n"
2835 insertrow $localirow $nullid2
2837 return 0
2840 proc readdifffiles {fd serial} {
2841 global localirow localfrow commitrow mainheadid nullid curview
2842 global commitinfo commitdata lserial
2844 set isdiff 1
2845 if {[gets $fd line] < 0} {
2846 if {![eof $fd]} {
2847 return 1
2849 set isdiff 0
2851 # we only need to see one line and we don't really care what it says...
2852 close $fd
2854 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2855 # add the line for the local diff to the graph
2856 if {$localirow >= 0} {
2857 set localfrow $localirow
2858 incr localirow
2859 } else {
2860 set localfrow $commitrow($curview,$mainheadid)
2862 set hl "Local uncommitted changes, not checked in to index"
2863 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2864 set commitdata($nullid) "\n $hl\n"
2865 insertrow $localfrow $nullid
2867 return 0
2870 proc layoutrows {row endrow last} {
2871 global rowidlist displayorder
2872 global uparrowlen downarrowlen maxwidth mingaplen
2873 global children parentlist
2874 global idrowranges
2875 global commitidx curview
2876 global idinlist rowchk rowrangelist
2878 set idlist [lindex $rowidlist $row]
2879 while {$row < $endrow} {
2880 set id [lindex $displayorder $row]
2881 set oldolds {}
2882 set newolds {}
2883 set olds [lindex $parentlist $row]
2884 foreach p $olds {
2885 if {![info exists idinlist($p)]} {
2886 lappend newolds $p
2887 } elseif {!$idinlist($p)} {
2888 lappend oldolds $p
2891 set nev [expr {[llength $idlist] + [llength $newolds]
2892 + [llength $oldolds] - $maxwidth + 1}]
2893 if {1 || $nev > 0} {
2894 if {!$last &&
2895 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2896 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2897 set i [lindex $idlist $x]
2898 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2899 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2900 [expr {$row + $uparrowlen + $mingaplen}]]
2901 if {$r == 0} {
2902 set idlist [lreplace $idlist $x $x]
2903 set idinlist($i) 0
2904 set rm1 [expr {$row - 1}]
2905 lappend idrowranges($i) [lindex $displayorder $rm1]
2906 #if {[incr nev -1] <= 0} break
2907 continue
2909 set rowchk($id) [expr {$row + $r}]
2912 lset rowidlist $row $idlist
2914 set col [lsearch -exact $idlist $id]
2915 if {$col < 0} {
2916 set col [idcol $idlist $id]
2917 set idlist [linsert $idlist $col $id]
2918 lset rowidlist $row $idlist
2919 if {$children($curview,$id) ne {}} {
2920 unset idinlist($id)
2921 makeuparrow $id $row $col
2923 } else {
2924 unset idinlist($id)
2926 set ranges {}
2927 if {[info exists idrowranges($id)]} {
2928 set ranges $idrowranges($id)
2929 lappend ranges $id
2930 unset idrowranges($id)
2932 lappend rowrangelist $ranges
2933 incr row
2934 set idlist [lreplace $idlist $col $col]
2935 set x $col
2936 foreach i $newolds {
2937 set x [idcol $idlist $i $x]
2938 set idlist [linsert $idlist $x $i]
2939 set idinlist($i) 1
2940 set idrowranges($i) $id
2942 foreach oid $oldolds {
2943 set idinlist($oid) 1
2944 set x [idcol $idlist $oid $x]
2945 set idlist [linsert $idlist $x $oid]
2946 makeuparrow $oid $row $x
2948 lappend rowidlist $idlist
2950 return $row
2953 proc addextraid {id row} {
2954 global displayorder commitrow commitinfo
2955 global commitidx commitlisted
2956 global parentlist children curview
2958 incr commitidx($curview)
2959 lappend displayorder $id
2960 lappend commitlisted 0
2961 lappend parentlist {}
2962 set commitrow($curview,$id) $row
2963 readcommit $id
2964 if {![info exists commitinfo($id)]} {
2965 set commitinfo($id) {"No commit information available"}
2967 if {![info exists children($curview,$id)]} {
2968 set children($curview,$id) {}
2972 proc layouttail {} {
2973 global rowidlist idinlist commitidx curview
2974 global idrowranges rowrangelist
2976 set row $commitidx($curview)
2977 set idlist [lindex $rowidlist $row]
2978 while {$idlist ne {}} {
2979 set col [expr {[llength $idlist] - 1}]
2980 set id [lindex $idlist $col]
2981 addextraid $id $row
2982 unset idinlist($id)
2983 lappend idrowranges($id) $id
2984 lappend rowrangelist $idrowranges($id)
2985 unset idrowranges($id)
2986 incr row
2987 set idlist [lreplace $idlist $col $col]
2988 lappend rowidlist $idlist
2991 foreach id [array names idinlist] {
2992 unset idinlist($id)
2993 addextraid $id $row
2994 lset rowidlist $row [list $id]
2995 makeuparrow $id $row 0
2996 lappend idrowranges($id) $id
2997 lappend rowrangelist $idrowranges($id)
2998 unset idrowranges($id)
2999 incr row
3000 lappend rowidlist {}
3004 proc insert_pad {row col npad} {
3005 global rowidlist
3007 set pad [ntimes $npad {}]
3008 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
3011 proc optimize_rows {row col endrow} {
3012 global rowidlist displayorder
3014 if {$row < 1} {
3015 set row 1
3017 set idlist [lindex $rowidlist [expr {$row - 1}]]
3018 if {$row >= 2} {
3019 set previdlist [lindex $rowidlist [expr {$row - 2}]]
3020 } else {
3021 set previdlist {}
3023 for {} {$row < $endrow} {incr row} {
3024 set pprevidlist $previdlist
3025 set previdlist $idlist
3026 set idlist [lindex $rowidlist $row]
3027 set haspad 0
3028 set y0 [expr {$row - 1}]
3029 set ym [expr {$row - 2}]
3030 set x0 -1
3031 set xm -1
3032 for {} {$col < [llength $idlist]} {incr col} {
3033 set id [lindex $idlist $col]
3034 if {[lindex $previdlist $col] eq $id} continue
3035 if {$id eq {}} {
3036 set haspad 1
3037 continue
3039 set x0 [lsearch -exact $previdlist $id]
3040 if {$x0 < 0} continue
3041 set z [expr {$x0 - $col}]
3042 set isarrow 0
3043 set z0 {}
3044 if {$ym >= 0} {
3045 set xm [lsearch -exact $pprevidlist $id]
3046 if {$xm >= 0} {
3047 set z0 [expr {$xm - $x0}]
3050 if {$z0 eq {}} {
3051 set ranges [rowranges $id]
3052 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3053 set isarrow 1
3056 # Looking at lines from this row to the previous row,
3057 # make them go straight up if they end in an arrow on
3058 # the previous row; otherwise make them go straight up
3059 # or at 45 degrees.
3060 if {$z < -1 || ($z < 0 && $isarrow)} {
3061 # Line currently goes left too much;
3062 # insert pads in the previous row, then optimize it
3063 set npad [expr {-1 - $z + $isarrow}]
3064 insert_pad $y0 $x0 $npad
3065 if {$y0 > 0} {
3066 optimize_rows $y0 $x0 $row
3068 set previdlist [lindex $rowidlist $y0]
3069 set x0 [lsearch -exact $previdlist $id]
3070 set z [expr {$x0 - $col}]
3071 if {$z0 ne {}} {
3072 set pprevidlist [lindex $rowidlist $ym]
3073 set xm [lsearch -exact $pprevidlist $id]
3074 set z0 [expr {$xm - $x0}]
3076 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3077 # Line currently goes right too much;
3078 # insert pads in this line
3079 set npad [expr {$z - 1 + $isarrow}]
3080 set pad [ntimes $npad {}]
3081 set idlist [eval linsert \$idlist $col $pad]
3082 incr col $npad
3083 set z [expr {$x0 - $col}]
3084 set haspad 1
3086 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3087 # this line links to its first child on row $row-2
3088 set id [lindex $displayorder $ym]
3089 set xc [lsearch -exact $pprevidlist $id]
3090 if {$xc >= 0} {
3091 set z0 [expr {$xc - $x0}]
3094 # avoid lines jigging left then immediately right
3095 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3096 insert_pad $y0 $x0 1
3097 incr x0
3098 optimize_rows $y0 $x0 $row
3099 set previdlist [lindex $rowidlist $y0]
3100 set pprevidlist [lindex $rowidlist $ym]
3103 if {!$haspad} {
3104 # Find the first column that doesn't have a line going right
3105 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3106 set id [lindex $idlist $col]
3107 if {$id eq {}} break
3108 set x0 [lsearch -exact $previdlist $id]
3109 if {$x0 < 0} {
3110 # check if this is the link to the first child
3111 set ranges [rowranges $id]
3112 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3113 # it is, work out offset to child
3114 set id [lindex $displayorder $y0]
3115 set x0 [lsearch -exact $previdlist $id]
3118 if {$x0 <= $col} break
3120 # Insert a pad at that column as long as it has a line and
3121 # isn't the last column
3122 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3123 set idlist [linsert $idlist $col {}]
3126 lset rowidlist $row $idlist
3127 set col 0
3131 proc xc {row col} {
3132 global canvx0 linespc
3133 return [expr {$canvx0 + $col * $linespc}]
3136 proc yc {row} {
3137 global canvy0 linespc
3138 return [expr {$canvy0 + $row * $linespc}]
3141 proc linewidth {id} {
3142 global thickerline lthickness
3144 set wid $lthickness
3145 if {[info exists thickerline] && $id eq $thickerline} {
3146 set wid [expr {2 * $lthickness}]
3148 return $wid
3151 proc rowranges {id} {
3152 global phase idrowranges commitrow rowlaidout rowrangelist curview
3154 set ranges {}
3155 if {$phase eq {} ||
3156 ([info exists commitrow($curview,$id)]
3157 && $commitrow($curview,$id) < $rowlaidout)} {
3158 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3159 } elseif {[info exists idrowranges($id)]} {
3160 set ranges $idrowranges($id)
3162 set linenos {}
3163 foreach rid $ranges {
3164 lappend linenos $commitrow($curview,$rid)
3166 if {$linenos ne {}} {
3167 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3169 return $linenos
3172 # work around tk8.4 refusal to draw arrows on diagonal segments
3173 proc adjarrowhigh {coords} {
3174 global linespc
3176 set x0 [lindex $coords 0]
3177 set x1 [lindex $coords 2]
3178 if {$x0 != $x1} {
3179 set y0 [lindex $coords 1]
3180 set y1 [lindex $coords 3]
3181 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3182 # we have a nearby vertical segment, just trim off the diag bit
3183 set coords [lrange $coords 2 end]
3184 } else {
3185 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3186 set xi [expr {$x0 - $slope * $linespc / 2}]
3187 set yi [expr {$y0 - $linespc / 2}]
3188 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3191 return $coords
3194 proc drawlineseg {id row endrow arrowlow} {
3195 global rowidlist displayorder iddrawn linesegs
3196 global canv colormap linespc curview maxlinelen
3198 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3199 set le [expr {$row + 1}]
3200 set arrowhigh 1
3201 while {1} {
3202 set c [lsearch -exact [lindex $rowidlist $le] $id]
3203 if {$c < 0} {
3204 incr le -1
3205 break
3207 lappend cols $c
3208 set x [lindex $displayorder $le]
3209 if {$x eq $id} {
3210 set arrowhigh 0
3211 break
3213 if {[info exists iddrawn($x)] || $le == $endrow} {
3214 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3215 if {$c >= 0} {
3216 lappend cols $c
3217 set arrowhigh 0
3219 break
3221 incr le
3223 if {$le <= $row} {
3224 return $row
3227 set lines {}
3228 set i 0
3229 set joinhigh 0
3230 if {[info exists linesegs($id)]} {
3231 set lines $linesegs($id)
3232 foreach li $lines {
3233 set r0 [lindex $li 0]
3234 if {$r0 > $row} {
3235 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3236 set joinhigh 1
3238 break
3240 incr i
3243 set joinlow 0
3244 if {$i > 0} {
3245 set li [lindex $lines [expr {$i-1}]]
3246 set r1 [lindex $li 1]
3247 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3248 set joinlow 1
3252 set x [lindex $cols [expr {$le - $row}]]
3253 set xp [lindex $cols [expr {$le - 1 - $row}]]
3254 set dir [expr {$xp - $x}]
3255 if {$joinhigh} {
3256 set ith [lindex $lines $i 2]
3257 set coords [$canv coords $ith]
3258 set ah [$canv itemcget $ith -arrow]
3259 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3260 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3261 if {$x2 ne {} && $x - $x2 == $dir} {
3262 set coords [lrange $coords 0 end-2]
3264 } else {
3265 set coords [list [xc $le $x] [yc $le]]
3267 if {$joinlow} {
3268 set itl [lindex $lines [expr {$i-1}] 2]
3269 set al [$canv itemcget $itl -arrow]
3270 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3271 } elseif {$arrowlow &&
3272 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3273 set arrowlow 0
3275 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3276 for {set y $le} {[incr y -1] > $row} {} {
3277 set x $xp
3278 set xp [lindex $cols [expr {$y - 1 - $row}]]
3279 set ndir [expr {$xp - $x}]
3280 if {$dir != $ndir || $xp < 0} {
3281 lappend coords [xc $y $x] [yc $y]
3283 set dir $ndir
3285 if {!$joinlow} {
3286 if {$xp < 0} {
3287 # join parent line to first child
3288 set ch [lindex $displayorder $row]
3289 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3290 if {$xc < 0} {
3291 puts "oops: drawlineseg: child $ch not on row $row"
3292 } else {
3293 if {$xc < $x - 1} {
3294 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3295 } elseif {$xc > $x + 1} {
3296 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3298 set x $xc
3300 lappend coords [xc $row $x] [yc $row]
3301 } else {
3302 set xn [xc $row $xp]
3303 set yn [yc $row]
3304 # work around tk8.4 refusal to draw arrows on diagonal segments
3305 if {$arrowlow && $xn != [lindex $coords end-1]} {
3306 if {[llength $coords] < 4 ||
3307 [lindex $coords end-3] != [lindex $coords end-1] ||
3308 [lindex $coords end] - $yn > 2 * $linespc} {
3309 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3310 set yo [yc [expr {$row + 0.5}]]
3311 lappend coords $xn $yo $xn $yn
3313 } else {
3314 lappend coords $xn $yn
3317 if {!$joinhigh} {
3318 if {$arrowhigh} {
3319 set coords [adjarrowhigh $coords]
3321 assigncolor $id
3322 set t [$canv create line $coords -width [linewidth $id] \
3323 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3324 $canv lower $t
3325 bindline $t $id
3326 set lines [linsert $lines $i [list $row $le $t]]
3327 } else {
3328 $canv coords $ith $coords
3329 if {$arrow ne $ah} {
3330 $canv itemconf $ith -arrow $arrow
3332 lset lines $i 0 $row
3334 } else {
3335 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3336 set ndir [expr {$xo - $xp}]
3337 set clow [$canv coords $itl]
3338 if {$dir == $ndir} {
3339 set clow [lrange $clow 2 end]
3341 set coords [concat $coords $clow]
3342 if {!$joinhigh} {
3343 lset lines [expr {$i-1}] 1 $le
3344 if {$arrowhigh} {
3345 set coords [adjarrowhigh $coords]
3347 } else {
3348 # coalesce two pieces
3349 $canv delete $ith
3350 set b [lindex $lines [expr {$i-1}] 0]
3351 set e [lindex $lines $i 1]
3352 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3354 $canv coords $itl $coords
3355 if {$arrow ne $al} {
3356 $canv itemconf $itl -arrow $arrow
3360 set linesegs($id) $lines
3361 return $le
3364 proc drawparentlinks {id row} {
3365 global rowidlist canv colormap curview parentlist
3366 global idpos
3368 set rowids [lindex $rowidlist $row]
3369 set col [lsearch -exact $rowids $id]
3370 if {$col < 0} return
3371 set olds [lindex $parentlist $row]
3372 set row2 [expr {$row + 1}]
3373 set x [xc $row $col]
3374 set y [yc $row]
3375 set y2 [yc $row2]
3376 set ids [lindex $rowidlist $row2]
3377 # rmx = right-most X coord used
3378 set rmx 0
3379 foreach p $olds {
3380 set i [lsearch -exact $ids $p]
3381 if {$i < 0} {
3382 puts "oops, parent $p of $id not in list"
3383 continue
3385 set x2 [xc $row2 $i]
3386 if {$x2 > $rmx} {
3387 set rmx $x2
3389 if {[lsearch -exact $rowids $p] < 0} {
3390 # drawlineseg will do this one for us
3391 continue
3393 assigncolor $p
3394 # should handle duplicated parents here...
3395 set coords [list $x $y]
3396 if {$i < $col - 1} {
3397 lappend coords [xc $row [expr {$i + 1}]] $y
3398 } elseif {$i > $col + 1} {
3399 lappend coords [xc $row [expr {$i - 1}]] $y
3401 lappend coords $x2 $y2
3402 set t [$canv create line $coords -width [linewidth $p] \
3403 -fill $colormap($p) -tags lines.$p]
3404 $canv lower $t
3405 bindline $t $p
3407 if {$rmx > [lindex $idpos($id) 1]} {
3408 lset idpos($id) 1 $rmx
3409 redrawtags $id
3413 proc drawlines {id} {
3414 global canv
3416 $canv itemconf lines.$id -width [linewidth $id]
3419 proc drawcmittext {id row col} {
3420 global linespc canv canv2 canv3 canvy0 fgcolor curview
3421 global commitlisted commitinfo rowidlist parentlist
3422 global rowtextx idpos idtags idheads idotherrefs
3423 global linehtag linentag linedtag
3424 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3426 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3427 set listed [lindex $commitlisted $row]
3428 if {$id eq $nullid} {
3429 set ofill red
3430 } elseif {$id eq $nullid2} {
3431 set ofill green
3432 } else {
3433 set ofill [expr {$listed != 0? "blue": "white"}]
3435 set x [xc $row $col]
3436 set y [yc $row]
3437 set orad [expr {$linespc / 3}]
3438 if {$listed <= 1} {
3439 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3440 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3441 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3442 } elseif {$listed == 2} {
3443 # triangle pointing left for left-side commits
3444 set t [$canv create polygon \
3445 [expr {$x - $orad}] $y \
3446 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3447 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3448 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3449 } else {
3450 # triangle pointing right for right-side commits
3451 set t [$canv create polygon \
3452 [expr {$x + $orad - 1}] $y \
3453 [expr {$x - $orad}] [expr {$y - $orad}] \
3454 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3455 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3457 $canv raise $t
3458 $canv bind $t <1> {selcanvline {} %x %y}
3459 set rmx [llength [lindex $rowidlist $row]]
3460 set olds [lindex $parentlist $row]
3461 if {$olds ne {}} {
3462 set nextids [lindex $rowidlist [expr {$row + 1}]]
3463 foreach p $olds {
3464 set i [lsearch -exact $nextids $p]
3465 if {$i > $rmx} {
3466 set rmx $i
3470 set xt [xc $row $rmx]
3471 set rowtextx($row) $xt
3472 set idpos($id) [list $x $xt $y]
3473 if {[info exists idtags($id)] || [info exists idheads($id)]
3474 || [info exists idotherrefs($id)]} {
3475 set xt [drawtags $id $x $xt $y]
3477 set headline [lindex $commitinfo($id) 0]
3478 set name [lindex $commitinfo($id) 1]
3479 set date [lindex $commitinfo($id) 2]
3480 set date [formatdate $date]
3481 set font $mainfont
3482 set nfont $mainfont
3483 set isbold [ishighlighted $row]
3484 if {$isbold > 0} {
3485 lappend boldrows $row
3486 lappend font bold
3487 if {$isbold > 1} {
3488 lappend boldnamerows $row
3489 lappend nfont bold
3492 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3493 -text $headline -font $font -tags text]
3494 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3495 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3496 -text $name -font $nfont -tags text]
3497 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3498 -text $date -font $mainfont -tags text]
3499 set xr [expr {$xt + [font measure $mainfont $headline]}]
3500 if {$xr > $canvxmax} {
3501 set canvxmax $xr
3502 setcanvscroll
3506 proc drawcmitrow {row} {
3507 global displayorder rowidlist
3508 global iddrawn markingmatches
3509 global commitinfo parentlist numcommits
3510 global filehighlight fhighlights findstring nhighlights
3511 global hlview vhighlights
3512 global highlight_related rhighlights
3514 if {$row >= $numcommits} return
3516 set id [lindex $displayorder $row]
3517 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3518 askvhighlight $row $id
3520 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3521 askfilehighlight $row $id
3523 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3524 askfindhighlight $row $id
3526 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3527 askrelhighlight $row $id
3529 if {![info exists iddrawn($id)]} {
3530 set col [lsearch -exact [lindex $rowidlist $row] $id]
3531 if {$col < 0} {
3532 puts "oops, row $row id $id not in list"
3533 return
3535 if {![info exists commitinfo($id)]} {
3536 getcommit $id
3538 assigncolor $id
3539 drawcmittext $id $row $col
3540 set iddrawn($id) 1
3542 if {$markingmatches} {
3543 markrowmatches $row $id
3547 proc drawcommits {row {endrow {}}} {
3548 global numcommits iddrawn displayorder curview
3549 global parentlist rowidlist
3551 if {$row < 0} {
3552 set row 0
3554 if {$endrow eq {}} {
3555 set endrow $row
3557 if {$endrow >= $numcommits} {
3558 set endrow [expr {$numcommits - 1}]
3561 # make the lines join to already-drawn rows either side
3562 set r [expr {$row - 1}]
3563 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3564 set r $row
3566 set er [expr {$endrow + 1}]
3567 if {$er >= $numcommits ||
3568 ![info exists iddrawn([lindex $displayorder $er])]} {
3569 set er $endrow
3571 for {} {$r <= $er} {incr r} {
3572 set id [lindex $displayorder $r]
3573 set wasdrawn [info exists iddrawn($id)]
3574 drawcmitrow $r
3575 if {$r == $er} break
3576 set nextid [lindex $displayorder [expr {$r + 1}]]
3577 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3578 catch {unset prevlines}
3579 continue
3581 drawparentlinks $id $r
3583 if {[info exists lineends($r)]} {
3584 foreach lid $lineends($r) {
3585 unset prevlines($lid)
3588 set rowids [lindex $rowidlist $r]
3589 foreach lid $rowids {
3590 if {$lid eq {}} continue
3591 if {$lid eq $id} {
3592 # see if this is the first child of any of its parents
3593 foreach p [lindex $parentlist $r] {
3594 if {[lsearch -exact $rowids $p] < 0} {
3595 # make this line extend up to the child
3596 set le [drawlineseg $p $r $er 0]
3597 lappend lineends($le) $p
3598 set prevlines($p) 1
3601 } elseif {![info exists prevlines($lid)]} {
3602 set le [drawlineseg $lid $r $er 1]
3603 lappend lineends($le) $lid
3604 set prevlines($lid) 1
3610 proc drawfrac {f0 f1} {
3611 global canv linespc
3613 set ymax [lindex [$canv cget -scrollregion] 3]
3614 if {$ymax eq {} || $ymax == 0} return
3615 set y0 [expr {int($f0 * $ymax)}]
3616 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3617 set y1 [expr {int($f1 * $ymax)}]
3618 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3619 drawcommits $row $endrow
3622 proc drawvisible {} {
3623 global canv
3624 eval drawfrac [$canv yview]
3627 proc clear_display {} {
3628 global iddrawn linesegs
3629 global vhighlights fhighlights nhighlights rhighlights
3631 allcanvs delete all
3632 catch {unset iddrawn}
3633 catch {unset linesegs}
3634 catch {unset vhighlights}
3635 catch {unset fhighlights}
3636 catch {unset nhighlights}
3637 catch {unset rhighlights}
3640 proc findcrossings {id} {
3641 global rowidlist parentlist numcommits displayorder
3643 set cross {}
3644 set ccross {}
3645 foreach {s e} [rowranges $id] {
3646 if {$e >= $numcommits} {
3647 set e [expr {$numcommits - 1}]
3649 if {$e <= $s} continue
3650 for {set row $e} {[incr row -1] >= $s} {} {
3651 set x [lsearch -exact [lindex $rowidlist $row] $id]
3652 if {$x < 0} break
3653 set olds [lindex $parentlist $row]
3654 set kid [lindex $displayorder $row]
3655 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3656 if {$kidx < 0} continue
3657 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3658 foreach p $olds {
3659 set px [lsearch -exact $nextrow $p]
3660 if {$px < 0} continue
3661 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3662 if {[lsearch -exact $ccross $p] >= 0} continue
3663 if {$x == $px + ($kidx < $px? -1: 1)} {
3664 lappend ccross $p
3665 } elseif {[lsearch -exact $cross $p] < 0} {
3666 lappend cross $p
3672 return [concat $ccross {{}} $cross]
3675 proc assigncolor {id} {
3676 global colormap colors nextcolor
3677 global commitrow parentlist children children curview
3679 if {[info exists colormap($id)]} return
3680 set ncolors [llength $colors]
3681 if {[info exists children($curview,$id)]} {
3682 set kids $children($curview,$id)
3683 } else {
3684 set kids {}
3686 if {[llength $kids] == 1} {
3687 set child [lindex $kids 0]
3688 if {[info exists colormap($child)]
3689 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3690 set colormap($id) $colormap($child)
3691 return
3694 set badcolors {}
3695 set origbad {}
3696 foreach x [findcrossings $id] {
3697 if {$x eq {}} {
3698 # delimiter between corner crossings and other crossings
3699 if {[llength $badcolors] >= $ncolors - 1} break
3700 set origbad $badcolors
3702 if {[info exists colormap($x)]
3703 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3704 lappend badcolors $colormap($x)
3707 if {[llength $badcolors] >= $ncolors} {
3708 set badcolors $origbad
3710 set origbad $badcolors
3711 if {[llength $badcolors] < $ncolors - 1} {
3712 foreach child $kids {
3713 if {[info exists colormap($child)]
3714 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3715 lappend badcolors $colormap($child)
3717 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3718 if {[info exists colormap($p)]
3719 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3720 lappend badcolors $colormap($p)
3724 if {[llength $badcolors] >= $ncolors} {
3725 set badcolors $origbad
3728 for {set i 0} {$i <= $ncolors} {incr i} {
3729 set c [lindex $colors $nextcolor]
3730 if {[incr nextcolor] >= $ncolors} {
3731 set nextcolor 0
3733 if {[lsearch -exact $badcolors $c]} break
3735 set colormap($id) $c
3738 proc bindline {t id} {
3739 global canv
3741 $canv bind $t <Enter> "lineenter %x %y $id"
3742 $canv bind $t <Motion> "linemotion %x %y $id"
3743 $canv bind $t <Leave> "lineleave $id"
3744 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3747 proc drawtags {id x xt y1} {
3748 global idtags idheads idotherrefs mainhead
3749 global linespc lthickness
3750 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3752 set marks {}
3753 set ntags 0
3754 set nheads 0
3755 if {[info exists idtags($id)]} {
3756 set marks $idtags($id)
3757 set ntags [llength $marks]
3759 if {[info exists idheads($id)]} {
3760 set marks [concat $marks $idheads($id)]
3761 set nheads [llength $idheads($id)]
3763 if {[info exists idotherrefs($id)]} {
3764 set marks [concat $marks $idotherrefs($id)]
3766 if {$marks eq {}} {
3767 return $xt
3770 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3771 set yt [expr {$y1 - 0.5 * $linespc}]
3772 set yb [expr {$yt + $linespc - 1}]
3773 set xvals {}
3774 set wvals {}
3775 set i -1
3776 foreach tag $marks {
3777 incr i
3778 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3779 set wid [font measure [concat $mainfont bold] $tag]
3780 } else {
3781 set wid [font measure $mainfont $tag]
3783 lappend xvals $xt
3784 lappend wvals $wid
3785 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3787 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3788 -width $lthickness -fill black -tags tag.$id]
3789 $canv lower $t
3790 foreach tag $marks x $xvals wid $wvals {
3791 set xl [expr {$x + $delta}]
3792 set xr [expr {$x + $delta + $wid + $lthickness}]
3793 set font $mainfont
3794 if {[incr ntags -1] >= 0} {
3795 # draw a tag
3796 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3797 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3798 -width 1 -outline black -fill yellow -tags tag.$id]
3799 $canv bind $t <1> [list showtag $tag 1]
3800 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3801 } else {
3802 # draw a head or other ref
3803 if {[incr nheads -1] >= 0} {
3804 set col green
3805 if {$tag eq $mainhead} {
3806 lappend font bold
3808 } else {
3809 set col "#ddddff"
3811 set xl [expr {$xl - $delta/2}]
3812 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3813 -width 1 -outline black -fill $col -tags tag.$id
3814 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3815 set rwid [font measure $mainfont $remoteprefix]
3816 set xi [expr {$x + 1}]
3817 set yti [expr {$yt + 1}]
3818 set xri [expr {$x + $rwid}]
3819 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3820 -width 0 -fill "#ffddaa" -tags tag.$id
3823 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3824 -font $font -tags [list tag.$id text]]
3825 if {$ntags >= 0} {
3826 $canv bind $t <1> [list showtag $tag 1]
3827 } elseif {$nheads >= 0} {
3828 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3831 return $xt
3834 proc xcoord {i level ln} {
3835 global canvx0 xspc1 xspc2
3837 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3838 if {$i > 0 && $i == $level} {
3839 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3840 } elseif {$i > $level} {
3841 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3843 return $x
3846 proc show_status {msg} {
3847 global canv mainfont fgcolor
3849 clear_display
3850 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3851 -tags text -fill $fgcolor
3854 # Insert a new commit as the child of the commit on row $row.
3855 # The new commit will be displayed on row $row and the commits
3856 # on that row and below will move down one row.
3857 proc insertrow {row newcmit} {
3858 global displayorder parentlist commitlisted children
3859 global commitrow curview rowidlist numcommits
3860 global rowrangelist rowlaidout rowoptim numcommits
3861 global selectedline rowchk commitidx
3863 if {$row >= $numcommits} {
3864 puts "oops, inserting new row $row but only have $numcommits rows"
3865 return
3867 set p [lindex $displayorder $row]
3868 set displayorder [linsert $displayorder $row $newcmit]
3869 set parentlist [linsert $parentlist $row $p]
3870 set kids $children($curview,$p)
3871 lappend kids $newcmit
3872 set children($curview,$p) $kids
3873 set children($curview,$newcmit) {}
3874 set commitlisted [linsert $commitlisted $row 1]
3875 set l [llength $displayorder]
3876 for {set r $row} {$r < $l} {incr r} {
3877 set id [lindex $displayorder $r]
3878 set commitrow($curview,$id) $r
3880 incr commitidx($curview)
3882 set idlist [lindex $rowidlist $row]
3883 if {[llength $kids] == 1} {
3884 set col [lsearch -exact $idlist $p]
3885 lset idlist $col $newcmit
3886 } else {
3887 set col [llength $idlist]
3888 lappend idlist $newcmit
3890 set rowidlist [linsert $rowidlist $row $idlist]
3892 set rowrangelist [linsert $rowrangelist $row {}]
3893 if {[llength $kids] > 1} {
3894 set rp1 [expr {$row + 1}]
3895 set ranges [lindex $rowrangelist $rp1]
3896 if {$ranges eq {}} {
3897 set ranges [list $newcmit $p]
3898 } elseif {[lindex $ranges end-1] eq $p} {
3899 lset ranges end-1 $newcmit
3901 lset rowrangelist $rp1 $ranges
3904 catch {unset rowchk}
3906 incr rowlaidout
3907 incr rowoptim
3908 incr numcommits
3910 if {[info exists selectedline] && $selectedline >= $row} {
3911 incr selectedline
3913 redisplay
3916 # Remove a commit that was inserted with insertrow on row $row.
3917 proc removerow {row} {
3918 global displayorder parentlist commitlisted children
3919 global commitrow curview rowidlist numcommits
3920 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3921 global linesegends selectedline rowchk commitidx
3923 if {$row >= $numcommits} {
3924 puts "oops, removing row $row but only have $numcommits rows"
3925 return
3927 set rp1 [expr {$row + 1}]
3928 set id [lindex $displayorder $row]
3929 set p [lindex $parentlist $row]
3930 set displayorder [lreplace $displayorder $row $row]
3931 set parentlist [lreplace $parentlist $row $row]
3932 set commitlisted [lreplace $commitlisted $row $row]
3933 set kids $children($curview,$p)
3934 set i [lsearch -exact $kids $id]
3935 if {$i >= 0} {
3936 set kids [lreplace $kids $i $i]
3937 set children($curview,$p) $kids
3939 set l [llength $displayorder]
3940 for {set r $row} {$r < $l} {incr r} {
3941 set id [lindex $displayorder $r]
3942 set commitrow($curview,$id) $r
3944 incr commitidx($curview) -1
3946 set rowidlist [lreplace $rowidlist $row $row]
3948 set rowrangelist [lreplace $rowrangelist $row $row]
3949 if {[llength $kids] > 0} {
3950 set ranges [lindex $rowrangelist $row]
3951 if {[lindex $ranges end-1] eq $id} {
3952 set ranges [lreplace $ranges end-1 end]
3953 lset rowrangelist $row $ranges
3957 catch {unset rowchk}
3959 incr rowlaidout -1
3960 incr rowoptim -1
3961 incr numcommits -1
3963 if {[info exists selectedline] && $selectedline > $row} {
3964 incr selectedline -1
3966 redisplay
3969 # Don't change the text pane cursor if it is currently the hand cursor,
3970 # showing that we are over a sha1 ID link.
3971 proc settextcursor {c} {
3972 global ctext curtextcursor
3974 if {[$ctext cget -cursor] == $curtextcursor} {
3975 $ctext config -cursor $c
3977 set curtextcursor $c
3980 proc nowbusy {what} {
3981 global isbusy
3983 if {[array names isbusy] eq {}} {
3984 . config -cursor watch
3985 settextcursor watch
3987 set isbusy($what) 1
3990 proc notbusy {what} {
3991 global isbusy maincursor textcursor
3993 catch {unset isbusy($what)}
3994 if {[array names isbusy] eq {}} {
3995 . config -cursor $maincursor
3996 settextcursor $textcursor
4000 proc findmatches {f} {
4001 global findtype findstring
4002 if {$findtype == "Regexp"} {
4003 set matches [regexp -indices -all -inline $findstring $f]
4004 } else {
4005 set fs $findstring
4006 if {$findtype == "IgnCase"} {
4007 set f [string tolower $f]
4008 set fs [string tolower $fs]
4010 set matches {}
4011 set i 0
4012 set l [string length $fs]
4013 while {[set j [string first $fs $f $i]] >= 0} {
4014 lappend matches [list $j [expr {$j+$l-1}]]
4015 set i [expr {$j + $l}]
4018 return $matches
4021 proc dofind {{rev 0}} {
4022 global findstring findstartline findcurline selectedline numcommits
4024 unmarkmatches
4025 cancel_next_highlight
4026 focus .
4027 if {$findstring eq {} || $numcommits == 0} return
4028 if {![info exists selectedline]} {
4029 set findstartline [lindex [visiblerows] $rev]
4030 } else {
4031 set findstartline $selectedline
4033 set findcurline $findstartline
4034 nowbusy finding
4035 if {!$rev} {
4036 run findmore
4037 } else {
4038 if {$findcurline == 0} {
4039 set findcurline $numcommits
4041 incr findcurline -1
4042 run findmorerev
4046 proc findnext {restart} {
4047 global findcurline
4048 if {![info exists findcurline]} {
4049 if {$restart} {
4050 dofind
4051 } else {
4052 bell
4054 } else {
4055 run findmore
4056 nowbusy finding
4060 proc findprev {} {
4061 global findcurline
4062 if {![info exists findcurline]} {
4063 dofind 1
4064 } else {
4065 run findmorerev
4066 nowbusy finding
4070 proc findmore {} {
4071 global commitdata commitinfo numcommits findstring findpattern findloc
4072 global findstartline findcurline displayorder
4074 set fldtypes {Headline Author Date Committer CDate Comments}
4075 set l [expr {$findcurline + 1}]
4076 if {$l >= $numcommits} {
4077 set l 0
4079 if {$l <= $findstartline} {
4080 set lim [expr {$findstartline + 1}]
4081 } else {
4082 set lim $numcommits
4084 if {$lim - $l > 500} {
4085 set lim [expr {$l + 500}]
4087 set last 0
4088 for {} {$l < $lim} {incr l} {
4089 set id [lindex $displayorder $l]
4090 # shouldn't happen unless git log doesn't give all the commits...
4091 if {![info exists commitdata($id)]} continue
4092 if {![doesmatch $commitdata($id)]} continue
4093 if {![info exists commitinfo($id)]} {
4094 getcommit $id
4096 set info $commitinfo($id)
4097 foreach f $info ty $fldtypes {
4098 if {($findloc eq "All fields" || $findloc eq $ty) &&
4099 [doesmatch $f]} {
4100 findselectline $l
4101 notbusy finding
4102 return 0
4106 if {$l == $findstartline + 1} {
4107 bell
4108 unset findcurline
4109 notbusy finding
4110 return 0
4112 set findcurline [expr {$l - 1}]
4113 return 1
4116 proc findmorerev {} {
4117 global commitdata commitinfo numcommits findstring findpattern findloc
4118 global findstartline findcurline displayorder
4120 set fldtypes {Headline Author Date Committer CDate Comments}
4121 set l $findcurline
4122 if {$l == 0} {
4123 set l $numcommits
4125 incr l -1
4126 if {$l >= $findstartline} {
4127 set lim [expr {$findstartline - 1}]
4128 } else {
4129 set lim -1
4131 if {$l - $lim > 500} {
4132 set lim [expr {$l - 500}]
4134 set last 0
4135 for {} {$l > $lim} {incr l -1} {
4136 set id [lindex $displayorder $l]
4137 if {![doesmatch $commitdata($id)]} continue
4138 if {![info exists commitinfo($id)]} {
4139 getcommit $id
4141 set info $commitinfo($id)
4142 foreach f $info ty $fldtypes {
4143 if {($findloc eq "All fields" || $findloc eq $ty) &&
4144 [doesmatch $f]} {
4145 findselectline $l
4146 notbusy finding
4147 return 0
4151 if {$l == -1} {
4152 bell
4153 unset findcurline
4154 notbusy finding
4155 return 0
4157 set findcurline [expr {$l + 1}]
4158 return 1
4161 proc findselectline {l} {
4162 global findloc commentend ctext findcurline markingmatches
4164 set markingmatches 1
4165 set findcurline $l
4166 selectline $l 1
4167 if {$findloc == "All fields" || $findloc == "Comments"} {
4168 # highlight the matches in the comments
4169 set f [$ctext get 1.0 $commentend]
4170 set matches [findmatches $f]
4171 foreach match $matches {
4172 set start [lindex $match 0]
4173 set end [expr {[lindex $match 1] + 1}]
4174 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4177 drawvisible
4180 # mark the bits of a headline or author that match a find string
4181 proc markmatches {canv l str tag matches font row} {
4182 global selectedline
4184 set bbox [$canv bbox $tag]
4185 set x0 [lindex $bbox 0]
4186 set y0 [lindex $bbox 1]
4187 set y1 [lindex $bbox 3]
4188 foreach match $matches {
4189 set start [lindex $match 0]
4190 set end [lindex $match 1]
4191 if {$start > $end} continue
4192 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4193 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4194 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4195 [expr {$x0+$xlen+2}] $y1 \
4196 -outline {} -tags [list match$l matches] -fill yellow]
4197 $canv lower $t
4198 if {[info exists selectedline] && $row == $selectedline} {
4199 $canv raise $t secsel
4204 proc unmarkmatches {} {
4205 global findids markingmatches findcurline
4207 allcanvs delete matches
4208 catch {unset findids}
4209 set markingmatches 0
4210 catch {unset findcurline}
4213 proc selcanvline {w x y} {
4214 global canv canvy0 ctext linespc
4215 global rowtextx
4216 set ymax [lindex [$canv cget -scrollregion] 3]
4217 if {$ymax == {}} return
4218 set yfrac [lindex [$canv yview] 0]
4219 set y [expr {$y + $yfrac * $ymax}]
4220 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4221 if {$l < 0} {
4222 set l 0
4224 if {$w eq $canv} {
4225 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4227 unmarkmatches
4228 selectline $l 1
4231 proc commit_descriptor {p} {
4232 global commitinfo
4233 if {![info exists commitinfo($p)]} {
4234 getcommit $p
4236 set l "..."
4237 if {[llength $commitinfo($p)] > 1} {
4238 set l [lindex $commitinfo($p) 0]
4240 return "$p ($l)\n"
4243 # append some text to the ctext widget, and make any SHA1 ID
4244 # that we know about be a clickable link.
4245 proc appendwithlinks {text tags} {
4246 global ctext commitrow linknum curview
4248 set start [$ctext index "end - 1c"]
4249 $ctext insert end $text $tags
4250 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4251 foreach l $links {
4252 set s [lindex $l 0]
4253 set e [lindex $l 1]
4254 set linkid [string range $text $s $e]
4255 if {![info exists commitrow($curview,$linkid)]} continue
4256 incr e
4257 $ctext tag add link "$start + $s c" "$start + $e c"
4258 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4259 $ctext tag bind link$linknum <1> \
4260 [list selectline $commitrow($curview,$linkid) 1]
4261 incr linknum
4263 $ctext tag conf link -foreground blue -underline 1
4264 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4265 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4268 proc viewnextline {dir} {
4269 global canv linespc
4271 $canv delete hover
4272 set ymax [lindex [$canv cget -scrollregion] 3]
4273 set wnow [$canv yview]
4274 set wtop [expr {[lindex $wnow 0] * $ymax}]
4275 set newtop [expr {$wtop + $dir * $linespc}]
4276 if {$newtop < 0} {
4277 set newtop 0
4278 } elseif {$newtop > $ymax} {
4279 set newtop $ymax
4281 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4284 # add a list of tag or branch names at position pos
4285 # returns the number of names inserted
4286 proc appendrefs {pos ids var} {
4287 global ctext commitrow linknum curview $var maxrefs
4289 if {[catch {$ctext index $pos}]} {
4290 return 0
4292 $ctext conf -state normal
4293 $ctext delete $pos "$pos lineend"
4294 set tags {}
4295 foreach id $ids {
4296 foreach tag [set $var\($id\)] {
4297 lappend tags [list $tag $id]
4300 if {[llength $tags] > $maxrefs} {
4301 $ctext insert $pos "many ([llength $tags])"
4302 } else {
4303 set tags [lsort -index 0 -decreasing $tags]
4304 set sep {}
4305 foreach ti $tags {
4306 set id [lindex $ti 1]
4307 set lk link$linknum
4308 incr linknum
4309 $ctext tag delete $lk
4310 $ctext insert $pos $sep
4311 $ctext insert $pos [lindex $ti 0] $lk
4312 if {[info exists commitrow($curview,$id)]} {
4313 $ctext tag conf $lk -foreground blue
4314 $ctext tag bind $lk <1> \
4315 [list selectline $commitrow($curview,$id) 1]
4316 $ctext tag conf $lk -underline 1
4317 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4318 $ctext tag bind $lk <Leave> \
4319 { %W configure -cursor $curtextcursor }
4321 set sep ", "
4324 $ctext conf -state disabled
4325 return [llength $tags]
4328 # called when we have finished computing the nearby tags
4329 proc dispneartags {delay} {
4330 global selectedline currentid showneartags tagphase
4332 if {![info exists selectedline] || !$showneartags} return
4333 after cancel dispnexttag
4334 if {$delay} {
4335 after 200 dispnexttag
4336 set tagphase -1
4337 } else {
4338 after idle dispnexttag
4339 set tagphase 0
4343 proc dispnexttag {} {
4344 global selectedline currentid showneartags tagphase ctext
4346 if {![info exists selectedline] || !$showneartags} return
4347 switch -- $tagphase {
4349 set dtags [desctags $currentid]
4350 if {$dtags ne {}} {
4351 appendrefs precedes $dtags idtags
4355 set atags [anctags $currentid]
4356 if {$atags ne {}} {
4357 appendrefs follows $atags idtags
4361 set dheads [descheads $currentid]
4362 if {$dheads ne {}} {
4363 if {[appendrefs branch $dheads idheads] > 1
4364 && [$ctext get "branch -3c"] eq "h"} {
4365 # turn "Branch" into "Branches"
4366 $ctext conf -state normal
4367 $ctext insert "branch -2c" "es"
4368 $ctext conf -state disabled
4373 if {[incr tagphase] <= 2} {
4374 after idle dispnexttag
4378 proc selectline {l isnew} {
4379 global canv canv2 canv3 ctext commitinfo selectedline
4380 global displayorder linehtag linentag linedtag
4381 global canvy0 linespc parentlist children curview
4382 global currentid sha1entry
4383 global commentend idtags linknum
4384 global mergemax numcommits pending_select
4385 global cmitmode showneartags allcommits
4387 catch {unset pending_select}
4388 $canv delete hover
4389 normalline
4390 cancel_next_highlight
4391 if {$l < 0 || $l >= $numcommits} return
4392 set y [expr {$canvy0 + $l * $linespc}]
4393 set ymax [lindex [$canv cget -scrollregion] 3]
4394 set ytop [expr {$y - $linespc - 1}]
4395 set ybot [expr {$y + $linespc + 1}]
4396 set wnow [$canv yview]
4397 set wtop [expr {[lindex $wnow 0] * $ymax}]
4398 set wbot [expr {[lindex $wnow 1] * $ymax}]
4399 set wh [expr {$wbot - $wtop}]
4400 set newtop $wtop
4401 if {$ytop < $wtop} {
4402 if {$ybot < $wtop} {
4403 set newtop [expr {$y - $wh / 2.0}]
4404 } else {
4405 set newtop $ytop
4406 if {$newtop > $wtop - $linespc} {
4407 set newtop [expr {$wtop - $linespc}]
4410 } elseif {$ybot > $wbot} {
4411 if {$ytop > $wbot} {
4412 set newtop [expr {$y - $wh / 2.0}]
4413 } else {
4414 set newtop [expr {$ybot - $wh}]
4415 if {$newtop < $wtop + $linespc} {
4416 set newtop [expr {$wtop + $linespc}]
4420 if {$newtop != $wtop} {
4421 if {$newtop < 0} {
4422 set newtop 0
4424 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4425 drawvisible
4428 if {![info exists linehtag($l)]} return
4429 $canv delete secsel
4430 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4431 -tags secsel -fill [$canv cget -selectbackground]]
4432 $canv lower $t
4433 $canv2 delete secsel
4434 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4435 -tags secsel -fill [$canv2 cget -selectbackground]]
4436 $canv2 lower $t
4437 $canv3 delete secsel
4438 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4439 -tags secsel -fill [$canv3 cget -selectbackground]]
4440 $canv3 lower $t
4442 if {$isnew} {
4443 addtohistory [list selectline $l 0]
4446 set selectedline $l
4448 set id [lindex $displayorder $l]
4449 set currentid $id
4450 $sha1entry delete 0 end
4451 $sha1entry insert 0 $id
4452 $sha1entry selection from 0
4453 $sha1entry selection to end
4454 rhighlight_sel $id
4456 $ctext conf -state normal
4457 clear_ctext
4458 set linknum 0
4459 set info $commitinfo($id)
4460 set date [formatdate [lindex $info 2]]
4461 $ctext insert end "Author: [lindex $info 1] $date\n"
4462 set date [formatdate [lindex $info 4]]
4463 $ctext insert end "Committer: [lindex $info 3] $date\n"
4464 if {[info exists idtags($id)]} {
4465 $ctext insert end "Tags:"
4466 foreach tag $idtags($id) {
4467 $ctext insert end " $tag"
4469 $ctext insert end "\n"
4472 set headers {}
4473 set olds [lindex $parentlist $l]
4474 if {[llength $olds] > 1} {
4475 set np 0
4476 foreach p $olds {
4477 if {$np >= $mergemax} {
4478 set tag mmax
4479 } else {
4480 set tag m$np
4482 $ctext insert end "Parent: " $tag
4483 appendwithlinks [commit_descriptor $p] {}
4484 incr np
4486 } else {
4487 foreach p $olds {
4488 append headers "Parent: [commit_descriptor $p]"
4492 foreach c $children($curview,$id) {
4493 append headers "Child: [commit_descriptor $c]"
4496 # make anything that looks like a SHA1 ID be a clickable link
4497 appendwithlinks $headers {}
4498 if {$showneartags} {
4499 if {![info exists allcommits]} {
4500 getallcommits
4502 $ctext insert end "Branch: "
4503 $ctext mark set branch "end -1c"
4504 $ctext mark gravity branch left
4505 $ctext insert end "\nFollows: "
4506 $ctext mark set follows "end -1c"
4507 $ctext mark gravity follows left
4508 $ctext insert end "\nPrecedes: "
4509 $ctext mark set precedes "end -1c"
4510 $ctext mark gravity precedes left
4511 $ctext insert end "\n"
4512 dispneartags 1
4514 $ctext insert end "\n"
4515 set comment [lindex $info 5]
4516 if {[string first "\r" $comment] >= 0} {
4517 set comment [string map {"\r" "\n "} $comment]
4519 appendwithlinks $comment {comment}
4521 $ctext tag remove found 1.0 end
4522 $ctext conf -state disabled
4523 set commentend [$ctext index "end - 1c"]
4525 init_flist "Comments"
4526 if {$cmitmode eq "tree"} {
4527 gettree $id
4528 } elseif {[llength $olds] <= 1} {
4529 startdiff $id
4530 } else {
4531 mergediff $id $l
4535 proc selfirstline {} {
4536 unmarkmatches
4537 selectline 0 1
4540 proc sellastline {} {
4541 global numcommits
4542 unmarkmatches
4543 set l [expr {$numcommits - 1}]
4544 selectline $l 1
4547 proc selnextline {dir} {
4548 global selectedline
4549 if {![info exists selectedline]} return
4550 set l [expr {$selectedline + $dir}]
4551 unmarkmatches
4552 selectline $l 1
4555 proc selnextpage {dir} {
4556 global canv linespc selectedline numcommits
4558 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4559 if {$lpp < 1} {
4560 set lpp 1
4562 allcanvs yview scroll [expr {$dir * $lpp}] units
4563 drawvisible
4564 if {![info exists selectedline]} return
4565 set l [expr {$selectedline + $dir * $lpp}]
4566 if {$l < 0} {
4567 set l 0
4568 } elseif {$l >= $numcommits} {
4569 set l [expr $numcommits - 1]
4571 unmarkmatches
4572 selectline $l 1
4575 proc unselectline {} {
4576 global selectedline currentid
4578 catch {unset selectedline}
4579 catch {unset currentid}
4580 allcanvs delete secsel
4581 rhighlight_none
4582 cancel_next_highlight
4585 proc reselectline {} {
4586 global selectedline
4588 if {[info exists selectedline]} {
4589 selectline $selectedline 0
4593 proc addtohistory {cmd} {
4594 global history historyindex curview
4596 set elt [list $curview $cmd]
4597 if {$historyindex > 0
4598 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4599 return
4602 if {$historyindex < [llength $history]} {
4603 set history [lreplace $history $historyindex end $elt]
4604 } else {
4605 lappend history $elt
4607 incr historyindex
4608 if {$historyindex > 1} {
4609 .tf.bar.leftbut conf -state normal
4610 } else {
4611 .tf.bar.leftbut conf -state disabled
4613 .tf.bar.rightbut conf -state disabled
4616 proc godo {elt} {
4617 global curview
4619 set view [lindex $elt 0]
4620 set cmd [lindex $elt 1]
4621 if {$curview != $view} {
4622 showview $view
4624 eval $cmd
4627 proc goback {} {
4628 global history historyindex
4630 if {$historyindex > 1} {
4631 incr historyindex -1
4632 godo [lindex $history [expr {$historyindex - 1}]]
4633 .tf.bar.rightbut conf -state normal
4635 if {$historyindex <= 1} {
4636 .tf.bar.leftbut conf -state disabled
4640 proc goforw {} {
4641 global history historyindex
4643 if {$historyindex < [llength $history]} {
4644 set cmd [lindex $history $historyindex]
4645 incr historyindex
4646 godo $cmd
4647 .tf.bar.leftbut conf -state normal
4649 if {$historyindex >= [llength $history]} {
4650 .tf.bar.rightbut conf -state disabled
4654 proc gettree {id} {
4655 global treefilelist treeidlist diffids diffmergeid treepending
4656 global nullid nullid2
4658 set diffids $id
4659 catch {unset diffmergeid}
4660 if {![info exists treefilelist($id)]} {
4661 if {![info exists treepending]} {
4662 if {$id eq $nullid} {
4663 set cmd [list | git ls-files]
4664 } elseif {$id eq $nullid2} {
4665 set cmd [list | git ls-files --stage -t]
4666 } else {
4667 set cmd [list | git ls-tree -r $id]
4669 if {[catch {set gtf [open $cmd r]}]} {
4670 return
4672 set treepending $id
4673 set treefilelist($id) {}
4674 set treeidlist($id) {}
4675 fconfigure $gtf -blocking 0
4676 filerun $gtf [list gettreeline $gtf $id]
4678 } else {
4679 setfilelist $id
4683 proc gettreeline {gtf id} {
4684 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4686 set nl 0
4687 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4688 if {$diffids eq $nullid} {
4689 set fname $line
4690 } else {
4691 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4692 set i [string first "\t" $line]
4693 if {$i < 0} continue
4694 set sha1 [lindex $line 2]
4695 set fname [string range $line [expr {$i+1}] end]
4696 if {[string index $fname 0] eq "\""} {
4697 set fname [lindex $fname 0]
4699 lappend treeidlist($id) $sha1
4701 lappend treefilelist($id) $fname
4703 if {![eof $gtf]} {
4704 return [expr {$nl >= 1000? 2: 1}]
4706 close $gtf
4707 unset treepending
4708 if {$cmitmode ne "tree"} {
4709 if {![info exists diffmergeid]} {
4710 gettreediffs $diffids
4712 } elseif {$id ne $diffids} {
4713 gettree $diffids
4714 } else {
4715 setfilelist $id
4717 return 0
4720 proc showfile {f} {
4721 global treefilelist treeidlist diffids nullid nullid2
4722 global ctext commentend
4724 set i [lsearch -exact $treefilelist($diffids) $f]
4725 if {$i < 0} {
4726 puts "oops, $f not in list for id $diffids"
4727 return
4729 if {$diffids eq $nullid} {
4730 if {[catch {set bf [open $f r]} err]} {
4731 puts "oops, can't read $f: $err"
4732 return
4734 } else {
4735 set blob [lindex $treeidlist($diffids) $i]
4736 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4737 puts "oops, error reading blob $blob: $err"
4738 return
4741 fconfigure $bf -blocking 0
4742 filerun $bf [list getblobline $bf $diffids]
4743 $ctext config -state normal
4744 clear_ctext $commentend
4745 $ctext insert end "\n"
4746 $ctext insert end "$f\n" filesep
4747 $ctext config -state disabled
4748 $ctext yview $commentend
4751 proc getblobline {bf id} {
4752 global diffids cmitmode ctext
4754 if {$id ne $diffids || $cmitmode ne "tree"} {
4755 catch {close $bf}
4756 return 0
4758 $ctext config -state normal
4759 set nl 0
4760 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4761 $ctext insert end "$line\n"
4763 if {[eof $bf]} {
4764 # delete last newline
4765 $ctext delete "end - 2c" "end - 1c"
4766 close $bf
4767 return 0
4769 $ctext config -state disabled
4770 return [expr {$nl >= 1000? 2: 1}]
4773 proc mergediff {id l} {
4774 global diffmergeid diffopts mdifffd
4775 global diffids
4776 global parentlist
4778 set diffmergeid $id
4779 set diffids $id
4780 # this doesn't seem to actually affect anything...
4781 set env(GIT_DIFF_OPTS) $diffopts
4782 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4783 if {[catch {set mdf [open $cmd r]} err]} {
4784 error_popup "Error getting merge diffs: $err"
4785 return
4787 fconfigure $mdf -blocking 0
4788 set mdifffd($id) $mdf
4789 set np [llength [lindex $parentlist $l]]
4790 filerun $mdf [list getmergediffline $mdf $id $np]
4793 proc getmergediffline {mdf id np} {
4794 global diffmergeid ctext cflist mergemax
4795 global difffilestart mdifffd
4797 $ctext conf -state normal
4798 set nr 0
4799 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4800 if {![info exists diffmergeid] || $id != $diffmergeid
4801 || $mdf != $mdifffd($id)} {
4802 close $mdf
4803 return 0
4805 if {[regexp {^diff --cc (.*)} $line match fname]} {
4806 # start of a new file
4807 $ctext insert end "\n"
4808 set here [$ctext index "end - 1c"]
4809 lappend difffilestart $here
4810 add_flist [list $fname]
4811 set l [expr {(78 - [string length $fname]) / 2}]
4812 set pad [string range "----------------------------------------" 1 $l]
4813 $ctext insert end "$pad $fname $pad\n" filesep
4814 } elseif {[regexp {^@@} $line]} {
4815 $ctext insert end "$line\n" hunksep
4816 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4817 # do nothing
4818 } else {
4819 # parse the prefix - one ' ', '-' or '+' for each parent
4820 set spaces {}
4821 set minuses {}
4822 set pluses {}
4823 set isbad 0
4824 for {set j 0} {$j < $np} {incr j} {
4825 set c [string range $line $j $j]
4826 if {$c == " "} {
4827 lappend spaces $j
4828 } elseif {$c == "-"} {
4829 lappend minuses $j
4830 } elseif {$c == "+"} {
4831 lappend pluses $j
4832 } else {
4833 set isbad 1
4834 break
4837 set tags {}
4838 set num {}
4839 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4840 # line doesn't appear in result, parents in $minuses have the line
4841 set num [lindex $minuses 0]
4842 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4843 # line appears in result, parents in $pluses don't have the line
4844 lappend tags mresult
4845 set num [lindex $spaces 0]
4847 if {$num ne {}} {
4848 if {$num >= $mergemax} {
4849 set num "max"
4851 lappend tags m$num
4853 $ctext insert end "$line\n" $tags
4856 $ctext conf -state disabled
4857 if {[eof $mdf]} {
4858 close $mdf
4859 return 0
4861 return [expr {$nr >= 1000? 2: 1}]
4864 proc startdiff {ids} {
4865 global treediffs diffids treepending diffmergeid nullid nullid2
4867 set diffids $ids
4868 catch {unset diffmergeid}
4869 if {![info exists treediffs($ids)] ||
4870 [lsearch -exact $ids $nullid] >= 0 ||
4871 [lsearch -exact $ids $nullid2] >= 0} {
4872 if {![info exists treepending]} {
4873 gettreediffs $ids
4875 } else {
4876 addtocflist $ids
4880 proc addtocflist {ids} {
4881 global treediffs cflist
4882 add_flist $treediffs($ids)
4883 getblobdiffs $ids
4886 proc diffcmd {ids flags} {
4887 global nullid nullid2
4889 set i [lsearch -exact $ids $nullid]
4890 set j [lsearch -exact $ids $nullid2]
4891 if {$i >= 0} {
4892 if {[llength $ids] > 1 && $j < 0} {
4893 # comparing working directory with some specific revision
4894 set cmd [concat | git diff-index $flags]
4895 if {$i == 0} {
4896 lappend cmd -R [lindex $ids 1]
4897 } else {
4898 lappend cmd [lindex $ids 0]
4900 } else {
4901 # comparing working directory with index
4902 set cmd [concat | git diff-files $flags]
4903 if {$j == 1} {
4904 lappend cmd -R
4907 } elseif {$j >= 0} {
4908 set cmd [concat | git diff-index --cached $flags]
4909 if {[llength $ids] > 1} {
4910 # comparing index with specific revision
4911 if {$i == 0} {
4912 lappend cmd -R [lindex $ids 1]
4913 } else {
4914 lappend cmd [lindex $ids 0]
4916 } else {
4917 # comparing index with HEAD
4918 lappend cmd HEAD
4920 } else {
4921 set cmd [concat | git diff-tree -r $flags $ids]
4923 return $cmd
4926 proc gettreediffs {ids} {
4927 global treediff treepending
4929 set treepending $ids
4930 set treediff {}
4931 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4932 fconfigure $gdtf -blocking 0
4933 filerun $gdtf [list gettreediffline $gdtf $ids]
4936 proc gettreediffline {gdtf ids} {
4937 global treediff treediffs treepending diffids diffmergeid
4938 global cmitmode
4940 set nr 0
4941 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4942 set i [string first "\t" $line]
4943 if {$i >= 0} {
4944 set file [string range $line [expr {$i+1}] end]
4945 if {[string index $file 0] eq "\""} {
4946 set file [lindex $file 0]
4948 lappend treediff $file
4951 if {![eof $gdtf]} {
4952 return [expr {$nr >= 1000? 2: 1}]
4954 close $gdtf
4955 set treediffs($ids) $treediff
4956 unset treepending
4957 if {$cmitmode eq "tree"} {
4958 gettree $diffids
4959 } elseif {$ids != $diffids} {
4960 if {![info exists diffmergeid]} {
4961 gettreediffs $diffids
4963 } else {
4964 addtocflist $ids
4966 return 0
4969 proc getblobdiffs {ids} {
4970 global diffopts blobdifffd diffids env
4971 global diffinhdr treediffs
4973 set env(GIT_DIFF_OPTS) $diffopts
4974 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4975 puts "error getting diffs: $err"
4976 return
4978 set diffinhdr 0
4979 fconfigure $bdf -blocking 0
4980 set blobdifffd($ids) $bdf
4981 filerun $bdf [list getblobdiffline $bdf $diffids]
4984 proc setinlist {var i val} {
4985 global $var
4987 while {[llength [set $var]] < $i} {
4988 lappend $var {}
4990 if {[llength [set $var]] == $i} {
4991 lappend $var $val
4992 } else {
4993 lset $var $i $val
4997 proc makediffhdr {fname ids} {
4998 global ctext curdiffstart treediffs
5000 set i [lsearch -exact $treediffs($ids) $fname]
5001 if {$i >= 0} {
5002 setinlist difffilestart $i $curdiffstart
5004 set l [expr {(78 - [string length $fname]) / 2}]
5005 set pad [string range "----------------------------------------" 1 $l]
5006 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5009 proc getblobdiffline {bdf ids} {
5010 global diffids blobdifffd ctext curdiffstart
5011 global diffnexthead diffnextnote difffilestart
5012 global diffinhdr treediffs
5014 set nr 0
5015 $ctext conf -state normal
5016 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5017 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5018 close $bdf
5019 return 0
5021 if {![string compare -length 11 "diff --git " $line]} {
5022 # trim off "diff --git "
5023 set line [string range $line 11 end]
5024 set diffinhdr 1
5025 # start of a new file
5026 $ctext insert end "\n"
5027 set curdiffstart [$ctext index "end - 1c"]
5028 $ctext insert end "\n" filesep
5029 # If the name hasn't changed the length will be odd,
5030 # the middle char will be a space, and the two bits either
5031 # side will be a/name and b/name, or "a/name" and "b/name".
5032 # If the name has changed we'll get "rename from" and
5033 # "rename to" lines following this, and we'll use them
5034 # to get the filenames.
5035 # This complexity is necessary because spaces in the filename(s)
5036 # don't get escaped.
5037 set l [string length $line]
5038 set i [expr {$l / 2}]
5039 if {!(($l & 1) && [string index $line $i] eq " " &&
5040 [string range $line 2 [expr {$i - 1}]] eq \
5041 [string range $line [expr {$i + 3}] end])} {
5042 continue
5044 # unescape if quoted and chop off the a/ from the front
5045 if {[string index $line 0] eq "\""} {
5046 set fname [string range [lindex $line 0] 2 end]
5047 } else {
5048 set fname [string range $line 2 [expr {$i - 1}]]
5050 makediffhdr $fname $ids
5052 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5053 $line match f1l f1c f2l f2c rest]} {
5054 $ctext insert end "$line\n" hunksep
5055 set diffinhdr 0
5057 } elseif {$diffinhdr} {
5058 if {![string compare -length 12 "rename from " $line]} {
5059 set fname [string range $line 12 end]
5060 if {[string index $fname 0] eq "\""} {
5061 set fname [lindex $fname 0]
5063 set i [lsearch -exact $treediffs($ids) $fname]
5064 if {$i >= 0} {
5065 setinlist difffilestart $i $curdiffstart
5067 } elseif {![string compare -length 10 $line "rename to "]} {
5068 set fname [string range $line 10 end]
5069 if {[string index $fname 0] eq "\""} {
5070 set fname [lindex $fname 0]
5072 makediffhdr $fname $ids
5073 } elseif {[string compare -length 3 $line "---"] == 0} {
5074 # do nothing
5075 continue
5076 } elseif {[string compare -length 3 $line "+++"] == 0} {
5077 set diffinhdr 0
5078 continue
5080 $ctext insert end "$line\n" filesep
5082 } else {
5083 set x [string range $line 0 0]
5084 if {$x == "-" || $x == "+"} {
5085 set tag [expr {$x == "+"}]
5086 $ctext insert end "$line\n" d$tag
5087 } elseif {$x == " "} {
5088 $ctext insert end "$line\n"
5089 } else {
5090 # "\ No newline at end of file",
5091 # or something else we don't recognize
5092 $ctext insert end "$line\n" hunksep
5096 $ctext conf -state disabled
5097 if {[eof $bdf]} {
5098 close $bdf
5099 return 0
5101 return [expr {$nr >= 1000? 2: 1}]
5104 proc changediffdisp {} {
5105 global ctext diffelide
5107 $ctext tag conf d0 -elide [lindex $diffelide 0]
5108 $ctext tag conf d1 -elide [lindex $diffelide 1]
5111 proc prevfile {} {
5112 global difffilestart ctext
5113 set prev [lindex $difffilestart 0]
5114 set here [$ctext index @0,0]
5115 foreach loc $difffilestart {
5116 if {[$ctext compare $loc >= $here]} {
5117 $ctext yview $prev
5118 return
5120 set prev $loc
5122 $ctext yview $prev
5125 proc nextfile {} {
5126 global difffilestart ctext
5127 set here [$ctext index @0,0]
5128 foreach loc $difffilestart {
5129 if {[$ctext compare $loc > $here]} {
5130 $ctext yview $loc
5131 return
5136 proc clear_ctext {{first 1.0}} {
5137 global ctext smarktop smarkbot
5139 set l [lindex [split $first .] 0]
5140 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5141 set smarktop $l
5143 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5144 set smarkbot $l
5146 $ctext delete $first end
5149 proc incrsearch {name ix op} {
5150 global ctext searchstring searchdirn
5152 $ctext tag remove found 1.0 end
5153 if {[catch {$ctext index anchor}]} {
5154 # no anchor set, use start of selection, or of visible area
5155 set sel [$ctext tag ranges sel]
5156 if {$sel ne {}} {
5157 $ctext mark set anchor [lindex $sel 0]
5158 } elseif {$searchdirn eq "-forwards"} {
5159 $ctext mark set anchor @0,0
5160 } else {
5161 $ctext mark set anchor @0,[winfo height $ctext]
5164 if {$searchstring ne {}} {
5165 set here [$ctext search $searchdirn -- $searchstring anchor]
5166 if {$here ne {}} {
5167 $ctext see $here
5169 searchmarkvisible 1
5173 proc dosearch {} {
5174 global sstring ctext searchstring searchdirn
5176 focus $sstring
5177 $sstring icursor end
5178 set searchdirn -forwards
5179 if {$searchstring ne {}} {
5180 set sel [$ctext tag ranges sel]
5181 if {$sel ne {}} {
5182 set start "[lindex $sel 0] + 1c"
5183 } elseif {[catch {set start [$ctext index anchor]}]} {
5184 set start "@0,0"
5186 set match [$ctext search -count mlen -- $searchstring $start]
5187 $ctext tag remove sel 1.0 end
5188 if {$match eq {}} {
5189 bell
5190 return
5192 $ctext see $match
5193 set mend "$match + $mlen c"
5194 $ctext tag add sel $match $mend
5195 $ctext mark unset anchor
5199 proc dosearchback {} {
5200 global sstring ctext searchstring searchdirn
5202 focus $sstring
5203 $sstring icursor end
5204 set searchdirn -backwards
5205 if {$searchstring ne {}} {
5206 set sel [$ctext tag ranges sel]
5207 if {$sel ne {}} {
5208 set start [lindex $sel 0]
5209 } elseif {[catch {set start [$ctext index anchor]}]} {
5210 set start @0,[winfo height $ctext]
5212 set match [$ctext search -backwards -count ml -- $searchstring $start]
5213 $ctext tag remove sel 1.0 end
5214 if {$match eq {}} {
5215 bell
5216 return
5218 $ctext see $match
5219 set mend "$match + $ml c"
5220 $ctext tag add sel $match $mend
5221 $ctext mark unset anchor
5225 proc searchmark {first last} {
5226 global ctext searchstring
5228 set mend $first.0
5229 while {1} {
5230 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5231 if {$match eq {}} break
5232 set mend "$match + $mlen c"
5233 $ctext tag add found $match $mend
5237 proc searchmarkvisible {doall} {
5238 global ctext smarktop smarkbot
5240 set topline [lindex [split [$ctext index @0,0] .] 0]
5241 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5242 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5243 # no overlap with previous
5244 searchmark $topline $botline
5245 set smarktop $topline
5246 set smarkbot $botline
5247 } else {
5248 if {$topline < $smarktop} {
5249 searchmark $topline [expr {$smarktop-1}]
5250 set smarktop $topline
5252 if {$botline > $smarkbot} {
5253 searchmark [expr {$smarkbot+1}] $botline
5254 set smarkbot $botline
5259 proc scrolltext {f0 f1} {
5260 global searchstring
5262 .bleft.sb set $f0 $f1
5263 if {$searchstring ne {}} {
5264 searchmarkvisible 0
5268 proc setcoords {} {
5269 global linespc charspc canvx0 canvy0 mainfont
5270 global xspc1 xspc2 lthickness
5272 set linespc [font metrics $mainfont -linespace]
5273 set charspc [font measure $mainfont "m"]
5274 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5275 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5276 set lthickness [expr {int($linespc / 9) + 1}]
5277 set xspc1(0) $linespc
5278 set xspc2 $linespc
5281 proc redisplay {} {
5282 global canv
5283 global selectedline
5285 set ymax [lindex [$canv cget -scrollregion] 3]
5286 if {$ymax eq {} || $ymax == 0} return
5287 set span [$canv yview]
5288 clear_display
5289 setcanvscroll
5290 allcanvs yview moveto [lindex $span 0]
5291 drawvisible
5292 if {[info exists selectedline]} {
5293 selectline $selectedline 0
5294 allcanvs yview moveto [lindex $span 0]
5298 proc incrfont {inc} {
5299 global mainfont textfont ctext canv phase cflist
5300 global charspc tabstop
5301 global stopped entries
5302 unmarkmatches
5303 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5304 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5305 setcoords
5306 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5307 $cflist conf -font $textfont
5308 $ctext tag conf filesep -font [concat $textfont bold]
5309 foreach e $entries {
5310 $e conf -font $mainfont
5312 if {$phase eq "getcommits"} {
5313 $canv itemconf textitems -font $mainfont
5315 redisplay
5318 proc clearsha1 {} {
5319 global sha1entry sha1string
5320 if {[string length $sha1string] == 40} {
5321 $sha1entry delete 0 end
5325 proc sha1change {n1 n2 op} {
5326 global sha1string currentid sha1but
5327 if {$sha1string == {}
5328 || ([info exists currentid] && $sha1string == $currentid)} {
5329 set state disabled
5330 } else {
5331 set state normal
5333 if {[$sha1but cget -state] == $state} return
5334 if {$state == "normal"} {
5335 $sha1but conf -state normal -relief raised -text "Goto: "
5336 } else {
5337 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5341 proc gotocommit {} {
5342 global sha1string currentid commitrow tagids headids
5343 global displayorder numcommits curview
5345 if {$sha1string == {}
5346 || ([info exists currentid] && $sha1string == $currentid)} return
5347 if {[info exists tagids($sha1string)]} {
5348 set id $tagids($sha1string)
5349 } elseif {[info exists headids($sha1string)]} {
5350 set id $headids($sha1string)
5351 } else {
5352 set id [string tolower $sha1string]
5353 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5354 set matches {}
5355 foreach i $displayorder {
5356 if {[string match $id* $i]} {
5357 lappend matches $i
5360 if {$matches ne {}} {
5361 if {[llength $matches] > 1} {
5362 error_popup "Short SHA1 id $id is ambiguous"
5363 return
5365 set id [lindex $matches 0]
5369 if {[info exists commitrow($curview,$id)]} {
5370 selectline $commitrow($curview,$id) 1
5371 return
5373 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5374 set type "SHA1 id"
5375 } else {
5376 set type "Tag/Head"
5378 error_popup "$type $sha1string is not known"
5381 proc lineenter {x y id} {
5382 global hoverx hovery hoverid hovertimer
5383 global commitinfo canv
5385 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5386 set hoverx $x
5387 set hovery $y
5388 set hoverid $id
5389 if {[info exists hovertimer]} {
5390 after cancel $hovertimer
5392 set hovertimer [after 500 linehover]
5393 $canv delete hover
5396 proc linemotion {x y id} {
5397 global hoverx hovery hoverid hovertimer
5399 if {[info exists hoverid] && $id == $hoverid} {
5400 set hoverx $x
5401 set hovery $y
5402 if {[info exists hovertimer]} {
5403 after cancel $hovertimer
5405 set hovertimer [after 500 linehover]
5409 proc lineleave {id} {
5410 global hoverid hovertimer canv
5412 if {[info exists hoverid] && $id == $hoverid} {
5413 $canv delete hover
5414 if {[info exists hovertimer]} {
5415 after cancel $hovertimer
5416 unset hovertimer
5418 unset hoverid
5422 proc linehover {} {
5423 global hoverx hovery hoverid hovertimer
5424 global canv linespc lthickness
5425 global commitinfo mainfont
5427 set text [lindex $commitinfo($hoverid) 0]
5428 set ymax [lindex [$canv cget -scrollregion] 3]
5429 if {$ymax == {}} return
5430 set yfrac [lindex [$canv yview] 0]
5431 set x [expr {$hoverx + 2 * $linespc}]
5432 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5433 set x0 [expr {$x - 2 * $lthickness}]
5434 set y0 [expr {$y - 2 * $lthickness}]
5435 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5436 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5437 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5438 -fill \#ffff80 -outline black -width 1 -tags hover]
5439 $canv raise $t
5440 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5441 -font $mainfont]
5442 $canv raise $t
5445 proc clickisonarrow {id y} {
5446 global lthickness
5448 set ranges [rowranges $id]
5449 set thresh [expr {2 * $lthickness + 6}]
5450 set n [expr {[llength $ranges] - 1}]
5451 for {set i 1} {$i < $n} {incr i} {
5452 set row [lindex $ranges $i]
5453 if {abs([yc $row] - $y) < $thresh} {
5454 return $i
5457 return {}
5460 proc arrowjump {id n y} {
5461 global canv
5463 # 1 <-> 2, 3 <-> 4, etc...
5464 set n [expr {(($n - 1) ^ 1) + 1}]
5465 set row [lindex [rowranges $id] $n]
5466 set yt [yc $row]
5467 set ymax [lindex [$canv cget -scrollregion] 3]
5468 if {$ymax eq {} || $ymax <= 0} return
5469 set view [$canv yview]
5470 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5471 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5472 if {$yfrac < 0} {
5473 set yfrac 0
5475 allcanvs yview moveto $yfrac
5478 proc lineclick {x y id isnew} {
5479 global ctext commitinfo children canv thickerline curview
5481 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5482 unmarkmatches
5483 unselectline
5484 normalline
5485 $canv delete hover
5486 # draw this line thicker than normal
5487 set thickerline $id
5488 drawlines $id
5489 if {$isnew} {
5490 set ymax [lindex [$canv cget -scrollregion] 3]
5491 if {$ymax eq {}} return
5492 set yfrac [lindex [$canv yview] 0]
5493 set y [expr {$y + $yfrac * $ymax}]
5495 set dirn [clickisonarrow $id $y]
5496 if {$dirn ne {}} {
5497 arrowjump $id $dirn $y
5498 return
5501 if {$isnew} {
5502 addtohistory [list lineclick $x $y $id 0]
5504 # fill the details pane with info about this line
5505 $ctext conf -state normal
5506 clear_ctext
5507 $ctext tag conf link -foreground blue -underline 1
5508 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5509 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5510 $ctext insert end "Parent:\t"
5511 $ctext insert end $id [list link link0]
5512 $ctext tag bind link0 <1> [list selbyid $id]
5513 set info $commitinfo($id)
5514 $ctext insert end "\n\t[lindex $info 0]\n"
5515 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5516 set date [formatdate [lindex $info 2]]
5517 $ctext insert end "\tDate:\t$date\n"
5518 set kids $children($curview,$id)
5519 if {$kids ne {}} {
5520 $ctext insert end "\nChildren:"
5521 set i 0
5522 foreach child $kids {
5523 incr i
5524 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5525 set info $commitinfo($child)
5526 $ctext insert end "\n\t"
5527 $ctext insert end $child [list link link$i]
5528 $ctext tag bind link$i <1> [list selbyid $child]
5529 $ctext insert end "\n\t[lindex $info 0]"
5530 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5531 set date [formatdate [lindex $info 2]]
5532 $ctext insert end "\n\tDate:\t$date\n"
5535 $ctext conf -state disabled
5536 init_flist {}
5539 proc normalline {} {
5540 global thickerline
5541 if {[info exists thickerline]} {
5542 set id $thickerline
5543 unset thickerline
5544 drawlines $id
5548 proc selbyid {id} {
5549 global commitrow curview
5550 if {[info exists commitrow($curview,$id)]} {
5551 selectline $commitrow($curview,$id) 1
5555 proc mstime {} {
5556 global startmstime
5557 if {![info exists startmstime]} {
5558 set startmstime [clock clicks -milliseconds]
5560 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5563 proc rowmenu {x y id} {
5564 global rowctxmenu commitrow selectedline rowmenuid curview
5565 global nullid nullid2 fakerowmenu mainhead
5567 set rowmenuid $id
5568 if {![info exists selectedline]
5569 || $commitrow($curview,$id) eq $selectedline} {
5570 set state disabled
5571 } else {
5572 set state normal
5574 if {$id ne $nullid && $id ne $nullid2} {
5575 set menu $rowctxmenu
5576 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5577 } else {
5578 set menu $fakerowmenu
5580 $menu entryconfigure "Diff this*" -state $state
5581 $menu entryconfigure "Diff selected*" -state $state
5582 $menu entryconfigure "Make patch" -state $state
5583 tk_popup $menu $x $y
5586 proc diffvssel {dirn} {
5587 global rowmenuid selectedline displayorder
5589 if {![info exists selectedline]} return
5590 if {$dirn} {
5591 set oldid [lindex $displayorder $selectedline]
5592 set newid $rowmenuid
5593 } else {
5594 set oldid $rowmenuid
5595 set newid [lindex $displayorder $selectedline]
5597 addtohistory [list doseldiff $oldid $newid]
5598 doseldiff $oldid $newid
5601 proc doseldiff {oldid newid} {
5602 global ctext
5603 global commitinfo
5605 $ctext conf -state normal
5606 clear_ctext
5607 init_flist "Top"
5608 $ctext insert end "From "
5609 $ctext tag conf link -foreground blue -underline 1
5610 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5611 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5612 $ctext tag bind link0 <1> [list selbyid $oldid]
5613 $ctext insert end $oldid [list link link0]
5614 $ctext insert end "\n "
5615 $ctext insert end [lindex $commitinfo($oldid) 0]
5616 $ctext insert end "\n\nTo "
5617 $ctext tag bind link1 <1> [list selbyid $newid]
5618 $ctext insert end $newid [list link link1]
5619 $ctext insert end "\n "
5620 $ctext insert end [lindex $commitinfo($newid) 0]
5621 $ctext insert end "\n"
5622 $ctext conf -state disabled
5623 $ctext tag remove found 1.0 end
5624 startdiff [list $oldid $newid]
5627 proc mkpatch {} {
5628 global rowmenuid currentid commitinfo patchtop patchnum
5630 if {![info exists currentid]} return
5631 set oldid $currentid
5632 set oldhead [lindex $commitinfo($oldid) 0]
5633 set newid $rowmenuid
5634 set newhead [lindex $commitinfo($newid) 0]
5635 set top .patch
5636 set patchtop $top
5637 catch {destroy $top}
5638 toplevel $top
5639 label $top.title -text "Generate patch"
5640 grid $top.title - -pady 10
5641 label $top.from -text "From:"
5642 entry $top.fromsha1 -width 40 -relief flat
5643 $top.fromsha1 insert 0 $oldid
5644 $top.fromsha1 conf -state readonly
5645 grid $top.from $top.fromsha1 -sticky w
5646 entry $top.fromhead -width 60 -relief flat
5647 $top.fromhead insert 0 $oldhead
5648 $top.fromhead conf -state readonly
5649 grid x $top.fromhead -sticky w
5650 label $top.to -text "To:"
5651 entry $top.tosha1 -width 40 -relief flat
5652 $top.tosha1 insert 0 $newid
5653 $top.tosha1 conf -state readonly
5654 grid $top.to $top.tosha1 -sticky w
5655 entry $top.tohead -width 60 -relief flat
5656 $top.tohead insert 0 $newhead
5657 $top.tohead conf -state readonly
5658 grid x $top.tohead -sticky w
5659 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5660 grid $top.rev x -pady 10
5661 label $top.flab -text "Output file:"
5662 entry $top.fname -width 60
5663 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5664 incr patchnum
5665 grid $top.flab $top.fname -sticky w
5666 frame $top.buts
5667 button $top.buts.gen -text "Generate" -command mkpatchgo
5668 button $top.buts.can -text "Cancel" -command mkpatchcan
5669 grid $top.buts.gen $top.buts.can
5670 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5671 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5672 grid $top.buts - -pady 10 -sticky ew
5673 focus $top.fname
5676 proc mkpatchrev {} {
5677 global patchtop
5679 set oldid [$patchtop.fromsha1 get]
5680 set oldhead [$patchtop.fromhead get]
5681 set newid [$patchtop.tosha1 get]
5682 set newhead [$patchtop.tohead get]
5683 foreach e [list fromsha1 fromhead tosha1 tohead] \
5684 v [list $newid $newhead $oldid $oldhead] {
5685 $patchtop.$e conf -state normal
5686 $patchtop.$e delete 0 end
5687 $patchtop.$e insert 0 $v
5688 $patchtop.$e conf -state readonly
5692 proc mkpatchgo {} {
5693 global patchtop nullid nullid2
5695 set oldid [$patchtop.fromsha1 get]
5696 set newid [$patchtop.tosha1 get]
5697 set fname [$patchtop.fname get]
5698 set cmd [diffcmd [list $oldid $newid] -p]
5699 lappend cmd >$fname &
5700 if {[catch {eval exec $cmd} err]} {
5701 error_popup "Error creating patch: $err"
5703 catch {destroy $patchtop}
5704 unset patchtop
5707 proc mkpatchcan {} {
5708 global patchtop
5710 catch {destroy $patchtop}
5711 unset patchtop
5714 proc mktag {} {
5715 global rowmenuid mktagtop commitinfo
5717 set top .maketag
5718 set mktagtop $top
5719 catch {destroy $top}
5720 toplevel $top
5721 label $top.title -text "Create tag"
5722 grid $top.title - -pady 10
5723 label $top.id -text "ID:"
5724 entry $top.sha1 -width 40 -relief flat
5725 $top.sha1 insert 0 $rowmenuid
5726 $top.sha1 conf -state readonly
5727 grid $top.id $top.sha1 -sticky w
5728 entry $top.head -width 60 -relief flat
5729 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5730 $top.head conf -state readonly
5731 grid x $top.head -sticky w
5732 label $top.tlab -text "Tag name:"
5733 entry $top.tag -width 60
5734 grid $top.tlab $top.tag -sticky w
5735 frame $top.buts
5736 button $top.buts.gen -text "Create" -command mktaggo
5737 button $top.buts.can -text "Cancel" -command mktagcan
5738 grid $top.buts.gen $top.buts.can
5739 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5740 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5741 grid $top.buts - -pady 10 -sticky ew
5742 focus $top.tag
5745 proc domktag {} {
5746 global mktagtop env tagids idtags
5748 set id [$mktagtop.sha1 get]
5749 set tag [$mktagtop.tag get]
5750 if {$tag == {}} {
5751 error_popup "No tag name specified"
5752 return
5754 if {[info exists tagids($tag)]} {
5755 error_popup "Tag \"$tag\" already exists"
5756 return
5758 if {[catch {
5759 set dir [gitdir]
5760 set fname [file join $dir "refs/tags" $tag]
5761 set f [open $fname w]
5762 puts $f $id
5763 close $f
5764 } err]} {
5765 error_popup "Error creating tag: $err"
5766 return
5769 set tagids($tag) $id
5770 lappend idtags($id) $tag
5771 redrawtags $id
5772 addedtag $id
5775 proc redrawtags {id} {
5776 global canv linehtag commitrow idpos selectedline curview
5777 global mainfont canvxmax iddrawn
5779 if {![info exists commitrow($curview,$id)]} return
5780 if {![info exists iddrawn($id)]} return
5781 drawcommits $commitrow($curview,$id)
5782 $canv delete tag.$id
5783 set xt [eval drawtags $id $idpos($id)]
5784 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5785 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5786 set xr [expr {$xt + [font measure $mainfont $text]}]
5787 if {$xr > $canvxmax} {
5788 set canvxmax $xr
5789 setcanvscroll
5791 if {[info exists selectedline]
5792 && $selectedline == $commitrow($curview,$id)} {
5793 selectline $selectedline 0
5797 proc mktagcan {} {
5798 global mktagtop
5800 catch {destroy $mktagtop}
5801 unset mktagtop
5804 proc mktaggo {} {
5805 domktag
5806 mktagcan
5809 proc writecommit {} {
5810 global rowmenuid wrcomtop commitinfo wrcomcmd
5812 set top .writecommit
5813 set wrcomtop $top
5814 catch {destroy $top}
5815 toplevel $top
5816 label $top.title -text "Write commit to file"
5817 grid $top.title - -pady 10
5818 label $top.id -text "ID:"
5819 entry $top.sha1 -width 40 -relief flat
5820 $top.sha1 insert 0 $rowmenuid
5821 $top.sha1 conf -state readonly
5822 grid $top.id $top.sha1 -sticky w
5823 entry $top.head -width 60 -relief flat
5824 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5825 $top.head conf -state readonly
5826 grid x $top.head -sticky w
5827 label $top.clab -text "Command:"
5828 entry $top.cmd -width 60 -textvariable wrcomcmd
5829 grid $top.clab $top.cmd -sticky w -pady 10
5830 label $top.flab -text "Output file:"
5831 entry $top.fname -width 60
5832 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5833 grid $top.flab $top.fname -sticky w
5834 frame $top.buts
5835 button $top.buts.gen -text "Write" -command wrcomgo
5836 button $top.buts.can -text "Cancel" -command wrcomcan
5837 grid $top.buts.gen $top.buts.can
5838 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5839 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5840 grid $top.buts - -pady 10 -sticky ew
5841 focus $top.fname
5844 proc wrcomgo {} {
5845 global wrcomtop
5847 set id [$wrcomtop.sha1 get]
5848 set cmd "echo $id | [$wrcomtop.cmd get]"
5849 set fname [$wrcomtop.fname get]
5850 if {[catch {exec sh -c $cmd >$fname &} err]} {
5851 error_popup "Error writing commit: $err"
5853 catch {destroy $wrcomtop}
5854 unset wrcomtop
5857 proc wrcomcan {} {
5858 global wrcomtop
5860 catch {destroy $wrcomtop}
5861 unset wrcomtop
5864 proc mkbranch {} {
5865 global rowmenuid mkbrtop
5867 set top .makebranch
5868 catch {destroy $top}
5869 toplevel $top
5870 label $top.title -text "Create new branch"
5871 grid $top.title - -pady 10
5872 label $top.id -text "ID:"
5873 entry $top.sha1 -width 40 -relief flat
5874 $top.sha1 insert 0 $rowmenuid
5875 $top.sha1 conf -state readonly
5876 grid $top.id $top.sha1 -sticky w
5877 label $top.nlab -text "Name:"
5878 entry $top.name -width 40
5879 grid $top.nlab $top.name -sticky w
5880 frame $top.buts
5881 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5882 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5883 grid $top.buts.go $top.buts.can
5884 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5885 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5886 grid $top.buts - -pady 10 -sticky ew
5887 focus $top.name
5890 proc mkbrgo {top} {
5891 global headids idheads
5893 set name [$top.name get]
5894 set id [$top.sha1 get]
5895 if {$name eq {}} {
5896 error_popup "Please specify a name for the new branch"
5897 return
5899 catch {destroy $top}
5900 nowbusy newbranch
5901 update
5902 if {[catch {
5903 exec git branch $name $id
5904 } err]} {
5905 notbusy newbranch
5906 error_popup $err
5907 } else {
5908 set headids($name) $id
5909 lappend idheads($id) $name
5910 addedhead $id $name
5911 notbusy newbranch
5912 redrawtags $id
5913 dispneartags 0
5917 proc cherrypick {} {
5918 global rowmenuid curview commitrow
5919 global mainhead
5921 set oldhead [exec git rev-parse HEAD]
5922 set dheads [descheads $rowmenuid]
5923 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5924 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5925 included in branch $mainhead -- really re-apply it?"]
5926 if {!$ok} return
5928 nowbusy cherrypick
5929 update
5930 # Unfortunately git-cherry-pick writes stuff to stderr even when
5931 # no error occurs, and exec takes that as an indication of error...
5932 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5933 notbusy cherrypick
5934 error_popup $err
5935 return
5937 set newhead [exec git rev-parse HEAD]
5938 if {$newhead eq $oldhead} {
5939 notbusy cherrypick
5940 error_popup "No changes committed"
5941 return
5943 addnewchild $newhead $oldhead
5944 if {[info exists commitrow($curview,$oldhead)]} {
5945 insertrow $commitrow($curview,$oldhead) $newhead
5946 if {$mainhead ne {}} {
5947 movehead $newhead $mainhead
5948 movedhead $newhead $mainhead
5950 redrawtags $oldhead
5951 redrawtags $newhead
5953 notbusy cherrypick
5956 proc resethead {} {
5957 global mainheadid mainhead rowmenuid confirm_ok resettype
5958 global showlocalchanges
5960 set confirm_ok 0
5961 set w ".confirmreset"
5962 toplevel $w
5963 wm transient $w .
5964 wm title $w "Confirm reset"
5965 message $w.m -text \
5966 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5967 -justify center -aspect 1000
5968 pack $w.m -side top -fill x -padx 20 -pady 20
5969 frame $w.f -relief sunken -border 2
5970 message $w.f.rt -text "Reset type:" -aspect 1000
5971 grid $w.f.rt -sticky w
5972 set resettype mixed
5973 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5974 -text "Soft: Leave working tree and index untouched"
5975 grid $w.f.soft -sticky w
5976 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5977 -text "Mixed: Leave working tree untouched, reset index"
5978 grid $w.f.mixed -sticky w
5979 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5980 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5981 grid $w.f.hard -sticky w
5982 pack $w.f -side top -fill x
5983 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5984 pack $w.ok -side left -fill x -padx 20 -pady 20
5985 button $w.cancel -text Cancel -command "destroy $w"
5986 pack $w.cancel -side right -fill x -padx 20 -pady 20
5987 bind $w <Visibility> "grab $w; focus $w"
5988 tkwait window $w
5989 if {!$confirm_ok} return
5990 if {[catch {set fd [open \
5991 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5992 error_popup $err
5993 } else {
5994 dohidelocalchanges
5995 set w ".resetprogress"
5996 filerun $fd [list readresetstat $fd $w]
5997 toplevel $w
5998 wm transient $w
5999 wm title $w "Reset progress"
6000 message $w.m -text "Reset in progress, please wait..." \
6001 -justify center -aspect 1000
6002 pack $w.m -side top -fill x -padx 20 -pady 5
6003 canvas $w.c -width 150 -height 20 -bg white
6004 $w.c create rect 0 0 0 20 -fill green -tags rect
6005 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6006 nowbusy reset
6010 proc readresetstat {fd w} {
6011 global mainhead mainheadid showlocalchanges
6013 if {[gets $fd line] >= 0} {
6014 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6015 set x [expr {($m * 150) / $n}]
6016 $w.c coords rect 0 0 $x 20
6018 return 1
6020 destroy $w
6021 notbusy reset
6022 if {[catch {close $fd} err]} {
6023 error_popup $err
6025 set oldhead $mainheadid
6026 set newhead [exec git rev-parse HEAD]
6027 if {$newhead ne $oldhead} {
6028 movehead $newhead $mainhead
6029 movedhead $newhead $mainhead
6030 set mainheadid $newhead
6031 redrawtags $oldhead
6032 redrawtags $newhead
6034 if {$showlocalchanges} {
6035 doshowlocalchanges
6037 return 0
6040 # context menu for a head
6041 proc headmenu {x y id head} {
6042 global headmenuid headmenuhead headctxmenu mainhead
6044 set headmenuid $id
6045 set headmenuhead $head
6046 set state normal
6047 if {$head eq $mainhead} {
6048 set state disabled
6050 $headctxmenu entryconfigure 0 -state $state
6051 $headctxmenu entryconfigure 1 -state $state
6052 tk_popup $headctxmenu $x $y
6055 proc cobranch {} {
6056 global headmenuid headmenuhead mainhead headids
6057 global showlocalchanges mainheadid
6059 # check the tree is clean first??
6060 set oldmainhead $mainhead
6061 nowbusy checkout
6062 update
6063 dohidelocalchanges
6064 if {[catch {
6065 exec git checkout -q $headmenuhead
6066 } err]} {
6067 notbusy checkout
6068 error_popup $err
6069 } else {
6070 notbusy checkout
6071 set mainhead $headmenuhead
6072 set mainheadid $headmenuid
6073 if {[info exists headids($oldmainhead)]} {
6074 redrawtags $headids($oldmainhead)
6076 redrawtags $headmenuid
6078 if {$showlocalchanges} {
6079 dodiffindex
6083 proc rmbranch {} {
6084 global headmenuid headmenuhead mainhead
6085 global headids idheads
6087 set head $headmenuhead
6088 set id $headmenuid
6089 # this check shouldn't be needed any more...
6090 if {$head eq $mainhead} {
6091 error_popup "Cannot delete the currently checked-out branch"
6092 return
6094 set dheads [descheads $id]
6095 if {$dheads eq $headids($head)} {
6096 # the stuff on this branch isn't on any other branch
6097 if {![confirm_popup "The commits on branch $head aren't on any other\
6098 branch.\nReally delete branch $head?"]} return
6100 nowbusy rmbranch
6101 update
6102 if {[catch {exec git branch -D $head} err]} {
6103 notbusy rmbranch
6104 error_popup $err
6105 return
6107 removehead $id $head
6108 removedhead $id $head
6109 redrawtags $id
6110 notbusy rmbranch
6111 dispneartags 0
6114 # Stuff for finding nearby tags
6115 proc getallcommits {} {
6116 global allcommits allids nbmp nextarc seeds
6118 set allids {}
6119 set nbmp 0
6120 set nextarc 0
6121 set allcommits 0
6122 set seeds {}
6123 regetallcommits
6126 # Called when the graph might have changed
6127 proc regetallcommits {} {
6128 global allcommits seeds
6130 set cmd [concat | git rev-list --all --parents]
6131 foreach id $seeds {
6132 lappend cmd "^$id"
6134 set fd [open $cmd r]
6135 fconfigure $fd -blocking 0
6136 incr allcommits
6137 nowbusy allcommits
6138 filerun $fd [list getallclines $fd]
6141 # Since most commits have 1 parent and 1 child, we group strings of
6142 # such commits into "arcs" joining branch/merge points (BMPs), which
6143 # are commits that either don't have 1 parent or don't have 1 child.
6145 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6146 # arcout(id) - outgoing arcs for BMP
6147 # arcids(a) - list of IDs on arc including end but not start
6148 # arcstart(a) - BMP ID at start of arc
6149 # arcend(a) - BMP ID at end of arc
6150 # growing(a) - arc a is still growing
6151 # arctags(a) - IDs out of arcids (excluding end) that have tags
6152 # archeads(a) - IDs out of arcids (excluding end) that have heads
6153 # The start of an arc is at the descendent end, so "incoming" means
6154 # coming from descendents, and "outgoing" means going towards ancestors.
6156 proc getallclines {fd} {
6157 global allids allparents allchildren idtags idheads nextarc nbmp
6158 global arcnos arcids arctags arcout arcend arcstart archeads growing
6159 global seeds allcommits
6161 set nid 0
6162 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6163 set id [lindex $line 0]
6164 if {[info exists allparents($id)]} {
6165 # seen it already
6166 continue
6168 lappend allids $id
6169 set olds [lrange $line 1 end]
6170 set allparents($id) $olds
6171 if {![info exists allchildren($id)]} {
6172 set allchildren($id) {}
6173 set arcnos($id) {}
6174 lappend seeds $id
6175 } else {
6176 set a $arcnos($id)
6177 if {[llength $olds] == 1 && [llength $a] == 1} {
6178 lappend arcids($a) $id
6179 if {[info exists idtags($id)]} {
6180 lappend arctags($a) $id
6182 if {[info exists idheads($id)]} {
6183 lappend archeads($a) $id
6185 if {[info exists allparents($olds)]} {
6186 # seen parent already
6187 if {![info exists arcout($olds)]} {
6188 splitarc $olds
6190 lappend arcids($a) $olds
6191 set arcend($a) $olds
6192 unset growing($a)
6194 lappend allchildren($olds) $id
6195 lappend arcnos($olds) $a
6196 continue
6199 incr nbmp
6200 foreach a $arcnos($id) {
6201 lappend arcids($a) $id
6202 set arcend($a) $id
6203 unset growing($a)
6206 set ao {}
6207 foreach p $olds {
6208 lappend allchildren($p) $id
6209 set a [incr nextarc]
6210 set arcstart($a) $id
6211 set archeads($a) {}
6212 set arctags($a) {}
6213 set archeads($a) {}
6214 set arcids($a) {}
6215 lappend ao $a
6216 set growing($a) 1
6217 if {[info exists allparents($p)]} {
6218 # seen it already, may need to make a new branch
6219 if {![info exists arcout($p)]} {
6220 splitarc $p
6222 lappend arcids($a) $p
6223 set arcend($a) $p
6224 unset growing($a)
6226 lappend arcnos($p) $a
6228 set arcout($id) $ao
6230 if {$nid > 0} {
6231 global cached_dheads cached_dtags cached_atags
6232 catch {unset cached_dheads}
6233 catch {unset cached_dtags}
6234 catch {unset cached_atags}
6236 if {![eof $fd]} {
6237 return [expr {$nid >= 1000? 2: 1}]
6239 close $fd
6240 if {[incr allcommits -1] == 0} {
6241 notbusy allcommits
6243 dispneartags 0
6244 return 0
6247 proc recalcarc {a} {
6248 global arctags archeads arcids idtags idheads
6250 set at {}
6251 set ah {}
6252 foreach id [lrange $arcids($a) 0 end-1] {
6253 if {[info exists idtags($id)]} {
6254 lappend at $id
6256 if {[info exists idheads($id)]} {
6257 lappend ah $id
6260 set arctags($a) $at
6261 set archeads($a) $ah
6264 proc splitarc {p} {
6265 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6266 global arcstart arcend arcout allparents growing
6268 set a $arcnos($p)
6269 if {[llength $a] != 1} {
6270 puts "oops splitarc called but [llength $a] arcs already"
6271 return
6273 set a [lindex $a 0]
6274 set i [lsearch -exact $arcids($a) $p]
6275 if {$i < 0} {
6276 puts "oops splitarc $p not in arc $a"
6277 return
6279 set na [incr nextarc]
6280 if {[info exists arcend($a)]} {
6281 set arcend($na) $arcend($a)
6282 } else {
6283 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6284 set j [lsearch -exact $arcnos($l) $a]
6285 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6287 set tail [lrange $arcids($a) [expr {$i+1}] end]
6288 set arcids($a) [lrange $arcids($a) 0 $i]
6289 set arcend($a) $p
6290 set arcstart($na) $p
6291 set arcout($p) $na
6292 set arcids($na) $tail
6293 if {[info exists growing($a)]} {
6294 set growing($na) 1
6295 unset growing($a)
6297 incr nbmp
6299 foreach id $tail {
6300 if {[llength $arcnos($id)] == 1} {
6301 set arcnos($id) $na
6302 } else {
6303 set j [lsearch -exact $arcnos($id) $a]
6304 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6308 # reconstruct tags and heads lists
6309 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6310 recalcarc $a
6311 recalcarc $na
6312 } else {
6313 set arctags($na) {}
6314 set archeads($na) {}
6318 # Update things for a new commit added that is a child of one
6319 # existing commit. Used when cherry-picking.
6320 proc addnewchild {id p} {
6321 global allids allparents allchildren idtags nextarc nbmp
6322 global arcnos arcids arctags arcout arcend arcstart archeads growing
6323 global seeds
6325 lappend allids $id
6326 set allparents($id) [list $p]
6327 set allchildren($id) {}
6328 set arcnos($id) {}
6329 lappend seeds $id
6330 incr nbmp
6331 lappend allchildren($p) $id
6332 set a [incr nextarc]
6333 set arcstart($a) $id
6334 set archeads($a) {}
6335 set arctags($a) {}
6336 set arcids($a) [list $p]
6337 set arcend($a) $p
6338 if {![info exists arcout($p)]} {
6339 splitarc $p
6341 lappend arcnos($p) $a
6342 set arcout($id) [list $a]
6345 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6346 # or 0 if neither is true.
6347 proc anc_or_desc {a b} {
6348 global arcout arcstart arcend arcnos cached_isanc
6350 if {$arcnos($a) eq $arcnos($b)} {
6351 # Both are on the same arc(s); either both are the same BMP,
6352 # or if one is not a BMP, the other is also not a BMP or is
6353 # the BMP at end of the arc (and it only has 1 incoming arc).
6354 # Or both can be BMPs with no incoming arcs.
6355 if {$a eq $b || $arcnos($a) eq {}} {
6356 return 0
6358 # assert {[llength $arcnos($a)] == 1}
6359 set arc [lindex $arcnos($a) 0]
6360 set i [lsearch -exact $arcids($arc) $a]
6361 set j [lsearch -exact $arcids($arc) $b]
6362 if {$i < 0 || $i > $j} {
6363 return 1
6364 } else {
6365 return -1
6369 if {![info exists arcout($a)]} {
6370 set arc [lindex $arcnos($a) 0]
6371 if {[info exists arcend($arc)]} {
6372 set aend $arcend($arc)
6373 } else {
6374 set aend {}
6376 set a $arcstart($arc)
6377 } else {
6378 set aend $a
6380 if {![info exists arcout($b)]} {
6381 set arc [lindex $arcnos($b) 0]
6382 if {[info exists arcend($arc)]} {
6383 set bend $arcend($arc)
6384 } else {
6385 set bend {}
6387 set b $arcstart($arc)
6388 } else {
6389 set bend $b
6391 if {$a eq $bend} {
6392 return 1
6394 if {$b eq $aend} {
6395 return -1
6397 if {[info exists cached_isanc($a,$bend)]} {
6398 if {$cached_isanc($a,$bend)} {
6399 return 1
6402 if {[info exists cached_isanc($b,$aend)]} {
6403 if {$cached_isanc($b,$aend)} {
6404 return -1
6406 if {[info exists cached_isanc($a,$bend)]} {
6407 return 0
6411 set todo [list $a $b]
6412 set anc($a) a
6413 set anc($b) b
6414 for {set i 0} {$i < [llength $todo]} {incr i} {
6415 set x [lindex $todo $i]
6416 if {$anc($x) eq {}} {
6417 continue
6419 foreach arc $arcnos($x) {
6420 set xd $arcstart($arc)
6421 if {$xd eq $bend} {
6422 set cached_isanc($a,$bend) 1
6423 set cached_isanc($b,$aend) 0
6424 return 1
6425 } elseif {$xd eq $aend} {
6426 set cached_isanc($b,$aend) 1
6427 set cached_isanc($a,$bend) 0
6428 return -1
6430 if {![info exists anc($xd)]} {
6431 set anc($xd) $anc($x)
6432 lappend todo $xd
6433 } elseif {$anc($xd) ne $anc($x)} {
6434 set anc($xd) {}
6438 set cached_isanc($a,$bend) 0
6439 set cached_isanc($b,$aend) 0
6440 return 0
6443 # This identifies whether $desc has an ancestor that is
6444 # a growing tip of the graph and which is not an ancestor of $anc
6445 # and returns 0 if so and 1 if not.
6446 # If we subsequently discover a tag on such a growing tip, and that
6447 # turns out to be a descendent of $anc (which it could, since we
6448 # don't necessarily see children before parents), then $desc
6449 # isn't a good choice to display as a descendent tag of
6450 # $anc (since it is the descendent of another tag which is
6451 # a descendent of $anc). Similarly, $anc isn't a good choice to
6452 # display as a ancestor tag of $desc.
6454 proc is_certain {desc anc} {
6455 global arcnos arcout arcstart arcend growing problems
6457 set certain {}
6458 if {[llength $arcnos($anc)] == 1} {
6459 # tags on the same arc are certain
6460 if {$arcnos($desc) eq $arcnos($anc)} {
6461 return 1
6463 if {![info exists arcout($anc)]} {
6464 # if $anc is partway along an arc, use the start of the arc instead
6465 set a [lindex $arcnos($anc) 0]
6466 set anc $arcstart($a)
6469 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6470 set x $desc
6471 } else {
6472 set a [lindex $arcnos($desc) 0]
6473 set x $arcend($a)
6475 if {$x == $anc} {
6476 return 1
6478 set anclist [list $x]
6479 set dl($x) 1
6480 set nnh 1
6481 set ngrowanc 0
6482 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6483 set x [lindex $anclist $i]
6484 if {$dl($x)} {
6485 incr nnh -1
6487 set done($x) 1
6488 foreach a $arcout($x) {
6489 if {[info exists growing($a)]} {
6490 if {![info exists growanc($x)] && $dl($x)} {
6491 set growanc($x) 1
6492 incr ngrowanc
6494 } else {
6495 set y $arcend($a)
6496 if {[info exists dl($y)]} {
6497 if {$dl($y)} {
6498 if {!$dl($x)} {
6499 set dl($y) 0
6500 if {![info exists done($y)]} {
6501 incr nnh -1
6503 if {[info exists growanc($x)]} {
6504 incr ngrowanc -1
6506 set xl [list $y]
6507 for {set k 0} {$k < [llength $xl]} {incr k} {
6508 set z [lindex $xl $k]
6509 foreach c $arcout($z) {
6510 if {[info exists arcend($c)]} {
6511 set v $arcend($c)
6512 if {[info exists dl($v)] && $dl($v)} {
6513 set dl($v) 0
6514 if {![info exists done($v)]} {
6515 incr nnh -1
6517 if {[info exists growanc($v)]} {
6518 incr ngrowanc -1
6520 lappend xl $v
6527 } elseif {$y eq $anc || !$dl($x)} {
6528 set dl($y) 0
6529 lappend anclist $y
6530 } else {
6531 set dl($y) 1
6532 lappend anclist $y
6533 incr nnh
6538 foreach x [array names growanc] {
6539 if {$dl($x)} {
6540 return 0
6542 return 0
6544 return 1
6547 proc validate_arctags {a} {
6548 global arctags idtags
6550 set i -1
6551 set na $arctags($a)
6552 foreach id $arctags($a) {
6553 incr i
6554 if {![info exists idtags($id)]} {
6555 set na [lreplace $na $i $i]
6556 incr i -1
6559 set arctags($a) $na
6562 proc validate_archeads {a} {
6563 global archeads idheads
6565 set i -1
6566 set na $archeads($a)
6567 foreach id $archeads($a) {
6568 incr i
6569 if {![info exists idheads($id)]} {
6570 set na [lreplace $na $i $i]
6571 incr i -1
6574 set archeads($a) $na
6577 # Return the list of IDs that have tags that are descendents of id,
6578 # ignoring IDs that are descendents of IDs already reported.
6579 proc desctags {id} {
6580 global arcnos arcstart arcids arctags idtags allparents
6581 global growing cached_dtags
6583 if {![info exists allparents($id)]} {
6584 return {}
6586 set t1 [clock clicks -milliseconds]
6587 set argid $id
6588 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6589 # part-way along an arc; check that arc first
6590 set a [lindex $arcnos($id) 0]
6591 if {$arctags($a) ne {}} {
6592 validate_arctags $a
6593 set i [lsearch -exact $arcids($a) $id]
6594 set tid {}
6595 foreach t $arctags($a) {
6596 set j [lsearch -exact $arcids($a) $t]
6597 if {$j >= $i} break
6598 set tid $t
6600 if {$tid ne {}} {
6601 return $tid
6604 set id $arcstart($a)
6605 if {[info exists idtags($id)]} {
6606 return $id
6609 if {[info exists cached_dtags($id)]} {
6610 return $cached_dtags($id)
6613 set origid $id
6614 set todo [list $id]
6615 set queued($id) 1
6616 set nc 1
6617 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6618 set id [lindex $todo $i]
6619 set done($id) 1
6620 set ta [info exists hastaggedancestor($id)]
6621 if {!$ta} {
6622 incr nc -1
6624 # ignore tags on starting node
6625 if {!$ta && $i > 0} {
6626 if {[info exists idtags($id)]} {
6627 set tagloc($id) $id
6628 set ta 1
6629 } elseif {[info exists cached_dtags($id)]} {
6630 set tagloc($id) $cached_dtags($id)
6631 set ta 1
6634 foreach a $arcnos($id) {
6635 set d $arcstart($a)
6636 if {!$ta && $arctags($a) ne {}} {
6637 validate_arctags $a
6638 if {$arctags($a) ne {}} {
6639 lappend tagloc($id) [lindex $arctags($a) end]
6642 if {$ta || $arctags($a) ne {}} {
6643 set tomark [list $d]
6644 for {set j 0} {$j < [llength $tomark]} {incr j} {
6645 set dd [lindex $tomark $j]
6646 if {![info exists hastaggedancestor($dd)]} {
6647 if {[info exists done($dd)]} {
6648 foreach b $arcnos($dd) {
6649 lappend tomark $arcstart($b)
6651 if {[info exists tagloc($dd)]} {
6652 unset tagloc($dd)
6654 } elseif {[info exists queued($dd)]} {
6655 incr nc -1
6657 set hastaggedancestor($dd) 1
6661 if {![info exists queued($d)]} {
6662 lappend todo $d
6663 set queued($d) 1
6664 if {![info exists hastaggedancestor($d)]} {
6665 incr nc
6670 set tags {}
6671 foreach id [array names tagloc] {
6672 if {![info exists hastaggedancestor($id)]} {
6673 foreach t $tagloc($id) {
6674 if {[lsearch -exact $tags $t] < 0} {
6675 lappend tags $t
6680 set t2 [clock clicks -milliseconds]
6681 set loopix $i
6683 # remove tags that are descendents of other tags
6684 for {set i 0} {$i < [llength $tags]} {incr i} {
6685 set a [lindex $tags $i]
6686 for {set j 0} {$j < $i} {incr j} {
6687 set b [lindex $tags $j]
6688 set r [anc_or_desc $a $b]
6689 if {$r == 1} {
6690 set tags [lreplace $tags $j $j]
6691 incr j -1
6692 incr i -1
6693 } elseif {$r == -1} {
6694 set tags [lreplace $tags $i $i]
6695 incr i -1
6696 break
6701 if {[array names growing] ne {}} {
6702 # graph isn't finished, need to check if any tag could get
6703 # eclipsed by another tag coming later. Simply ignore any
6704 # tags that could later get eclipsed.
6705 set ctags {}
6706 foreach t $tags {
6707 if {[is_certain $t $origid]} {
6708 lappend ctags $t
6711 if {$tags eq $ctags} {
6712 set cached_dtags($origid) $tags
6713 } else {
6714 set tags $ctags
6716 } else {
6717 set cached_dtags($origid) $tags
6719 set t3 [clock clicks -milliseconds]
6720 if {0 && $t3 - $t1 >= 100} {
6721 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6722 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6724 return $tags
6727 proc anctags {id} {
6728 global arcnos arcids arcout arcend arctags idtags allparents
6729 global growing cached_atags
6731 if {![info exists allparents($id)]} {
6732 return {}
6734 set t1 [clock clicks -milliseconds]
6735 set argid $id
6736 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6737 # part-way along an arc; check that arc first
6738 set a [lindex $arcnos($id) 0]
6739 if {$arctags($a) ne {}} {
6740 validate_arctags $a
6741 set i [lsearch -exact $arcids($a) $id]
6742 foreach t $arctags($a) {
6743 set j [lsearch -exact $arcids($a) $t]
6744 if {$j > $i} {
6745 return $t
6749 if {![info exists arcend($a)]} {
6750 return {}
6752 set id $arcend($a)
6753 if {[info exists idtags($id)]} {
6754 return $id
6757 if {[info exists cached_atags($id)]} {
6758 return $cached_atags($id)
6761 set origid $id
6762 set todo [list $id]
6763 set queued($id) 1
6764 set taglist {}
6765 set nc 1
6766 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6767 set id [lindex $todo $i]
6768 set done($id) 1
6769 set td [info exists hastaggeddescendent($id)]
6770 if {!$td} {
6771 incr nc -1
6773 # ignore tags on starting node
6774 if {!$td && $i > 0} {
6775 if {[info exists idtags($id)]} {
6776 set tagloc($id) $id
6777 set td 1
6778 } elseif {[info exists cached_atags($id)]} {
6779 set tagloc($id) $cached_atags($id)
6780 set td 1
6783 foreach a $arcout($id) {
6784 if {!$td && $arctags($a) ne {}} {
6785 validate_arctags $a
6786 if {$arctags($a) ne {}} {
6787 lappend tagloc($id) [lindex $arctags($a) 0]
6790 if {![info exists arcend($a)]} continue
6791 set d $arcend($a)
6792 if {$td || $arctags($a) ne {}} {
6793 set tomark [list $d]
6794 for {set j 0} {$j < [llength $tomark]} {incr j} {
6795 set dd [lindex $tomark $j]
6796 if {![info exists hastaggeddescendent($dd)]} {
6797 if {[info exists done($dd)]} {
6798 foreach b $arcout($dd) {
6799 if {[info exists arcend($b)]} {
6800 lappend tomark $arcend($b)
6803 if {[info exists tagloc($dd)]} {
6804 unset tagloc($dd)
6806 } elseif {[info exists queued($dd)]} {
6807 incr nc -1
6809 set hastaggeddescendent($dd) 1
6813 if {![info exists queued($d)]} {
6814 lappend todo $d
6815 set queued($d) 1
6816 if {![info exists hastaggeddescendent($d)]} {
6817 incr nc
6822 set t2 [clock clicks -milliseconds]
6823 set loopix $i
6824 set tags {}
6825 foreach id [array names tagloc] {
6826 if {![info exists hastaggeddescendent($id)]} {
6827 foreach t $tagloc($id) {
6828 if {[lsearch -exact $tags $t] < 0} {
6829 lappend tags $t
6835 # remove tags that are ancestors of other tags
6836 for {set i 0} {$i < [llength $tags]} {incr i} {
6837 set a [lindex $tags $i]
6838 for {set j 0} {$j < $i} {incr j} {
6839 set b [lindex $tags $j]
6840 set r [anc_or_desc $a $b]
6841 if {$r == -1} {
6842 set tags [lreplace $tags $j $j]
6843 incr j -1
6844 incr i -1
6845 } elseif {$r == 1} {
6846 set tags [lreplace $tags $i $i]
6847 incr i -1
6848 break
6853 if {[array names growing] ne {}} {
6854 # graph isn't finished, need to check if any tag could get
6855 # eclipsed by another tag coming later. Simply ignore any
6856 # tags that could later get eclipsed.
6857 set ctags {}
6858 foreach t $tags {
6859 if {[is_certain $origid $t]} {
6860 lappend ctags $t
6863 if {$tags eq $ctags} {
6864 set cached_atags($origid) $tags
6865 } else {
6866 set tags $ctags
6868 } else {
6869 set cached_atags($origid) $tags
6871 set t3 [clock clicks -milliseconds]
6872 if {0 && $t3 - $t1 >= 100} {
6873 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6874 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6876 return $tags
6879 # Return the list of IDs that have heads that are descendents of id,
6880 # including id itself if it has a head.
6881 proc descheads {id} {
6882 global arcnos arcstart arcids archeads idheads cached_dheads
6883 global allparents
6885 if {![info exists allparents($id)]} {
6886 return {}
6888 set aret {}
6889 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6890 # part-way along an arc; check it first
6891 set a [lindex $arcnos($id) 0]
6892 if {$archeads($a) ne {}} {
6893 validate_archeads $a
6894 set i [lsearch -exact $arcids($a) $id]
6895 foreach t $archeads($a) {
6896 set j [lsearch -exact $arcids($a) $t]
6897 if {$j > $i} break
6898 lappend aret $t
6901 set id $arcstart($a)
6903 set origid $id
6904 set todo [list $id]
6905 set seen($id) 1
6906 set ret {}
6907 for {set i 0} {$i < [llength $todo]} {incr i} {
6908 set id [lindex $todo $i]
6909 if {[info exists cached_dheads($id)]} {
6910 set ret [concat $ret $cached_dheads($id)]
6911 } else {
6912 if {[info exists idheads($id)]} {
6913 lappend ret $id
6915 foreach a $arcnos($id) {
6916 if {$archeads($a) ne {}} {
6917 validate_archeads $a
6918 if {$archeads($a) ne {}} {
6919 set ret [concat $ret $archeads($a)]
6922 set d $arcstart($a)
6923 if {![info exists seen($d)]} {
6924 lappend todo $d
6925 set seen($d) 1
6930 set ret [lsort -unique $ret]
6931 set cached_dheads($origid) $ret
6932 return [concat $ret $aret]
6935 proc addedtag {id} {
6936 global arcnos arcout cached_dtags cached_atags
6938 if {![info exists arcnos($id)]} return
6939 if {![info exists arcout($id)]} {
6940 recalcarc [lindex $arcnos($id) 0]
6942 catch {unset cached_dtags}
6943 catch {unset cached_atags}
6946 proc addedhead {hid head} {
6947 global arcnos arcout cached_dheads
6949 if {![info exists arcnos($hid)]} return
6950 if {![info exists arcout($hid)]} {
6951 recalcarc [lindex $arcnos($hid) 0]
6953 catch {unset cached_dheads}
6956 proc removedhead {hid head} {
6957 global cached_dheads
6959 catch {unset cached_dheads}
6962 proc movedhead {hid head} {
6963 global arcnos arcout cached_dheads
6965 if {![info exists arcnos($hid)]} return
6966 if {![info exists arcout($hid)]} {
6967 recalcarc [lindex $arcnos($hid) 0]
6969 catch {unset cached_dheads}
6972 proc changedrefs {} {
6973 global cached_dheads cached_dtags cached_atags
6974 global arctags archeads arcnos arcout idheads idtags
6976 foreach id [concat [array names idheads] [array names idtags]] {
6977 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6978 set a [lindex $arcnos($id) 0]
6979 if {![info exists donearc($a)]} {
6980 recalcarc $a
6981 set donearc($a) 1
6985 catch {unset cached_dtags}
6986 catch {unset cached_atags}
6987 catch {unset cached_dheads}
6990 proc rereadrefs {} {
6991 global idtags idheads idotherrefs mainhead
6993 set refids [concat [array names idtags] \
6994 [array names idheads] [array names idotherrefs]]
6995 foreach id $refids {
6996 if {![info exists ref($id)]} {
6997 set ref($id) [listrefs $id]
7000 set oldmainhead $mainhead
7001 readrefs
7002 changedrefs
7003 set refids [lsort -unique [concat $refids [array names idtags] \
7004 [array names idheads] [array names idotherrefs]]]
7005 foreach id $refids {
7006 set v [listrefs $id]
7007 if {![info exists ref($id)] || $ref($id) != $v ||
7008 ($id eq $oldmainhead && $id ne $mainhead) ||
7009 ($id eq $mainhead && $id ne $oldmainhead)} {
7010 redrawtags $id
7015 proc listrefs {id} {
7016 global idtags idheads idotherrefs
7018 set x {}
7019 if {[info exists idtags($id)]} {
7020 set x $idtags($id)
7022 set y {}
7023 if {[info exists idheads($id)]} {
7024 set y $idheads($id)
7026 set z {}
7027 if {[info exists idotherrefs($id)]} {
7028 set z $idotherrefs($id)
7030 return [list $x $y $z]
7033 proc showtag {tag isnew} {
7034 global ctext tagcontents tagids linknum tagobjid
7036 if {$isnew} {
7037 addtohistory [list showtag $tag 0]
7039 $ctext conf -state normal
7040 clear_ctext
7041 set linknum 0
7042 if {![info exists tagcontents($tag)]} {
7043 catch {
7044 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7047 if {[info exists tagcontents($tag)]} {
7048 set text $tagcontents($tag)
7049 } else {
7050 set text "Tag: $tag\nId: $tagids($tag)"
7052 appendwithlinks $text {}
7053 $ctext conf -state disabled
7054 init_flist {}
7057 proc doquit {} {
7058 global stopped
7059 set stopped 100
7060 savestuff .
7061 destroy .
7064 proc doprefs {} {
7065 global maxwidth maxgraphpct diffopts
7066 global oldprefs prefstop showneartags showlocalchanges
7067 global bgcolor fgcolor ctext diffcolors selectbgcolor
7068 global uifont tabstop
7070 set top .gitkprefs
7071 set prefstop $top
7072 if {[winfo exists $top]} {
7073 raise $top
7074 return
7076 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7077 set oldprefs($v) [set $v]
7079 toplevel $top
7080 wm title $top "Gitk preferences"
7081 label $top.ldisp -text "Commit list display options"
7082 $top.ldisp configure -font $uifont
7083 grid $top.ldisp - -sticky w -pady 10
7084 label $top.spacer -text " "
7085 label $top.maxwidthl -text "Maximum graph width (lines)" \
7086 -font optionfont
7087 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7088 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7089 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7090 -font optionfont
7091 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7092 grid x $top.maxpctl $top.maxpct -sticky w
7093 frame $top.showlocal
7094 label $top.showlocal.l -text "Show local changes" -font optionfont
7095 checkbutton $top.showlocal.b -variable showlocalchanges
7096 pack $top.showlocal.b $top.showlocal.l -side left
7097 grid x $top.showlocal -sticky w
7099 label $top.ddisp -text "Diff display options"
7100 $top.ddisp configure -font $uifont
7101 grid $top.ddisp - -sticky w -pady 10
7102 label $top.diffoptl -text "Options for diff program" \
7103 -font optionfont
7104 entry $top.diffopt -width 20 -textvariable diffopts
7105 grid x $top.diffoptl $top.diffopt -sticky w
7106 frame $top.ntag
7107 label $top.ntag.l -text "Display nearby tags" -font optionfont
7108 checkbutton $top.ntag.b -variable showneartags
7109 pack $top.ntag.b $top.ntag.l -side left
7110 grid x $top.ntag -sticky w
7111 label $top.tabstopl -text "tabstop" -font optionfont
7112 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7113 grid x $top.tabstopl $top.tabstop -sticky w
7115 label $top.cdisp -text "Colors: press to choose"
7116 $top.cdisp configure -font $uifont
7117 grid $top.cdisp - -sticky w -pady 10
7118 label $top.bg -padx 40 -relief sunk -background $bgcolor
7119 button $top.bgbut -text "Background" -font optionfont \
7120 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7121 grid x $top.bgbut $top.bg -sticky w
7122 label $top.fg -padx 40 -relief sunk -background $fgcolor
7123 button $top.fgbut -text "Foreground" -font optionfont \
7124 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7125 grid x $top.fgbut $top.fg -sticky w
7126 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7127 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7128 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7129 [list $ctext tag conf d0 -foreground]]
7130 grid x $top.diffoldbut $top.diffold -sticky w
7131 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7132 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7133 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7134 [list $ctext tag conf d1 -foreground]]
7135 grid x $top.diffnewbut $top.diffnew -sticky w
7136 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7137 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7138 -command [list choosecolor diffcolors 2 $top.hunksep \
7139 "diff hunk header" \
7140 [list $ctext tag conf hunksep -foreground]]
7141 grid x $top.hunksepbut $top.hunksep -sticky w
7142 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7143 button $top.selbgbut -text "Select bg" -font optionfont \
7144 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7145 grid x $top.selbgbut $top.selbgsep -sticky w
7147 frame $top.buts
7148 button $top.buts.ok -text "OK" -command prefsok -default active
7149 $top.buts.ok configure -font $uifont
7150 button $top.buts.can -text "Cancel" -command prefscan -default normal
7151 $top.buts.can configure -font $uifont
7152 grid $top.buts.ok $top.buts.can
7153 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7154 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7155 grid $top.buts - - -pady 10 -sticky ew
7156 bind $top <Visibility> "focus $top.buts.ok"
7159 proc choosecolor {v vi w x cmd} {
7160 global $v
7162 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7163 -title "Gitk: choose color for $x"]
7164 if {$c eq {}} return
7165 $w conf -background $c
7166 lset $v $vi $c
7167 eval $cmd $c
7170 proc setselbg {c} {
7171 global bglist cflist
7172 foreach w $bglist {
7173 $w configure -selectbackground $c
7175 $cflist tag configure highlight \
7176 -background [$cflist cget -selectbackground]
7177 allcanvs itemconf secsel -fill $c
7180 proc setbg {c} {
7181 global bglist
7183 foreach w $bglist {
7184 $w conf -background $c
7188 proc setfg {c} {
7189 global fglist canv
7191 foreach w $fglist {
7192 $w conf -foreground $c
7194 allcanvs itemconf text -fill $c
7195 $canv itemconf circle -outline $c
7198 proc prefscan {} {
7199 global maxwidth maxgraphpct diffopts
7200 global oldprefs prefstop showneartags showlocalchanges
7202 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7203 set $v $oldprefs($v)
7205 catch {destroy $prefstop}
7206 unset prefstop
7209 proc prefsok {} {
7210 global maxwidth maxgraphpct
7211 global oldprefs prefstop showneartags showlocalchanges
7212 global charspc ctext tabstop
7214 catch {destroy $prefstop}
7215 unset prefstop
7216 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7217 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7218 if {$showlocalchanges} {
7219 doshowlocalchanges
7220 } else {
7221 dohidelocalchanges
7224 if {$maxwidth != $oldprefs(maxwidth)
7225 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7226 redisplay
7227 } elseif {$showneartags != $oldprefs(showneartags)} {
7228 reselectline
7232 proc formatdate {d} {
7233 if {$d ne {}} {
7234 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7236 return $d
7239 # This list of encoding names and aliases is distilled from
7240 # http://www.iana.org/assignments/character-sets.
7241 # Not all of them are supported by Tcl.
7242 set encoding_aliases {
7243 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7244 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7245 { ISO-10646-UTF-1 csISO10646UTF1 }
7246 { ISO_646.basic:1983 ref csISO646basic1983 }
7247 { INVARIANT csINVARIANT }
7248 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7249 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7250 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7251 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7252 { NATS-DANO iso-ir-9-1 csNATSDANO }
7253 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7254 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7255 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7256 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7257 { ISO-2022-KR csISO2022KR }
7258 { EUC-KR csEUCKR }
7259 { ISO-2022-JP csISO2022JP }
7260 { ISO-2022-JP-2 csISO2022JP2 }
7261 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7262 csISO13JISC6220jp }
7263 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7264 { IT iso-ir-15 ISO646-IT csISO15Italian }
7265 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7266 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7267 { greek7-old iso-ir-18 csISO18Greek7Old }
7268 { latin-greek iso-ir-19 csISO19LatinGreek }
7269 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7270 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7271 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7272 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7273 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7274 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7275 { INIS iso-ir-49 csISO49INIS }
7276 { INIS-8 iso-ir-50 csISO50INIS8 }
7277 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7278 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7279 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7280 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7281 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7282 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7283 csISO60Norwegian1 }
7284 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7285 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7286 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7287 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7288 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7289 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7290 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7291 { greek7 iso-ir-88 csISO88Greek7 }
7292 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7293 { iso-ir-90 csISO90 }
7294 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7295 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7296 csISO92JISC62991984b }
7297 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7298 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7299 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7300 csISO95JIS62291984handadd }
7301 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7302 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7303 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7304 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7305 CP819 csISOLatin1 }
7306 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7307 { T.61-7bit iso-ir-102 csISO102T617bit }
7308 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7309 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7310 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7311 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7312 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7313 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7314 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7315 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7316 arabic csISOLatinArabic }
7317 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7318 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7319 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7320 greek greek8 csISOLatinGreek }
7321 { T.101-G2 iso-ir-128 csISO128T101G2 }
7322 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7323 csISOLatinHebrew }
7324 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7325 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7326 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7327 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7328 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7329 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7330 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7331 csISOLatinCyrillic }
7332 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7333 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7334 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7335 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7336 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7337 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7338 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7339 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7340 { ISO_10367-box iso-ir-155 csISO10367Box }
7341 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7342 { latin-lap lap iso-ir-158 csISO158Lap }
7343 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7344 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7345 { us-dk csUSDK }
7346 { dk-us csDKUS }
7347 { JIS_X0201 X0201 csHalfWidthKatakana }
7348 { KSC5636 ISO646-KR csKSC5636 }
7349 { ISO-10646-UCS-2 csUnicode }
7350 { ISO-10646-UCS-4 csUCS4 }
7351 { DEC-MCS dec csDECMCS }
7352 { hp-roman8 roman8 r8 csHPRoman8 }
7353 { macintosh mac csMacintosh }
7354 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7355 csIBM037 }
7356 { IBM038 EBCDIC-INT cp038 csIBM038 }
7357 { IBM273 CP273 csIBM273 }
7358 { IBM274 EBCDIC-BE CP274 csIBM274 }
7359 { IBM275 EBCDIC-BR cp275 csIBM275 }
7360 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7361 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7362 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7363 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7364 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7365 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7366 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7367 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7368 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7369 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7370 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7371 { IBM437 cp437 437 csPC8CodePage437 }
7372 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7373 { IBM775 cp775 csPC775Baltic }
7374 { IBM850 cp850 850 csPC850Multilingual }
7375 { IBM851 cp851 851 csIBM851 }
7376 { IBM852 cp852 852 csPCp852 }
7377 { IBM855 cp855 855 csIBM855 }
7378 { IBM857 cp857 857 csIBM857 }
7379 { IBM860 cp860 860 csIBM860 }
7380 { IBM861 cp861 861 cp-is csIBM861 }
7381 { IBM862 cp862 862 csPC862LatinHebrew }
7382 { IBM863 cp863 863 csIBM863 }
7383 { IBM864 cp864 csIBM864 }
7384 { IBM865 cp865 865 csIBM865 }
7385 { IBM866 cp866 866 csIBM866 }
7386 { IBM868 CP868 cp-ar csIBM868 }
7387 { IBM869 cp869 869 cp-gr csIBM869 }
7388 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7389 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7390 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7391 { IBM891 cp891 csIBM891 }
7392 { IBM903 cp903 csIBM903 }
7393 { IBM904 cp904 904 csIBBM904 }
7394 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7395 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7396 { IBM1026 CP1026 csIBM1026 }
7397 { EBCDIC-AT-DE csIBMEBCDICATDE }
7398 { EBCDIC-AT-DE-A csEBCDICATDEA }
7399 { EBCDIC-CA-FR csEBCDICCAFR }
7400 { EBCDIC-DK-NO csEBCDICDKNO }
7401 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7402 { EBCDIC-FI-SE csEBCDICFISE }
7403 { EBCDIC-FI-SE-A csEBCDICFISEA }
7404 { EBCDIC-FR csEBCDICFR }
7405 { EBCDIC-IT csEBCDICIT }
7406 { EBCDIC-PT csEBCDICPT }
7407 { EBCDIC-ES csEBCDICES }
7408 { EBCDIC-ES-A csEBCDICESA }
7409 { EBCDIC-ES-S csEBCDICESS }
7410 { EBCDIC-UK csEBCDICUK }
7411 { EBCDIC-US csEBCDICUS }
7412 { UNKNOWN-8BIT csUnknown8BiT }
7413 { MNEMONIC csMnemonic }
7414 { MNEM csMnem }
7415 { VISCII csVISCII }
7416 { VIQR csVIQR }
7417 { KOI8-R csKOI8R }
7418 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7419 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7420 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7421 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7422 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7423 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7424 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7425 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7426 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7427 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7428 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7429 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7430 { IBM1047 IBM-1047 }
7431 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7432 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7433 { UNICODE-1-1 csUnicode11 }
7434 { CESU-8 csCESU-8 }
7435 { BOCU-1 csBOCU-1 }
7436 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7437 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7438 l8 }
7439 { ISO-8859-15 ISO_8859-15 Latin-9 }
7440 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7441 { GBK CP936 MS936 windows-936 }
7442 { JIS_Encoding csJISEncoding }
7443 { Shift_JIS MS_Kanji csShiftJIS }
7444 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7445 EUC-JP }
7446 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7447 { ISO-10646-UCS-Basic csUnicodeASCII }
7448 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7449 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7450 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7451 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7452 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7453 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7454 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7455 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7456 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7457 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7458 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7459 { Ventura-US csVenturaUS }
7460 { Ventura-International csVenturaInternational }
7461 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7462 { PC8-Turkish csPC8Turkish }
7463 { IBM-Symbols csIBMSymbols }
7464 { IBM-Thai csIBMThai }
7465 { HP-Legal csHPLegal }
7466 { HP-Pi-font csHPPiFont }
7467 { HP-Math8 csHPMath8 }
7468 { Adobe-Symbol-Encoding csHPPSMath }
7469 { HP-DeskTop csHPDesktop }
7470 { Ventura-Math csVenturaMath }
7471 { Microsoft-Publishing csMicrosoftPublishing }
7472 { Windows-31J csWindows31J }
7473 { GB2312 csGB2312 }
7474 { Big5 csBig5 }
7477 proc tcl_encoding {enc} {
7478 global encoding_aliases
7479 set names [encoding names]
7480 set lcnames [string tolower $names]
7481 set enc [string tolower $enc]
7482 set i [lsearch -exact $lcnames $enc]
7483 if {$i < 0} {
7484 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7485 if {[regsub {^iso[-_]} $enc iso encx]} {
7486 set i [lsearch -exact $lcnames $encx]
7489 if {$i < 0} {
7490 foreach l $encoding_aliases {
7491 set ll [string tolower $l]
7492 if {[lsearch -exact $ll $enc] < 0} continue
7493 # look through the aliases for one that tcl knows about
7494 foreach e $ll {
7495 set i [lsearch -exact $lcnames $e]
7496 if {$i < 0} {
7497 if {[regsub {^iso[-_]} $e iso ex]} {
7498 set i [lsearch -exact $lcnames $ex]
7501 if {$i >= 0} break
7503 break
7506 if {$i >= 0} {
7507 return [lindex $names $i]
7509 return {}
7512 # defaults...
7513 set datemode 0
7514 set diffopts "-U 5 -p"
7515 set wrcomcmd "git diff-tree --stdin -p --pretty"
7517 set gitencoding {}
7518 catch {
7519 set gitencoding [exec git config --get i18n.commitencoding]
7521 if {$gitencoding == ""} {
7522 set gitencoding "utf-8"
7524 set tclencoding [tcl_encoding $gitencoding]
7525 if {$tclencoding == {}} {
7526 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7529 set mainfont {Helvetica 9}
7530 set textfont {Courier 9}
7531 set uifont {Helvetica 9 bold}
7532 set tabstop 8
7533 set findmergefiles 0
7534 set maxgraphpct 50
7535 set maxwidth 16
7536 set revlistorder 0
7537 set fastdate 0
7538 set uparrowlen 5
7539 set downarrowlen 5
7540 set mingaplen 100
7541 set cmitmode "patch"
7542 set wrapcomment "none"
7543 set showneartags 1
7544 set maxrefs 20
7545 set maxlinelen 200
7546 set showlocalchanges 1
7548 set colors {green red blue magenta darkgrey brown orange}
7549 set bgcolor white
7550 set fgcolor black
7551 set diffcolors {red "#00a000" blue}
7552 set selectbgcolor gray85
7554 catch {source ~/.gitk}
7556 font create optionfont -family sans-serif -size -12
7558 # check that we can find a .git directory somewhere...
7559 set gitdir [gitdir]
7560 if {![file isdirectory $gitdir]} {
7561 show_error {} . "Cannot find the git directory \"$gitdir\"."
7562 exit 1
7565 set revtreeargs {}
7566 set cmdline_files {}
7567 set i 0
7568 foreach arg $argv {
7569 switch -- $arg {
7570 "" { }
7571 "-d" { set datemode 1 }
7572 "--" {
7573 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7574 break
7576 default {
7577 lappend revtreeargs $arg
7580 incr i
7583 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7584 # no -- on command line, but some arguments (other than -d)
7585 if {[catch {
7586 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7587 set cmdline_files [split $f "\n"]
7588 set n [llength $cmdline_files]
7589 set revtreeargs [lrange $revtreeargs 0 end-$n]
7590 # Unfortunately git rev-parse doesn't produce an error when
7591 # something is both a revision and a filename. To be consistent
7592 # with git log and git rev-list, check revtreeargs for filenames.
7593 foreach arg $revtreeargs {
7594 if {[file exists $arg]} {
7595 show_error {} . "Ambiguous argument '$arg': both revision\
7596 and filename"
7597 exit 1
7600 } err]} {
7601 # unfortunately we get both stdout and stderr in $err,
7602 # so look for "fatal:".
7603 set i [string first "fatal:" $err]
7604 if {$i > 0} {
7605 set err [string range $err [expr {$i + 6}] end]
7607 show_error {} . "Bad arguments to gitk:\n$err"
7608 exit 1
7612 set nullid "0000000000000000000000000000000000000000"
7613 set nullid2 "0000000000000000000000000000000000000001"
7616 set runq {}
7617 set history {}
7618 set historyindex 0
7619 set fh_serial 0
7620 set nhl_names {}
7621 set highlight_paths {}
7622 set searchdirn -forwards
7623 set boldrows {}
7624 set boldnamerows {}
7625 set diffelide {0 0}
7626 set markingmatches 0
7628 set optim_delay 16
7630 set nextviewnum 1
7631 set curview 0
7632 set selectedview 0
7633 set selectedhlview None
7634 set viewfiles(0) {}
7635 set viewperm(0) 0
7636 set viewargs(0) {}
7638 set cmdlineok 0
7639 set stopped 0
7640 set stuffsaved 0
7641 set patchnum 0
7642 set lookingforhead 0
7643 set localirow -1
7644 set localfrow -1
7645 set lserial 0
7646 setcoords
7647 makewindow
7648 # wait for the window to become visible
7649 tkwait visibility .
7650 wm title . "[file tail $argv0]: [file tail [pwd]]"
7651 readrefs
7653 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7654 # create a view for the files/dirs specified on the command line
7655 set curview 1
7656 set selectedview 1
7657 set nextviewnum 2
7658 set viewname(1) "Command line"
7659 set viewfiles(1) $cmdline_files
7660 set viewargs(1) $revtreeargs
7661 set viewperm(1) 0
7662 addviewmenu 1
7663 .bar.view entryconf Edit* -state normal
7664 .bar.view entryconf Delete* -state normal
7667 if {[info exists permviews]} {
7668 foreach v $permviews {
7669 set n $nextviewnum
7670 incr nextviewnum
7671 set viewname($n) [lindex $v 0]
7672 set viewfiles($n) [lindex $v 1]
7673 set viewargs($n) [lindex $v 2]
7674 set viewperm($n) 1
7675 addviewmenu $n
7678 getcommits