gitk: Eliminate diagonal arrows
[git/gitweb.git] / gitk
blob7b62e98ec12876fb8a4324721a6ea14e0830807c
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 0} {$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 set idlist [lindex $rowidlist $row]
3009 set bef [lrange $idlist 0 [expr {$col - 1}]]
3010 set aft [lrange $idlist $col end]
3011 set i [lsearch -exact $aft {}]
3012 if {$i > 0} {
3013 set aft [lreplace $aft $i $i]
3015 lset rowidlist $row [concat $bef $pad $aft]
3018 proc optimize_rows {row col endrow} {
3019 global rowidlist displayorder
3021 if {$row < 1} {
3022 set row 1
3024 set idlist [lindex $rowidlist [expr {$row - 1}]]
3025 if {$row >= 2} {
3026 set previdlist [lindex $rowidlist [expr {$row - 2}]]
3027 } else {
3028 set previdlist {}
3030 for {} {$row < $endrow} {incr row} {
3031 set pprevidlist $previdlist
3032 set previdlist $idlist
3033 set idlist [lindex $rowidlist $row]
3034 set haspad 0
3035 set y0 [expr {$row - 1}]
3036 set ym [expr {$row - 2}]
3037 set x0 -1
3038 set xm -1
3039 for {} {$col < [llength $idlist]} {incr col} {
3040 set id [lindex $idlist $col]
3041 if {[lindex $previdlist $col] eq $id} continue
3042 if {$id eq {}} {
3043 set haspad 1
3044 continue
3046 set x0 [lsearch -exact $previdlist $id]
3047 if {$x0 < 0} continue
3048 set z [expr {$x0 - $col}]
3049 set isarrow 0
3050 set z0 {}
3051 if {$ym >= 0} {
3052 set xm [lsearch -exact $pprevidlist $id]
3053 if {$xm >= 0} {
3054 set z0 [expr {$xm - $x0}]
3057 if {$z0 eq {}} {
3058 set ranges [rowranges $id]
3059 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3060 set isarrow 1
3063 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3064 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3065 set isarrow 1
3067 # Looking at lines from this row to the previous row,
3068 # make them go straight up if they end in an arrow on
3069 # the previous row; otherwise make them go straight up
3070 # or at 45 degrees.
3071 if {$z < -1 || ($z < 0 && $isarrow)} {
3072 # Line currently goes left too much;
3073 # insert pads in the previous row, then optimize it
3074 set npad [expr {-1 - $z + $isarrow}]
3075 insert_pad $y0 $x0 $npad
3076 if {$y0 > 0} {
3077 optimize_rows $y0 $x0 $row
3079 set previdlist [lindex $rowidlist $y0]
3080 set x0 [lsearch -exact $previdlist $id]
3081 set z [expr {$x0 - $col}]
3082 if {$z0 ne {}} {
3083 set pprevidlist [lindex $rowidlist $ym]
3084 set xm [lsearch -exact $pprevidlist $id]
3085 set z0 [expr {$xm - $x0}]
3087 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3088 # Line currently goes right too much;
3089 # insert pads in this line
3090 set npad [expr {$z - 1 + $isarrow}]
3091 insert_pad $row $col $npad
3092 set idlist [lindex $rowidlist $row]
3093 incr col $npad
3094 set z [expr {$x0 - $col}]
3095 set haspad 1
3097 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3098 # this line links to its first child on row $row-2
3099 set id [lindex $displayorder $ym]
3100 set xc [lsearch -exact $pprevidlist $id]
3101 if {$xc >= 0} {
3102 set z0 [expr {$xc - $x0}]
3105 # avoid lines jigging left then immediately right
3106 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3107 insert_pad $y0 $x0 1
3108 incr x0
3109 optimize_rows $y0 $x0 $row
3110 set previdlist [lindex $rowidlist $y0]
3111 set pprevidlist [lindex $rowidlist $ym]
3114 if {!$haspad} {
3115 # Find the first column that doesn't have a line going right
3116 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3117 set id [lindex $idlist $col]
3118 if {$id eq {}} break
3119 set x0 [lsearch -exact $previdlist $id]
3120 if {$x0 < 0} {
3121 # check if this is the link to the first child
3122 set ranges [rowranges $id]
3123 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3124 # it is, work out offset to child
3125 set id [lindex $displayorder $y0]
3126 set x0 [lsearch -exact $previdlist $id]
3129 if {$x0 <= $col} break
3131 # Insert a pad at that column as long as it has a line and
3132 # isn't the last column
3133 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3134 set idlist [linsert $idlist $col {}]
3137 lset rowidlist $row $idlist
3138 set col 0
3142 proc xc {row col} {
3143 global canvx0 linespc
3144 return [expr {$canvx0 + $col * $linespc}]
3147 proc yc {row} {
3148 global canvy0 linespc
3149 return [expr {$canvy0 + $row * $linespc}]
3152 proc linewidth {id} {
3153 global thickerline lthickness
3155 set wid $lthickness
3156 if {[info exists thickerline] && $id eq $thickerline} {
3157 set wid [expr {2 * $lthickness}]
3159 return $wid
3162 proc rowranges {id} {
3163 global phase idrowranges commitrow rowlaidout rowrangelist curview
3165 set ranges {}
3166 if {$phase eq {} ||
3167 ([info exists commitrow($curview,$id)]
3168 && $commitrow($curview,$id) < $rowlaidout)} {
3169 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3170 } elseif {[info exists idrowranges($id)]} {
3171 set ranges $idrowranges($id)
3173 set linenos {}
3174 foreach rid $ranges {
3175 lappend linenos $commitrow($curview,$rid)
3177 if {$linenos ne {}} {
3178 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3180 return $linenos
3183 proc drawlineseg {id row endrow arrowlow} {
3184 global rowidlist displayorder iddrawn linesegs
3185 global canv colormap linespc curview maxlinelen parentlist
3187 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3188 set le [expr {$row + 1}]
3189 set arrowhigh 1
3190 while {1} {
3191 set c [lsearch -exact [lindex $rowidlist $le] $id]
3192 if {$c < 0} {
3193 incr le -1
3194 break
3196 lappend cols $c
3197 set x [lindex $displayorder $le]
3198 if {$x eq $id} {
3199 set arrowhigh 0
3200 break
3202 if {[info exists iddrawn($x)] || $le == $endrow} {
3203 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3204 if {$c >= 0} {
3205 lappend cols $c
3206 set arrowhigh 0
3208 break
3210 incr le
3212 if {$le <= $row} {
3213 return $row
3216 set lines {}
3217 set i 0
3218 set joinhigh 0
3219 if {[info exists linesegs($id)]} {
3220 set lines $linesegs($id)
3221 foreach li $lines {
3222 set r0 [lindex $li 0]
3223 if {$r0 > $row} {
3224 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3225 set joinhigh 1
3227 break
3229 incr i
3232 set joinlow 0
3233 if {$i > 0} {
3234 set li [lindex $lines [expr {$i-1}]]
3235 set r1 [lindex $li 1]
3236 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3237 set joinlow 1
3241 set x [lindex $cols [expr {$le - $row}]]
3242 set xp [lindex $cols [expr {$le - 1 - $row}]]
3243 set dir [expr {$xp - $x}]
3244 if {$joinhigh} {
3245 set ith [lindex $lines $i 2]
3246 set coords [$canv coords $ith]
3247 set ah [$canv itemcget $ith -arrow]
3248 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3249 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3250 if {$x2 ne {} && $x - $x2 == $dir} {
3251 set coords [lrange $coords 0 end-2]
3253 } else {
3254 set coords [list [xc $le $x] [yc $le]]
3256 if {$joinlow} {
3257 set itl [lindex $lines [expr {$i-1}] 2]
3258 set al [$canv itemcget $itl -arrow]
3259 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3260 } elseif {$arrowlow} {
3261 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3262 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3263 set arrowlow 0
3266 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3267 for {set y $le} {[incr y -1] > $row} {} {
3268 set x $xp
3269 set xp [lindex $cols [expr {$y - 1 - $row}]]
3270 set ndir [expr {$xp - $x}]
3271 if {$dir != $ndir || $xp < 0} {
3272 lappend coords [xc $y $x] [yc $y]
3274 set dir $ndir
3276 if {!$joinlow} {
3277 if {$xp < 0} {
3278 # join parent line to first child
3279 set ch [lindex $displayorder $row]
3280 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3281 if {$xc < 0} {
3282 puts "oops: drawlineseg: child $ch not on row $row"
3283 } elseif {$xc != $x} {
3284 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3285 set d [expr {int(0.5 * $linespc)}]
3286 set x1 [xc $row $x]
3287 if {$xc < $x} {
3288 set x2 [expr {$x1 - $d}]
3289 } else {
3290 set x2 [expr {$x1 + $d}]
3292 set y2 [yc $row]
3293 set y1 [expr {$y2 + $d}]
3294 lappend coords $x1 $y1 $x2 $y2
3295 } elseif {$xc < $x - 1} {
3296 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3297 } elseif {$xc > $x + 1} {
3298 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3300 set x $xc
3302 lappend coords [xc $row $x] [yc $row]
3303 } else {
3304 set xn [xc $row $xp]
3305 set yn [yc $row]
3306 lappend coords $xn $yn
3308 if {!$joinhigh} {
3309 assigncolor $id
3310 set t [$canv create line $coords -width [linewidth $id] \
3311 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3312 $canv lower $t
3313 bindline $t $id
3314 set lines [linsert $lines $i [list $row $le $t]]
3315 } else {
3316 $canv coords $ith $coords
3317 if {$arrow ne $ah} {
3318 $canv itemconf $ith -arrow $arrow
3320 lset lines $i 0 $row
3322 } else {
3323 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3324 set ndir [expr {$xo - $xp}]
3325 set clow [$canv coords $itl]
3326 if {$dir == $ndir} {
3327 set clow [lrange $clow 2 end]
3329 set coords [concat $coords $clow]
3330 if {!$joinhigh} {
3331 lset lines [expr {$i-1}] 1 $le
3332 } else {
3333 # coalesce two pieces
3334 $canv delete $ith
3335 set b [lindex $lines [expr {$i-1}] 0]
3336 set e [lindex $lines $i 1]
3337 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3339 $canv coords $itl $coords
3340 if {$arrow ne $al} {
3341 $canv itemconf $itl -arrow $arrow
3345 set linesegs($id) $lines
3346 return $le
3349 proc drawparentlinks {id row} {
3350 global rowidlist canv colormap curview parentlist
3351 global idpos linespc
3353 set rowids [lindex $rowidlist $row]
3354 set col [lsearch -exact $rowids $id]
3355 if {$col < 0} return
3356 set olds [lindex $parentlist $row]
3357 set row2 [expr {$row + 1}]
3358 set x [xc $row $col]
3359 set y [yc $row]
3360 set y2 [yc $row2]
3361 set d [expr {int(0.5 * $linespc)}]
3362 set ymid [expr {$y + $d}]
3363 set ids [lindex $rowidlist $row2]
3364 # rmx = right-most X coord used
3365 set rmx 0
3366 foreach p $olds {
3367 set i [lsearch -exact $ids $p]
3368 if {$i < 0} {
3369 puts "oops, parent $p of $id not in list"
3370 continue
3372 set x2 [xc $row2 $i]
3373 if {$x2 > $rmx} {
3374 set rmx $x2
3376 set j [lsearch -exact $rowids $p]
3377 if {$j < 0} {
3378 # drawlineseg will do this one for us
3379 continue
3381 assigncolor $p
3382 # should handle duplicated parents here...
3383 set coords [list $x $y]
3384 if {$i != $col} {
3385 # if attaching to a vertical segment, draw a smaller
3386 # slant for visual distinctness
3387 if {$i == $j} {
3388 if {$i < $col} {
3389 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3390 } else {
3391 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3393 } elseif {$i < $col && $i < $j} {
3394 # segment slants towards us already
3395 lappend coords [xc $row $j] $y
3396 } else {
3397 if {$i < $col - 1} {
3398 lappend coords [expr {$x2 + $linespc}] $y
3399 } elseif {$i > $col + 1} {
3400 lappend coords [expr {$x2 - $linespc}] $y
3402 lappend coords $x2 $y2
3404 } else {
3405 lappend coords $x2 $y2
3407 set t [$canv create line $coords -width [linewidth $p] \
3408 -fill $colormap($p) -tags lines.$p]
3409 $canv lower $t
3410 bindline $t $p
3412 if {$rmx > [lindex $idpos($id) 1]} {
3413 lset idpos($id) 1 $rmx
3414 redrawtags $id
3418 proc drawlines {id} {
3419 global canv
3421 $canv itemconf lines.$id -width [linewidth $id]
3424 proc drawcmittext {id row col} {
3425 global linespc canv canv2 canv3 canvy0 fgcolor curview
3426 global commitlisted commitinfo rowidlist parentlist
3427 global rowtextx idpos idtags idheads idotherrefs
3428 global linehtag linentag linedtag
3429 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3431 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3432 set listed [lindex $commitlisted $row]
3433 if {$id eq $nullid} {
3434 set ofill red
3435 } elseif {$id eq $nullid2} {
3436 set ofill green
3437 } else {
3438 set ofill [expr {$listed != 0? "blue": "white"}]
3440 set x [xc $row $col]
3441 set y [yc $row]
3442 set orad [expr {$linespc / 3}]
3443 if {$listed <= 1} {
3444 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3445 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3446 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3447 } elseif {$listed == 2} {
3448 # triangle pointing left for left-side commits
3449 set t [$canv create polygon \
3450 [expr {$x - $orad}] $y \
3451 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3452 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3453 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3454 } else {
3455 # triangle pointing right for right-side commits
3456 set t [$canv create polygon \
3457 [expr {$x + $orad - 1}] $y \
3458 [expr {$x - $orad}] [expr {$y - $orad}] \
3459 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3460 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3462 $canv raise $t
3463 $canv bind $t <1> {selcanvline {} %x %y}
3464 set rmx [llength [lindex $rowidlist $row]]
3465 set olds [lindex $parentlist $row]
3466 if {$olds ne {}} {
3467 set nextids [lindex $rowidlist [expr {$row + 1}]]
3468 foreach p $olds {
3469 set i [lsearch -exact $nextids $p]
3470 if {$i > $rmx} {
3471 set rmx $i
3475 set xt [xc $row $rmx]
3476 set rowtextx($row) $xt
3477 set idpos($id) [list $x $xt $y]
3478 if {[info exists idtags($id)] || [info exists idheads($id)]
3479 || [info exists idotherrefs($id)]} {
3480 set xt [drawtags $id $x $xt $y]
3482 set headline [lindex $commitinfo($id) 0]
3483 set name [lindex $commitinfo($id) 1]
3484 set date [lindex $commitinfo($id) 2]
3485 set date [formatdate $date]
3486 set font $mainfont
3487 set nfont $mainfont
3488 set isbold [ishighlighted $row]
3489 if {$isbold > 0} {
3490 lappend boldrows $row
3491 lappend font bold
3492 if {$isbold > 1} {
3493 lappend boldnamerows $row
3494 lappend nfont bold
3497 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3498 -text $headline -font $font -tags text]
3499 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3500 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3501 -text $name -font $nfont -tags text]
3502 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3503 -text $date -font $mainfont -tags text]
3504 set xr [expr {$xt + [font measure $mainfont $headline]}]
3505 if {$xr > $canvxmax} {
3506 set canvxmax $xr
3507 setcanvscroll
3511 proc drawcmitrow {row} {
3512 global displayorder rowidlist
3513 global iddrawn markingmatches
3514 global commitinfo parentlist numcommits
3515 global filehighlight fhighlights findstring nhighlights
3516 global hlview vhighlights
3517 global highlight_related rhighlights
3519 if {$row >= $numcommits} return
3521 set id [lindex $displayorder $row]
3522 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3523 askvhighlight $row $id
3525 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3526 askfilehighlight $row $id
3528 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3529 askfindhighlight $row $id
3531 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3532 askrelhighlight $row $id
3534 if {![info exists iddrawn($id)]} {
3535 set col [lsearch -exact [lindex $rowidlist $row] $id]
3536 if {$col < 0} {
3537 puts "oops, row $row id $id not in list"
3538 return
3540 if {![info exists commitinfo($id)]} {
3541 getcommit $id
3543 assigncolor $id
3544 drawcmittext $id $row $col
3545 set iddrawn($id) 1
3547 if {$markingmatches} {
3548 markrowmatches $row $id
3552 proc drawcommits {row {endrow {}}} {
3553 global numcommits iddrawn displayorder curview
3554 global parentlist rowidlist
3556 if {$row < 0} {
3557 set row 0
3559 if {$endrow eq {}} {
3560 set endrow $row
3562 if {$endrow >= $numcommits} {
3563 set endrow [expr {$numcommits - 1}]
3566 # make the lines join to already-drawn rows either side
3567 set r [expr {$row - 1}]
3568 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3569 set r $row
3571 set er [expr {$endrow + 1}]
3572 if {$er >= $numcommits ||
3573 ![info exists iddrawn([lindex $displayorder $er])]} {
3574 set er $endrow
3576 for {} {$r <= $er} {incr r} {
3577 set id [lindex $displayorder $r]
3578 set wasdrawn [info exists iddrawn($id)]
3579 drawcmitrow $r
3580 if {$r == $er} break
3581 set nextid [lindex $displayorder [expr {$r + 1}]]
3582 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3583 catch {unset prevlines}
3584 continue
3586 drawparentlinks $id $r
3588 if {[info exists lineends($r)]} {
3589 foreach lid $lineends($r) {
3590 unset prevlines($lid)
3593 set rowids [lindex $rowidlist $r]
3594 foreach lid $rowids {
3595 if {$lid eq {}} continue
3596 if {$lid eq $id} {
3597 # see if this is the first child of any of its parents
3598 foreach p [lindex $parentlist $r] {
3599 if {[lsearch -exact $rowids $p] < 0} {
3600 # make this line extend up to the child
3601 set le [drawlineseg $p $r $er 0]
3602 lappend lineends($le) $p
3603 set prevlines($p) 1
3606 } elseif {![info exists prevlines($lid)]} {
3607 set le [drawlineseg $lid $r $er 1]
3608 lappend lineends($le) $lid
3609 set prevlines($lid) 1
3615 proc drawfrac {f0 f1} {
3616 global canv linespc
3618 set ymax [lindex [$canv cget -scrollregion] 3]
3619 if {$ymax eq {} || $ymax == 0} return
3620 set y0 [expr {int($f0 * $ymax)}]
3621 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3622 set y1 [expr {int($f1 * $ymax)}]
3623 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3624 drawcommits $row $endrow
3627 proc drawvisible {} {
3628 global canv
3629 eval drawfrac [$canv yview]
3632 proc clear_display {} {
3633 global iddrawn linesegs
3634 global vhighlights fhighlights nhighlights rhighlights
3636 allcanvs delete all
3637 catch {unset iddrawn}
3638 catch {unset linesegs}
3639 catch {unset vhighlights}
3640 catch {unset fhighlights}
3641 catch {unset nhighlights}
3642 catch {unset rhighlights}
3645 proc findcrossings {id} {
3646 global rowidlist parentlist numcommits displayorder
3648 set cross {}
3649 set ccross {}
3650 foreach {s e} [rowranges $id] {
3651 if {$e >= $numcommits} {
3652 set e [expr {$numcommits - 1}]
3654 if {$e <= $s} continue
3655 for {set row $e} {[incr row -1] >= $s} {} {
3656 set x [lsearch -exact [lindex $rowidlist $row] $id]
3657 if {$x < 0} break
3658 set olds [lindex $parentlist $row]
3659 set kid [lindex $displayorder $row]
3660 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3661 if {$kidx < 0} continue
3662 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3663 foreach p $olds {
3664 set px [lsearch -exact $nextrow $p]
3665 if {$px < 0} continue
3666 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3667 if {[lsearch -exact $ccross $p] >= 0} continue
3668 if {$x == $px + ($kidx < $px? -1: 1)} {
3669 lappend ccross $p
3670 } elseif {[lsearch -exact $cross $p] < 0} {
3671 lappend cross $p
3677 return [concat $ccross {{}} $cross]
3680 proc assigncolor {id} {
3681 global colormap colors nextcolor
3682 global commitrow parentlist children children curview
3684 if {[info exists colormap($id)]} return
3685 set ncolors [llength $colors]
3686 if {[info exists children($curview,$id)]} {
3687 set kids $children($curview,$id)
3688 } else {
3689 set kids {}
3691 if {[llength $kids] == 1} {
3692 set child [lindex $kids 0]
3693 if {[info exists colormap($child)]
3694 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3695 set colormap($id) $colormap($child)
3696 return
3699 set badcolors {}
3700 set origbad {}
3701 foreach x [findcrossings $id] {
3702 if {$x eq {}} {
3703 # delimiter between corner crossings and other crossings
3704 if {[llength $badcolors] >= $ncolors - 1} break
3705 set origbad $badcolors
3707 if {[info exists colormap($x)]
3708 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3709 lappend badcolors $colormap($x)
3712 if {[llength $badcolors] >= $ncolors} {
3713 set badcolors $origbad
3715 set origbad $badcolors
3716 if {[llength $badcolors] < $ncolors - 1} {
3717 foreach child $kids {
3718 if {[info exists colormap($child)]
3719 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3720 lappend badcolors $colormap($child)
3722 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3723 if {[info exists colormap($p)]
3724 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3725 lappend badcolors $colormap($p)
3729 if {[llength $badcolors] >= $ncolors} {
3730 set badcolors $origbad
3733 for {set i 0} {$i <= $ncolors} {incr i} {
3734 set c [lindex $colors $nextcolor]
3735 if {[incr nextcolor] >= $ncolors} {
3736 set nextcolor 0
3738 if {[lsearch -exact $badcolors $c]} break
3740 set colormap($id) $c
3743 proc bindline {t id} {
3744 global canv
3746 $canv bind $t <Enter> "lineenter %x %y $id"
3747 $canv bind $t <Motion> "linemotion %x %y $id"
3748 $canv bind $t <Leave> "lineleave $id"
3749 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3752 proc drawtags {id x xt y1} {
3753 global idtags idheads idotherrefs mainhead
3754 global linespc lthickness
3755 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3757 set marks {}
3758 set ntags 0
3759 set nheads 0
3760 if {[info exists idtags($id)]} {
3761 set marks $idtags($id)
3762 set ntags [llength $marks]
3764 if {[info exists idheads($id)]} {
3765 set marks [concat $marks $idheads($id)]
3766 set nheads [llength $idheads($id)]
3768 if {[info exists idotherrefs($id)]} {
3769 set marks [concat $marks $idotherrefs($id)]
3771 if {$marks eq {}} {
3772 return $xt
3775 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3776 set yt [expr {$y1 - 0.5 * $linespc}]
3777 set yb [expr {$yt + $linespc - 1}]
3778 set xvals {}
3779 set wvals {}
3780 set i -1
3781 foreach tag $marks {
3782 incr i
3783 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3784 set wid [font measure [concat $mainfont bold] $tag]
3785 } else {
3786 set wid [font measure $mainfont $tag]
3788 lappend xvals $xt
3789 lappend wvals $wid
3790 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3792 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3793 -width $lthickness -fill black -tags tag.$id]
3794 $canv lower $t
3795 foreach tag $marks x $xvals wid $wvals {
3796 set xl [expr {$x + $delta}]
3797 set xr [expr {$x + $delta + $wid + $lthickness}]
3798 set font $mainfont
3799 if {[incr ntags -1] >= 0} {
3800 # draw a tag
3801 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3802 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3803 -width 1 -outline black -fill yellow -tags tag.$id]
3804 $canv bind $t <1> [list showtag $tag 1]
3805 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3806 } else {
3807 # draw a head or other ref
3808 if {[incr nheads -1] >= 0} {
3809 set col green
3810 if {$tag eq $mainhead} {
3811 lappend font bold
3813 } else {
3814 set col "#ddddff"
3816 set xl [expr {$xl - $delta/2}]
3817 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3818 -width 1 -outline black -fill $col -tags tag.$id
3819 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3820 set rwid [font measure $mainfont $remoteprefix]
3821 set xi [expr {$x + 1}]
3822 set yti [expr {$yt + 1}]
3823 set xri [expr {$x + $rwid}]
3824 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3825 -width 0 -fill "#ffddaa" -tags tag.$id
3828 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3829 -font $font -tags [list tag.$id text]]
3830 if {$ntags >= 0} {
3831 $canv bind $t <1> [list showtag $tag 1]
3832 } elseif {$nheads >= 0} {
3833 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3836 return $xt
3839 proc xcoord {i level ln} {
3840 global canvx0 xspc1 xspc2
3842 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3843 if {$i > 0 && $i == $level} {
3844 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3845 } elseif {$i > $level} {
3846 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3848 return $x
3851 proc show_status {msg} {
3852 global canv mainfont fgcolor
3854 clear_display
3855 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3856 -tags text -fill $fgcolor
3859 # Insert a new commit as the child of the commit on row $row.
3860 # The new commit will be displayed on row $row and the commits
3861 # on that row and below will move down one row.
3862 proc insertrow {row newcmit} {
3863 global displayorder parentlist commitlisted children
3864 global commitrow curview rowidlist numcommits
3865 global rowrangelist rowlaidout rowoptim numcommits
3866 global selectedline rowchk commitidx
3868 if {$row >= $numcommits} {
3869 puts "oops, inserting new row $row but only have $numcommits rows"
3870 return
3872 set p [lindex $displayorder $row]
3873 set displayorder [linsert $displayorder $row $newcmit]
3874 set parentlist [linsert $parentlist $row $p]
3875 set kids $children($curview,$p)
3876 lappend kids $newcmit
3877 set children($curview,$p) $kids
3878 set children($curview,$newcmit) {}
3879 set commitlisted [linsert $commitlisted $row 1]
3880 set l [llength $displayorder]
3881 for {set r $row} {$r < $l} {incr r} {
3882 set id [lindex $displayorder $r]
3883 set commitrow($curview,$id) $r
3885 incr commitidx($curview)
3887 set idlist [lindex $rowidlist $row]
3888 if {[llength $kids] == 1} {
3889 set col [lsearch -exact $idlist $p]
3890 lset idlist $col $newcmit
3891 } else {
3892 set col [llength $idlist]
3893 lappend idlist $newcmit
3895 set rowidlist [linsert $rowidlist $row $idlist]
3897 set rowrangelist [linsert $rowrangelist $row {}]
3898 if {[llength $kids] > 1} {
3899 set rp1 [expr {$row + 1}]
3900 set ranges [lindex $rowrangelist $rp1]
3901 if {$ranges eq {}} {
3902 set ranges [list $newcmit $p]
3903 } elseif {[lindex $ranges end-1] eq $p} {
3904 lset ranges end-1 $newcmit
3906 lset rowrangelist $rp1 $ranges
3909 catch {unset rowchk}
3911 incr rowlaidout
3912 incr rowoptim
3913 incr numcommits
3915 if {[info exists selectedline] && $selectedline >= $row} {
3916 incr selectedline
3918 redisplay
3921 # Remove a commit that was inserted with insertrow on row $row.
3922 proc removerow {row} {
3923 global displayorder parentlist commitlisted children
3924 global commitrow curview rowidlist numcommits
3925 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3926 global linesegends selectedline rowchk commitidx
3928 if {$row >= $numcommits} {
3929 puts "oops, removing row $row but only have $numcommits rows"
3930 return
3932 set rp1 [expr {$row + 1}]
3933 set id [lindex $displayorder $row]
3934 set p [lindex $parentlist $row]
3935 set displayorder [lreplace $displayorder $row $row]
3936 set parentlist [lreplace $parentlist $row $row]
3937 set commitlisted [lreplace $commitlisted $row $row]
3938 set kids $children($curview,$p)
3939 set i [lsearch -exact $kids $id]
3940 if {$i >= 0} {
3941 set kids [lreplace $kids $i $i]
3942 set children($curview,$p) $kids
3944 set l [llength $displayorder]
3945 for {set r $row} {$r < $l} {incr r} {
3946 set id [lindex $displayorder $r]
3947 set commitrow($curview,$id) $r
3949 incr commitidx($curview) -1
3951 set rowidlist [lreplace $rowidlist $row $row]
3953 set rowrangelist [lreplace $rowrangelist $row $row]
3954 if {[llength $kids] > 0} {
3955 set ranges [lindex $rowrangelist $row]
3956 if {[lindex $ranges end-1] eq $id} {
3957 set ranges [lreplace $ranges end-1 end]
3958 lset rowrangelist $row $ranges
3962 catch {unset rowchk}
3964 incr rowlaidout -1
3965 incr rowoptim -1
3966 incr numcommits -1
3968 if {[info exists selectedline] && $selectedline > $row} {
3969 incr selectedline -1
3971 redisplay
3974 # Don't change the text pane cursor if it is currently the hand cursor,
3975 # showing that we are over a sha1 ID link.
3976 proc settextcursor {c} {
3977 global ctext curtextcursor
3979 if {[$ctext cget -cursor] == $curtextcursor} {
3980 $ctext config -cursor $c
3982 set curtextcursor $c
3985 proc nowbusy {what} {
3986 global isbusy
3988 if {[array names isbusy] eq {}} {
3989 . config -cursor watch
3990 settextcursor watch
3992 set isbusy($what) 1
3995 proc notbusy {what} {
3996 global isbusy maincursor textcursor
3998 catch {unset isbusy($what)}
3999 if {[array names isbusy] eq {}} {
4000 . config -cursor $maincursor
4001 settextcursor $textcursor
4005 proc findmatches {f} {
4006 global findtype findstring
4007 if {$findtype == "Regexp"} {
4008 set matches [regexp -indices -all -inline $findstring $f]
4009 } else {
4010 set fs $findstring
4011 if {$findtype == "IgnCase"} {
4012 set f [string tolower $f]
4013 set fs [string tolower $fs]
4015 set matches {}
4016 set i 0
4017 set l [string length $fs]
4018 while {[set j [string first $fs $f $i]] >= 0} {
4019 lappend matches [list $j [expr {$j+$l-1}]]
4020 set i [expr {$j + $l}]
4023 return $matches
4026 proc dofind {{rev 0}} {
4027 global findstring findstartline findcurline selectedline numcommits
4029 unmarkmatches
4030 cancel_next_highlight
4031 focus .
4032 if {$findstring eq {} || $numcommits == 0} return
4033 if {![info exists selectedline]} {
4034 set findstartline [lindex [visiblerows] $rev]
4035 } else {
4036 set findstartline $selectedline
4038 set findcurline $findstartline
4039 nowbusy finding
4040 if {!$rev} {
4041 run findmore
4042 } else {
4043 if {$findcurline == 0} {
4044 set findcurline $numcommits
4046 incr findcurline -1
4047 run findmorerev
4051 proc findnext {restart} {
4052 global findcurline
4053 if {![info exists findcurline]} {
4054 if {$restart} {
4055 dofind
4056 } else {
4057 bell
4059 } else {
4060 run findmore
4061 nowbusy finding
4065 proc findprev {} {
4066 global findcurline
4067 if {![info exists findcurline]} {
4068 dofind 1
4069 } else {
4070 run findmorerev
4071 nowbusy finding
4075 proc findmore {} {
4076 global commitdata commitinfo numcommits findstring findpattern findloc
4077 global findstartline findcurline displayorder
4079 set fldtypes {Headline Author Date Committer CDate Comments}
4080 set l [expr {$findcurline + 1}]
4081 if {$l >= $numcommits} {
4082 set l 0
4084 if {$l <= $findstartline} {
4085 set lim [expr {$findstartline + 1}]
4086 } else {
4087 set lim $numcommits
4089 if {$lim - $l > 500} {
4090 set lim [expr {$l + 500}]
4092 set last 0
4093 for {} {$l < $lim} {incr l} {
4094 set id [lindex $displayorder $l]
4095 # shouldn't happen unless git log doesn't give all the commits...
4096 if {![info exists commitdata($id)]} continue
4097 if {![doesmatch $commitdata($id)]} continue
4098 if {![info exists commitinfo($id)]} {
4099 getcommit $id
4101 set info $commitinfo($id)
4102 foreach f $info ty $fldtypes {
4103 if {($findloc eq "All fields" || $findloc eq $ty) &&
4104 [doesmatch $f]} {
4105 findselectline $l
4106 notbusy finding
4107 return 0
4111 if {$l == $findstartline + 1} {
4112 bell
4113 unset findcurline
4114 notbusy finding
4115 return 0
4117 set findcurline [expr {$l - 1}]
4118 return 1
4121 proc findmorerev {} {
4122 global commitdata commitinfo numcommits findstring findpattern findloc
4123 global findstartline findcurline displayorder
4125 set fldtypes {Headline Author Date Committer CDate Comments}
4126 set l $findcurline
4127 if {$l == 0} {
4128 set l $numcommits
4130 incr l -1
4131 if {$l >= $findstartline} {
4132 set lim [expr {$findstartline - 1}]
4133 } else {
4134 set lim -1
4136 if {$l - $lim > 500} {
4137 set lim [expr {$l - 500}]
4139 set last 0
4140 for {} {$l > $lim} {incr l -1} {
4141 set id [lindex $displayorder $l]
4142 if {![doesmatch $commitdata($id)]} continue
4143 if {![info exists commitinfo($id)]} {
4144 getcommit $id
4146 set info $commitinfo($id)
4147 foreach f $info ty $fldtypes {
4148 if {($findloc eq "All fields" || $findloc eq $ty) &&
4149 [doesmatch $f]} {
4150 findselectline $l
4151 notbusy finding
4152 return 0
4156 if {$l == -1} {
4157 bell
4158 unset findcurline
4159 notbusy finding
4160 return 0
4162 set findcurline [expr {$l + 1}]
4163 return 1
4166 proc findselectline {l} {
4167 global findloc commentend ctext findcurline markingmatches
4169 set markingmatches 1
4170 set findcurline $l
4171 selectline $l 1
4172 if {$findloc == "All fields" || $findloc == "Comments"} {
4173 # highlight the matches in the comments
4174 set f [$ctext get 1.0 $commentend]
4175 set matches [findmatches $f]
4176 foreach match $matches {
4177 set start [lindex $match 0]
4178 set end [expr {[lindex $match 1] + 1}]
4179 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4182 drawvisible
4185 # mark the bits of a headline or author that match a find string
4186 proc markmatches {canv l str tag matches font row} {
4187 global selectedline
4189 set bbox [$canv bbox $tag]
4190 set x0 [lindex $bbox 0]
4191 set y0 [lindex $bbox 1]
4192 set y1 [lindex $bbox 3]
4193 foreach match $matches {
4194 set start [lindex $match 0]
4195 set end [lindex $match 1]
4196 if {$start > $end} continue
4197 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4198 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4199 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4200 [expr {$x0+$xlen+2}] $y1 \
4201 -outline {} -tags [list match$l matches] -fill yellow]
4202 $canv lower $t
4203 if {[info exists selectedline] && $row == $selectedline} {
4204 $canv raise $t secsel
4209 proc unmarkmatches {} {
4210 global findids markingmatches findcurline
4212 allcanvs delete matches
4213 catch {unset findids}
4214 set markingmatches 0
4215 catch {unset findcurline}
4218 proc selcanvline {w x y} {
4219 global canv canvy0 ctext linespc
4220 global rowtextx
4221 set ymax [lindex [$canv cget -scrollregion] 3]
4222 if {$ymax == {}} return
4223 set yfrac [lindex [$canv yview] 0]
4224 set y [expr {$y + $yfrac * $ymax}]
4225 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4226 if {$l < 0} {
4227 set l 0
4229 if {$w eq $canv} {
4230 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4232 unmarkmatches
4233 selectline $l 1
4236 proc commit_descriptor {p} {
4237 global commitinfo
4238 if {![info exists commitinfo($p)]} {
4239 getcommit $p
4241 set l "..."
4242 if {[llength $commitinfo($p)] > 1} {
4243 set l [lindex $commitinfo($p) 0]
4245 return "$p ($l)\n"
4248 # append some text to the ctext widget, and make any SHA1 ID
4249 # that we know about be a clickable link.
4250 proc appendwithlinks {text tags} {
4251 global ctext commitrow linknum curview
4253 set start [$ctext index "end - 1c"]
4254 $ctext insert end $text $tags
4255 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4256 foreach l $links {
4257 set s [lindex $l 0]
4258 set e [lindex $l 1]
4259 set linkid [string range $text $s $e]
4260 if {![info exists commitrow($curview,$linkid)]} continue
4261 incr e
4262 $ctext tag add link "$start + $s c" "$start + $e c"
4263 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4264 $ctext tag bind link$linknum <1> \
4265 [list selectline $commitrow($curview,$linkid) 1]
4266 incr linknum
4268 $ctext tag conf link -foreground blue -underline 1
4269 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4270 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4273 proc viewnextline {dir} {
4274 global canv linespc
4276 $canv delete hover
4277 set ymax [lindex [$canv cget -scrollregion] 3]
4278 set wnow [$canv yview]
4279 set wtop [expr {[lindex $wnow 0] * $ymax}]
4280 set newtop [expr {$wtop + $dir * $linespc}]
4281 if {$newtop < 0} {
4282 set newtop 0
4283 } elseif {$newtop > $ymax} {
4284 set newtop $ymax
4286 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4289 # add a list of tag or branch names at position pos
4290 # returns the number of names inserted
4291 proc appendrefs {pos ids var} {
4292 global ctext commitrow linknum curview $var maxrefs
4294 if {[catch {$ctext index $pos}]} {
4295 return 0
4297 $ctext conf -state normal
4298 $ctext delete $pos "$pos lineend"
4299 set tags {}
4300 foreach id $ids {
4301 foreach tag [set $var\($id\)] {
4302 lappend tags [list $tag $id]
4305 if {[llength $tags] > $maxrefs} {
4306 $ctext insert $pos "many ([llength $tags])"
4307 } else {
4308 set tags [lsort -index 0 -decreasing $tags]
4309 set sep {}
4310 foreach ti $tags {
4311 set id [lindex $ti 1]
4312 set lk link$linknum
4313 incr linknum
4314 $ctext tag delete $lk
4315 $ctext insert $pos $sep
4316 $ctext insert $pos [lindex $ti 0] $lk
4317 if {[info exists commitrow($curview,$id)]} {
4318 $ctext tag conf $lk -foreground blue
4319 $ctext tag bind $lk <1> \
4320 [list selectline $commitrow($curview,$id) 1]
4321 $ctext tag conf $lk -underline 1
4322 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4323 $ctext tag bind $lk <Leave> \
4324 { %W configure -cursor $curtextcursor }
4326 set sep ", "
4329 $ctext conf -state disabled
4330 return [llength $tags]
4333 # called when we have finished computing the nearby tags
4334 proc dispneartags {delay} {
4335 global selectedline currentid showneartags tagphase
4337 if {![info exists selectedline] || !$showneartags} return
4338 after cancel dispnexttag
4339 if {$delay} {
4340 after 200 dispnexttag
4341 set tagphase -1
4342 } else {
4343 after idle dispnexttag
4344 set tagphase 0
4348 proc dispnexttag {} {
4349 global selectedline currentid showneartags tagphase ctext
4351 if {![info exists selectedline] || !$showneartags} return
4352 switch -- $tagphase {
4354 set dtags [desctags $currentid]
4355 if {$dtags ne {}} {
4356 appendrefs precedes $dtags idtags
4360 set atags [anctags $currentid]
4361 if {$atags ne {}} {
4362 appendrefs follows $atags idtags
4366 set dheads [descheads $currentid]
4367 if {$dheads ne {}} {
4368 if {[appendrefs branch $dheads idheads] > 1
4369 && [$ctext get "branch -3c"] eq "h"} {
4370 # turn "Branch" into "Branches"
4371 $ctext conf -state normal
4372 $ctext insert "branch -2c" "es"
4373 $ctext conf -state disabled
4378 if {[incr tagphase] <= 2} {
4379 after idle dispnexttag
4383 proc selectline {l isnew} {
4384 global canv canv2 canv3 ctext commitinfo selectedline
4385 global displayorder linehtag linentag linedtag
4386 global canvy0 linespc parentlist children curview
4387 global currentid sha1entry
4388 global commentend idtags linknum
4389 global mergemax numcommits pending_select
4390 global cmitmode showneartags allcommits
4392 catch {unset pending_select}
4393 $canv delete hover
4394 normalline
4395 cancel_next_highlight
4396 if {$l < 0 || $l >= $numcommits} return
4397 set y [expr {$canvy0 + $l * $linespc}]
4398 set ymax [lindex [$canv cget -scrollregion] 3]
4399 set ytop [expr {$y - $linespc - 1}]
4400 set ybot [expr {$y + $linespc + 1}]
4401 set wnow [$canv yview]
4402 set wtop [expr {[lindex $wnow 0] * $ymax}]
4403 set wbot [expr {[lindex $wnow 1] * $ymax}]
4404 set wh [expr {$wbot - $wtop}]
4405 set newtop $wtop
4406 if {$ytop < $wtop} {
4407 if {$ybot < $wtop} {
4408 set newtop [expr {$y - $wh / 2.0}]
4409 } else {
4410 set newtop $ytop
4411 if {$newtop > $wtop - $linespc} {
4412 set newtop [expr {$wtop - $linespc}]
4415 } elseif {$ybot > $wbot} {
4416 if {$ytop > $wbot} {
4417 set newtop [expr {$y - $wh / 2.0}]
4418 } else {
4419 set newtop [expr {$ybot - $wh}]
4420 if {$newtop < $wtop + $linespc} {
4421 set newtop [expr {$wtop + $linespc}]
4425 if {$newtop != $wtop} {
4426 if {$newtop < 0} {
4427 set newtop 0
4429 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4430 drawvisible
4433 if {![info exists linehtag($l)]} return
4434 $canv delete secsel
4435 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4436 -tags secsel -fill [$canv cget -selectbackground]]
4437 $canv lower $t
4438 $canv2 delete secsel
4439 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4440 -tags secsel -fill [$canv2 cget -selectbackground]]
4441 $canv2 lower $t
4442 $canv3 delete secsel
4443 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4444 -tags secsel -fill [$canv3 cget -selectbackground]]
4445 $canv3 lower $t
4447 if {$isnew} {
4448 addtohistory [list selectline $l 0]
4451 set selectedline $l
4453 set id [lindex $displayorder $l]
4454 set currentid $id
4455 $sha1entry delete 0 end
4456 $sha1entry insert 0 $id
4457 $sha1entry selection from 0
4458 $sha1entry selection to end
4459 rhighlight_sel $id
4461 $ctext conf -state normal
4462 clear_ctext
4463 set linknum 0
4464 set info $commitinfo($id)
4465 set date [formatdate [lindex $info 2]]
4466 $ctext insert end "Author: [lindex $info 1] $date\n"
4467 set date [formatdate [lindex $info 4]]
4468 $ctext insert end "Committer: [lindex $info 3] $date\n"
4469 if {[info exists idtags($id)]} {
4470 $ctext insert end "Tags:"
4471 foreach tag $idtags($id) {
4472 $ctext insert end " $tag"
4474 $ctext insert end "\n"
4477 set headers {}
4478 set olds [lindex $parentlist $l]
4479 if {[llength $olds] > 1} {
4480 set np 0
4481 foreach p $olds {
4482 if {$np >= $mergemax} {
4483 set tag mmax
4484 } else {
4485 set tag m$np
4487 $ctext insert end "Parent: " $tag
4488 appendwithlinks [commit_descriptor $p] {}
4489 incr np
4491 } else {
4492 foreach p $olds {
4493 append headers "Parent: [commit_descriptor $p]"
4497 foreach c $children($curview,$id) {
4498 append headers "Child: [commit_descriptor $c]"
4501 # make anything that looks like a SHA1 ID be a clickable link
4502 appendwithlinks $headers {}
4503 if {$showneartags} {
4504 if {![info exists allcommits]} {
4505 getallcommits
4507 $ctext insert end "Branch: "
4508 $ctext mark set branch "end -1c"
4509 $ctext mark gravity branch left
4510 $ctext insert end "\nFollows: "
4511 $ctext mark set follows "end -1c"
4512 $ctext mark gravity follows left
4513 $ctext insert end "\nPrecedes: "
4514 $ctext mark set precedes "end -1c"
4515 $ctext mark gravity precedes left
4516 $ctext insert end "\n"
4517 dispneartags 1
4519 $ctext insert end "\n"
4520 set comment [lindex $info 5]
4521 if {[string first "\r" $comment] >= 0} {
4522 set comment [string map {"\r" "\n "} $comment]
4524 appendwithlinks $comment {comment}
4526 $ctext tag remove found 1.0 end
4527 $ctext conf -state disabled
4528 set commentend [$ctext index "end - 1c"]
4530 init_flist "Comments"
4531 if {$cmitmode eq "tree"} {
4532 gettree $id
4533 } elseif {[llength $olds] <= 1} {
4534 startdiff $id
4535 } else {
4536 mergediff $id $l
4540 proc selfirstline {} {
4541 unmarkmatches
4542 selectline 0 1
4545 proc sellastline {} {
4546 global numcommits
4547 unmarkmatches
4548 set l [expr {$numcommits - 1}]
4549 selectline $l 1
4552 proc selnextline {dir} {
4553 global selectedline
4554 if {![info exists selectedline]} return
4555 set l [expr {$selectedline + $dir}]
4556 unmarkmatches
4557 selectline $l 1
4560 proc selnextpage {dir} {
4561 global canv linespc selectedline numcommits
4563 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4564 if {$lpp < 1} {
4565 set lpp 1
4567 allcanvs yview scroll [expr {$dir * $lpp}] units
4568 drawvisible
4569 if {![info exists selectedline]} return
4570 set l [expr {$selectedline + $dir * $lpp}]
4571 if {$l < 0} {
4572 set l 0
4573 } elseif {$l >= $numcommits} {
4574 set l [expr $numcommits - 1]
4576 unmarkmatches
4577 selectline $l 1
4580 proc unselectline {} {
4581 global selectedline currentid
4583 catch {unset selectedline}
4584 catch {unset currentid}
4585 allcanvs delete secsel
4586 rhighlight_none
4587 cancel_next_highlight
4590 proc reselectline {} {
4591 global selectedline
4593 if {[info exists selectedline]} {
4594 selectline $selectedline 0
4598 proc addtohistory {cmd} {
4599 global history historyindex curview
4601 set elt [list $curview $cmd]
4602 if {$historyindex > 0
4603 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4604 return
4607 if {$historyindex < [llength $history]} {
4608 set history [lreplace $history $historyindex end $elt]
4609 } else {
4610 lappend history $elt
4612 incr historyindex
4613 if {$historyindex > 1} {
4614 .tf.bar.leftbut conf -state normal
4615 } else {
4616 .tf.bar.leftbut conf -state disabled
4618 .tf.bar.rightbut conf -state disabled
4621 proc godo {elt} {
4622 global curview
4624 set view [lindex $elt 0]
4625 set cmd [lindex $elt 1]
4626 if {$curview != $view} {
4627 showview $view
4629 eval $cmd
4632 proc goback {} {
4633 global history historyindex
4635 if {$historyindex > 1} {
4636 incr historyindex -1
4637 godo [lindex $history [expr {$historyindex - 1}]]
4638 .tf.bar.rightbut conf -state normal
4640 if {$historyindex <= 1} {
4641 .tf.bar.leftbut conf -state disabled
4645 proc goforw {} {
4646 global history historyindex
4648 if {$historyindex < [llength $history]} {
4649 set cmd [lindex $history $historyindex]
4650 incr historyindex
4651 godo $cmd
4652 .tf.bar.leftbut conf -state normal
4654 if {$historyindex >= [llength $history]} {
4655 .tf.bar.rightbut conf -state disabled
4659 proc gettree {id} {
4660 global treefilelist treeidlist diffids diffmergeid treepending
4661 global nullid nullid2
4663 set diffids $id
4664 catch {unset diffmergeid}
4665 if {![info exists treefilelist($id)]} {
4666 if {![info exists treepending]} {
4667 if {$id eq $nullid} {
4668 set cmd [list | git ls-files]
4669 } elseif {$id eq $nullid2} {
4670 set cmd [list | git ls-files --stage -t]
4671 } else {
4672 set cmd [list | git ls-tree -r $id]
4674 if {[catch {set gtf [open $cmd r]}]} {
4675 return
4677 set treepending $id
4678 set treefilelist($id) {}
4679 set treeidlist($id) {}
4680 fconfigure $gtf -blocking 0
4681 filerun $gtf [list gettreeline $gtf $id]
4683 } else {
4684 setfilelist $id
4688 proc gettreeline {gtf id} {
4689 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4691 set nl 0
4692 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4693 if {$diffids eq $nullid} {
4694 set fname $line
4695 } else {
4696 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4697 set i [string first "\t" $line]
4698 if {$i < 0} continue
4699 set sha1 [lindex $line 2]
4700 set fname [string range $line [expr {$i+1}] end]
4701 if {[string index $fname 0] eq "\""} {
4702 set fname [lindex $fname 0]
4704 lappend treeidlist($id) $sha1
4706 lappend treefilelist($id) $fname
4708 if {![eof $gtf]} {
4709 return [expr {$nl >= 1000? 2: 1}]
4711 close $gtf
4712 unset treepending
4713 if {$cmitmode ne "tree"} {
4714 if {![info exists diffmergeid]} {
4715 gettreediffs $diffids
4717 } elseif {$id ne $diffids} {
4718 gettree $diffids
4719 } else {
4720 setfilelist $id
4722 return 0
4725 proc showfile {f} {
4726 global treefilelist treeidlist diffids nullid nullid2
4727 global ctext commentend
4729 set i [lsearch -exact $treefilelist($diffids) $f]
4730 if {$i < 0} {
4731 puts "oops, $f not in list for id $diffids"
4732 return
4734 if {$diffids eq $nullid} {
4735 if {[catch {set bf [open $f r]} err]} {
4736 puts "oops, can't read $f: $err"
4737 return
4739 } else {
4740 set blob [lindex $treeidlist($diffids) $i]
4741 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4742 puts "oops, error reading blob $blob: $err"
4743 return
4746 fconfigure $bf -blocking 0
4747 filerun $bf [list getblobline $bf $diffids]
4748 $ctext config -state normal
4749 clear_ctext $commentend
4750 $ctext insert end "\n"
4751 $ctext insert end "$f\n" filesep
4752 $ctext config -state disabled
4753 $ctext yview $commentend
4756 proc getblobline {bf id} {
4757 global diffids cmitmode ctext
4759 if {$id ne $diffids || $cmitmode ne "tree"} {
4760 catch {close $bf}
4761 return 0
4763 $ctext config -state normal
4764 set nl 0
4765 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4766 $ctext insert end "$line\n"
4768 if {[eof $bf]} {
4769 # delete last newline
4770 $ctext delete "end - 2c" "end - 1c"
4771 close $bf
4772 return 0
4774 $ctext config -state disabled
4775 return [expr {$nl >= 1000? 2: 1}]
4778 proc mergediff {id l} {
4779 global diffmergeid diffopts mdifffd
4780 global diffids
4781 global parentlist
4783 set diffmergeid $id
4784 set diffids $id
4785 # this doesn't seem to actually affect anything...
4786 set env(GIT_DIFF_OPTS) $diffopts
4787 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4788 if {[catch {set mdf [open $cmd r]} err]} {
4789 error_popup "Error getting merge diffs: $err"
4790 return
4792 fconfigure $mdf -blocking 0
4793 set mdifffd($id) $mdf
4794 set np [llength [lindex $parentlist $l]]
4795 filerun $mdf [list getmergediffline $mdf $id $np]
4798 proc getmergediffline {mdf id np} {
4799 global diffmergeid ctext cflist mergemax
4800 global difffilestart mdifffd
4802 $ctext conf -state normal
4803 set nr 0
4804 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4805 if {![info exists diffmergeid] || $id != $diffmergeid
4806 || $mdf != $mdifffd($id)} {
4807 close $mdf
4808 return 0
4810 if {[regexp {^diff --cc (.*)} $line match fname]} {
4811 # start of a new file
4812 $ctext insert end "\n"
4813 set here [$ctext index "end - 1c"]
4814 lappend difffilestart $here
4815 add_flist [list $fname]
4816 set l [expr {(78 - [string length $fname]) / 2}]
4817 set pad [string range "----------------------------------------" 1 $l]
4818 $ctext insert end "$pad $fname $pad\n" filesep
4819 } elseif {[regexp {^@@} $line]} {
4820 $ctext insert end "$line\n" hunksep
4821 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4822 # do nothing
4823 } else {
4824 # parse the prefix - one ' ', '-' or '+' for each parent
4825 set spaces {}
4826 set minuses {}
4827 set pluses {}
4828 set isbad 0
4829 for {set j 0} {$j < $np} {incr j} {
4830 set c [string range $line $j $j]
4831 if {$c == " "} {
4832 lappend spaces $j
4833 } elseif {$c == "-"} {
4834 lappend minuses $j
4835 } elseif {$c == "+"} {
4836 lappend pluses $j
4837 } else {
4838 set isbad 1
4839 break
4842 set tags {}
4843 set num {}
4844 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4845 # line doesn't appear in result, parents in $minuses have the line
4846 set num [lindex $minuses 0]
4847 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4848 # line appears in result, parents in $pluses don't have the line
4849 lappend tags mresult
4850 set num [lindex $spaces 0]
4852 if {$num ne {}} {
4853 if {$num >= $mergemax} {
4854 set num "max"
4856 lappend tags m$num
4858 $ctext insert end "$line\n" $tags
4861 $ctext conf -state disabled
4862 if {[eof $mdf]} {
4863 close $mdf
4864 return 0
4866 return [expr {$nr >= 1000? 2: 1}]
4869 proc startdiff {ids} {
4870 global treediffs diffids treepending diffmergeid nullid nullid2
4872 set diffids $ids
4873 catch {unset diffmergeid}
4874 if {![info exists treediffs($ids)] ||
4875 [lsearch -exact $ids $nullid] >= 0 ||
4876 [lsearch -exact $ids $nullid2] >= 0} {
4877 if {![info exists treepending]} {
4878 gettreediffs $ids
4880 } else {
4881 addtocflist $ids
4885 proc addtocflist {ids} {
4886 global treediffs cflist
4887 add_flist $treediffs($ids)
4888 getblobdiffs $ids
4891 proc diffcmd {ids flags} {
4892 global nullid nullid2
4894 set i [lsearch -exact $ids $nullid]
4895 set j [lsearch -exact $ids $nullid2]
4896 if {$i >= 0} {
4897 if {[llength $ids] > 1 && $j < 0} {
4898 # comparing working directory with some specific revision
4899 set cmd [concat | git diff-index $flags]
4900 if {$i == 0} {
4901 lappend cmd -R [lindex $ids 1]
4902 } else {
4903 lappend cmd [lindex $ids 0]
4905 } else {
4906 # comparing working directory with index
4907 set cmd [concat | git diff-files $flags]
4908 if {$j == 1} {
4909 lappend cmd -R
4912 } elseif {$j >= 0} {
4913 set cmd [concat | git diff-index --cached $flags]
4914 if {[llength $ids] > 1} {
4915 # comparing index with specific revision
4916 if {$i == 0} {
4917 lappend cmd -R [lindex $ids 1]
4918 } else {
4919 lappend cmd [lindex $ids 0]
4921 } else {
4922 # comparing index with HEAD
4923 lappend cmd HEAD
4925 } else {
4926 set cmd [concat | git diff-tree -r $flags $ids]
4928 return $cmd
4931 proc gettreediffs {ids} {
4932 global treediff treepending
4934 set treepending $ids
4935 set treediff {}
4936 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4937 fconfigure $gdtf -blocking 0
4938 filerun $gdtf [list gettreediffline $gdtf $ids]
4941 proc gettreediffline {gdtf ids} {
4942 global treediff treediffs treepending diffids diffmergeid
4943 global cmitmode
4945 set nr 0
4946 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4947 set i [string first "\t" $line]
4948 if {$i >= 0} {
4949 set file [string range $line [expr {$i+1}] end]
4950 if {[string index $file 0] eq "\""} {
4951 set file [lindex $file 0]
4953 lappend treediff $file
4956 if {![eof $gdtf]} {
4957 return [expr {$nr >= 1000? 2: 1}]
4959 close $gdtf
4960 set treediffs($ids) $treediff
4961 unset treepending
4962 if {$cmitmode eq "tree"} {
4963 gettree $diffids
4964 } elseif {$ids != $diffids} {
4965 if {![info exists diffmergeid]} {
4966 gettreediffs $diffids
4968 } else {
4969 addtocflist $ids
4971 return 0
4974 proc getblobdiffs {ids} {
4975 global diffopts blobdifffd diffids env
4976 global diffinhdr treediffs
4978 set env(GIT_DIFF_OPTS) $diffopts
4979 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4980 puts "error getting diffs: $err"
4981 return
4983 set diffinhdr 0
4984 fconfigure $bdf -blocking 0
4985 set blobdifffd($ids) $bdf
4986 filerun $bdf [list getblobdiffline $bdf $diffids]
4989 proc setinlist {var i val} {
4990 global $var
4992 while {[llength [set $var]] < $i} {
4993 lappend $var {}
4995 if {[llength [set $var]] == $i} {
4996 lappend $var $val
4997 } else {
4998 lset $var $i $val
5002 proc makediffhdr {fname ids} {
5003 global ctext curdiffstart treediffs
5005 set i [lsearch -exact $treediffs($ids) $fname]
5006 if {$i >= 0} {
5007 setinlist difffilestart $i $curdiffstart
5009 set l [expr {(78 - [string length $fname]) / 2}]
5010 set pad [string range "----------------------------------------" 1 $l]
5011 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5014 proc getblobdiffline {bdf ids} {
5015 global diffids blobdifffd ctext curdiffstart
5016 global diffnexthead diffnextnote difffilestart
5017 global diffinhdr treediffs
5019 set nr 0
5020 $ctext conf -state normal
5021 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5022 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5023 close $bdf
5024 return 0
5026 if {![string compare -length 11 "diff --git " $line]} {
5027 # trim off "diff --git "
5028 set line [string range $line 11 end]
5029 set diffinhdr 1
5030 # start of a new file
5031 $ctext insert end "\n"
5032 set curdiffstart [$ctext index "end - 1c"]
5033 $ctext insert end "\n" filesep
5034 # If the name hasn't changed the length will be odd,
5035 # the middle char will be a space, and the two bits either
5036 # side will be a/name and b/name, or "a/name" and "b/name".
5037 # If the name has changed we'll get "rename from" and
5038 # "rename to" lines following this, and we'll use them
5039 # to get the filenames.
5040 # This complexity is necessary because spaces in the filename(s)
5041 # don't get escaped.
5042 set l [string length $line]
5043 set i [expr {$l / 2}]
5044 if {!(($l & 1) && [string index $line $i] eq " " &&
5045 [string range $line 2 [expr {$i - 1}]] eq \
5046 [string range $line [expr {$i + 3}] end])} {
5047 continue
5049 # unescape if quoted and chop off the a/ from the front
5050 if {[string index $line 0] eq "\""} {
5051 set fname [string range [lindex $line 0] 2 end]
5052 } else {
5053 set fname [string range $line 2 [expr {$i - 1}]]
5055 makediffhdr $fname $ids
5057 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5058 $line match f1l f1c f2l f2c rest]} {
5059 $ctext insert end "$line\n" hunksep
5060 set diffinhdr 0
5062 } elseif {$diffinhdr} {
5063 if {![string compare -length 12 "rename from " $line]} {
5064 set fname [string range $line 12 end]
5065 if {[string index $fname 0] eq "\""} {
5066 set fname [lindex $fname 0]
5068 set i [lsearch -exact $treediffs($ids) $fname]
5069 if {$i >= 0} {
5070 setinlist difffilestart $i $curdiffstart
5072 } elseif {![string compare -length 10 $line "rename to "]} {
5073 set fname [string range $line 10 end]
5074 if {[string index $fname 0] eq "\""} {
5075 set fname [lindex $fname 0]
5077 makediffhdr $fname $ids
5078 } elseif {[string compare -length 3 $line "---"] == 0} {
5079 # do nothing
5080 continue
5081 } elseif {[string compare -length 3 $line "+++"] == 0} {
5082 set diffinhdr 0
5083 continue
5085 $ctext insert end "$line\n" filesep
5087 } else {
5088 set x [string range $line 0 0]
5089 if {$x == "-" || $x == "+"} {
5090 set tag [expr {$x == "+"}]
5091 $ctext insert end "$line\n" d$tag
5092 } elseif {$x == " "} {
5093 $ctext insert end "$line\n"
5094 } else {
5095 # "\ No newline at end of file",
5096 # or something else we don't recognize
5097 $ctext insert end "$line\n" hunksep
5101 $ctext conf -state disabled
5102 if {[eof $bdf]} {
5103 close $bdf
5104 return 0
5106 return [expr {$nr >= 1000? 2: 1}]
5109 proc changediffdisp {} {
5110 global ctext diffelide
5112 $ctext tag conf d0 -elide [lindex $diffelide 0]
5113 $ctext tag conf d1 -elide [lindex $diffelide 1]
5116 proc prevfile {} {
5117 global difffilestart ctext
5118 set prev [lindex $difffilestart 0]
5119 set here [$ctext index @0,0]
5120 foreach loc $difffilestart {
5121 if {[$ctext compare $loc >= $here]} {
5122 $ctext yview $prev
5123 return
5125 set prev $loc
5127 $ctext yview $prev
5130 proc nextfile {} {
5131 global difffilestart ctext
5132 set here [$ctext index @0,0]
5133 foreach loc $difffilestart {
5134 if {[$ctext compare $loc > $here]} {
5135 $ctext yview $loc
5136 return
5141 proc clear_ctext {{first 1.0}} {
5142 global ctext smarktop smarkbot
5144 set l [lindex [split $first .] 0]
5145 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5146 set smarktop $l
5148 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5149 set smarkbot $l
5151 $ctext delete $first end
5154 proc incrsearch {name ix op} {
5155 global ctext searchstring searchdirn
5157 $ctext tag remove found 1.0 end
5158 if {[catch {$ctext index anchor}]} {
5159 # no anchor set, use start of selection, or of visible area
5160 set sel [$ctext tag ranges sel]
5161 if {$sel ne {}} {
5162 $ctext mark set anchor [lindex $sel 0]
5163 } elseif {$searchdirn eq "-forwards"} {
5164 $ctext mark set anchor @0,0
5165 } else {
5166 $ctext mark set anchor @0,[winfo height $ctext]
5169 if {$searchstring ne {}} {
5170 set here [$ctext search $searchdirn -- $searchstring anchor]
5171 if {$here ne {}} {
5172 $ctext see $here
5174 searchmarkvisible 1
5178 proc dosearch {} {
5179 global sstring ctext searchstring searchdirn
5181 focus $sstring
5182 $sstring icursor end
5183 set searchdirn -forwards
5184 if {$searchstring ne {}} {
5185 set sel [$ctext tag ranges sel]
5186 if {$sel ne {}} {
5187 set start "[lindex $sel 0] + 1c"
5188 } elseif {[catch {set start [$ctext index anchor]}]} {
5189 set start "@0,0"
5191 set match [$ctext search -count mlen -- $searchstring $start]
5192 $ctext tag remove sel 1.0 end
5193 if {$match eq {}} {
5194 bell
5195 return
5197 $ctext see $match
5198 set mend "$match + $mlen c"
5199 $ctext tag add sel $match $mend
5200 $ctext mark unset anchor
5204 proc dosearchback {} {
5205 global sstring ctext searchstring searchdirn
5207 focus $sstring
5208 $sstring icursor end
5209 set searchdirn -backwards
5210 if {$searchstring ne {}} {
5211 set sel [$ctext tag ranges sel]
5212 if {$sel ne {}} {
5213 set start [lindex $sel 0]
5214 } elseif {[catch {set start [$ctext index anchor]}]} {
5215 set start @0,[winfo height $ctext]
5217 set match [$ctext search -backwards -count ml -- $searchstring $start]
5218 $ctext tag remove sel 1.0 end
5219 if {$match eq {}} {
5220 bell
5221 return
5223 $ctext see $match
5224 set mend "$match + $ml c"
5225 $ctext tag add sel $match $mend
5226 $ctext mark unset anchor
5230 proc searchmark {first last} {
5231 global ctext searchstring
5233 set mend $first.0
5234 while {1} {
5235 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5236 if {$match eq {}} break
5237 set mend "$match + $mlen c"
5238 $ctext tag add found $match $mend
5242 proc searchmarkvisible {doall} {
5243 global ctext smarktop smarkbot
5245 set topline [lindex [split [$ctext index @0,0] .] 0]
5246 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5247 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5248 # no overlap with previous
5249 searchmark $topline $botline
5250 set smarktop $topline
5251 set smarkbot $botline
5252 } else {
5253 if {$topline < $smarktop} {
5254 searchmark $topline [expr {$smarktop-1}]
5255 set smarktop $topline
5257 if {$botline > $smarkbot} {
5258 searchmark [expr {$smarkbot+1}] $botline
5259 set smarkbot $botline
5264 proc scrolltext {f0 f1} {
5265 global searchstring
5267 .bleft.sb set $f0 $f1
5268 if {$searchstring ne {}} {
5269 searchmarkvisible 0
5273 proc setcoords {} {
5274 global linespc charspc canvx0 canvy0 mainfont
5275 global xspc1 xspc2 lthickness
5277 set linespc [font metrics $mainfont -linespace]
5278 set charspc [font measure $mainfont "m"]
5279 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5280 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5281 set lthickness [expr {int($linespc / 9) + 1}]
5282 set xspc1(0) $linespc
5283 set xspc2 $linespc
5286 proc redisplay {} {
5287 global canv
5288 global selectedline
5290 set ymax [lindex [$canv cget -scrollregion] 3]
5291 if {$ymax eq {} || $ymax == 0} return
5292 set span [$canv yview]
5293 clear_display
5294 setcanvscroll
5295 allcanvs yview moveto [lindex $span 0]
5296 drawvisible
5297 if {[info exists selectedline]} {
5298 selectline $selectedline 0
5299 allcanvs yview moveto [lindex $span 0]
5303 proc incrfont {inc} {
5304 global mainfont textfont ctext canv phase cflist
5305 global charspc tabstop
5306 global stopped entries
5307 unmarkmatches
5308 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5309 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5310 setcoords
5311 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5312 $cflist conf -font $textfont
5313 $ctext tag conf filesep -font [concat $textfont bold]
5314 foreach e $entries {
5315 $e conf -font $mainfont
5317 if {$phase eq "getcommits"} {
5318 $canv itemconf textitems -font $mainfont
5320 redisplay
5323 proc clearsha1 {} {
5324 global sha1entry sha1string
5325 if {[string length $sha1string] == 40} {
5326 $sha1entry delete 0 end
5330 proc sha1change {n1 n2 op} {
5331 global sha1string currentid sha1but
5332 if {$sha1string == {}
5333 || ([info exists currentid] && $sha1string == $currentid)} {
5334 set state disabled
5335 } else {
5336 set state normal
5338 if {[$sha1but cget -state] == $state} return
5339 if {$state == "normal"} {
5340 $sha1but conf -state normal -relief raised -text "Goto: "
5341 } else {
5342 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5346 proc gotocommit {} {
5347 global sha1string currentid commitrow tagids headids
5348 global displayorder numcommits curview
5350 if {$sha1string == {}
5351 || ([info exists currentid] && $sha1string == $currentid)} return
5352 if {[info exists tagids($sha1string)]} {
5353 set id $tagids($sha1string)
5354 } elseif {[info exists headids($sha1string)]} {
5355 set id $headids($sha1string)
5356 } else {
5357 set id [string tolower $sha1string]
5358 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5359 set matches {}
5360 foreach i $displayorder {
5361 if {[string match $id* $i]} {
5362 lappend matches $i
5365 if {$matches ne {}} {
5366 if {[llength $matches] > 1} {
5367 error_popup "Short SHA1 id $id is ambiguous"
5368 return
5370 set id [lindex $matches 0]
5374 if {[info exists commitrow($curview,$id)]} {
5375 selectline $commitrow($curview,$id) 1
5376 return
5378 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5379 set type "SHA1 id"
5380 } else {
5381 set type "Tag/Head"
5383 error_popup "$type $sha1string is not known"
5386 proc lineenter {x y id} {
5387 global hoverx hovery hoverid hovertimer
5388 global commitinfo canv
5390 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5391 set hoverx $x
5392 set hovery $y
5393 set hoverid $id
5394 if {[info exists hovertimer]} {
5395 after cancel $hovertimer
5397 set hovertimer [after 500 linehover]
5398 $canv delete hover
5401 proc linemotion {x y id} {
5402 global hoverx hovery hoverid hovertimer
5404 if {[info exists hoverid] && $id == $hoverid} {
5405 set hoverx $x
5406 set hovery $y
5407 if {[info exists hovertimer]} {
5408 after cancel $hovertimer
5410 set hovertimer [after 500 linehover]
5414 proc lineleave {id} {
5415 global hoverid hovertimer canv
5417 if {[info exists hoverid] && $id == $hoverid} {
5418 $canv delete hover
5419 if {[info exists hovertimer]} {
5420 after cancel $hovertimer
5421 unset hovertimer
5423 unset hoverid
5427 proc linehover {} {
5428 global hoverx hovery hoverid hovertimer
5429 global canv linespc lthickness
5430 global commitinfo mainfont
5432 set text [lindex $commitinfo($hoverid) 0]
5433 set ymax [lindex [$canv cget -scrollregion] 3]
5434 if {$ymax == {}} return
5435 set yfrac [lindex [$canv yview] 0]
5436 set x [expr {$hoverx + 2 * $linespc}]
5437 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5438 set x0 [expr {$x - 2 * $lthickness}]
5439 set y0 [expr {$y - 2 * $lthickness}]
5440 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5441 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5442 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5443 -fill \#ffff80 -outline black -width 1 -tags hover]
5444 $canv raise $t
5445 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5446 -font $mainfont]
5447 $canv raise $t
5450 proc clickisonarrow {id y} {
5451 global lthickness
5453 set ranges [rowranges $id]
5454 set thresh [expr {2 * $lthickness + 6}]
5455 set n [expr {[llength $ranges] - 1}]
5456 for {set i 1} {$i < $n} {incr i} {
5457 set row [lindex $ranges $i]
5458 if {abs([yc $row] - $y) < $thresh} {
5459 return $i
5462 return {}
5465 proc arrowjump {id n y} {
5466 global canv
5468 # 1 <-> 2, 3 <-> 4, etc...
5469 set n [expr {(($n - 1) ^ 1) + 1}]
5470 set row [lindex [rowranges $id] $n]
5471 set yt [yc $row]
5472 set ymax [lindex [$canv cget -scrollregion] 3]
5473 if {$ymax eq {} || $ymax <= 0} return
5474 set view [$canv yview]
5475 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5476 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5477 if {$yfrac < 0} {
5478 set yfrac 0
5480 allcanvs yview moveto $yfrac
5483 proc lineclick {x y id isnew} {
5484 global ctext commitinfo children canv thickerline curview
5486 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5487 unmarkmatches
5488 unselectline
5489 normalline
5490 $canv delete hover
5491 # draw this line thicker than normal
5492 set thickerline $id
5493 drawlines $id
5494 if {$isnew} {
5495 set ymax [lindex [$canv cget -scrollregion] 3]
5496 if {$ymax eq {}} return
5497 set yfrac [lindex [$canv yview] 0]
5498 set y [expr {$y + $yfrac * $ymax}]
5500 set dirn [clickisonarrow $id $y]
5501 if {$dirn ne {}} {
5502 arrowjump $id $dirn $y
5503 return
5506 if {$isnew} {
5507 addtohistory [list lineclick $x $y $id 0]
5509 # fill the details pane with info about this line
5510 $ctext conf -state normal
5511 clear_ctext
5512 $ctext tag conf link -foreground blue -underline 1
5513 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5514 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5515 $ctext insert end "Parent:\t"
5516 $ctext insert end $id [list link link0]
5517 $ctext tag bind link0 <1> [list selbyid $id]
5518 set info $commitinfo($id)
5519 $ctext insert end "\n\t[lindex $info 0]\n"
5520 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5521 set date [formatdate [lindex $info 2]]
5522 $ctext insert end "\tDate:\t$date\n"
5523 set kids $children($curview,$id)
5524 if {$kids ne {}} {
5525 $ctext insert end "\nChildren:"
5526 set i 0
5527 foreach child $kids {
5528 incr i
5529 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5530 set info $commitinfo($child)
5531 $ctext insert end "\n\t"
5532 $ctext insert end $child [list link link$i]
5533 $ctext tag bind link$i <1> [list selbyid $child]
5534 $ctext insert end "\n\t[lindex $info 0]"
5535 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5536 set date [formatdate [lindex $info 2]]
5537 $ctext insert end "\n\tDate:\t$date\n"
5540 $ctext conf -state disabled
5541 init_flist {}
5544 proc normalline {} {
5545 global thickerline
5546 if {[info exists thickerline]} {
5547 set id $thickerline
5548 unset thickerline
5549 drawlines $id
5553 proc selbyid {id} {
5554 global commitrow curview
5555 if {[info exists commitrow($curview,$id)]} {
5556 selectline $commitrow($curview,$id) 1
5560 proc mstime {} {
5561 global startmstime
5562 if {![info exists startmstime]} {
5563 set startmstime [clock clicks -milliseconds]
5565 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5568 proc rowmenu {x y id} {
5569 global rowctxmenu commitrow selectedline rowmenuid curview
5570 global nullid nullid2 fakerowmenu mainhead
5572 set rowmenuid $id
5573 if {![info exists selectedline]
5574 || $commitrow($curview,$id) eq $selectedline} {
5575 set state disabled
5576 } else {
5577 set state normal
5579 if {$id ne $nullid && $id ne $nullid2} {
5580 set menu $rowctxmenu
5581 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5582 } else {
5583 set menu $fakerowmenu
5585 $menu entryconfigure "Diff this*" -state $state
5586 $menu entryconfigure "Diff selected*" -state $state
5587 $menu entryconfigure "Make patch" -state $state
5588 tk_popup $menu $x $y
5591 proc diffvssel {dirn} {
5592 global rowmenuid selectedline displayorder
5594 if {![info exists selectedline]} return
5595 if {$dirn} {
5596 set oldid [lindex $displayorder $selectedline]
5597 set newid $rowmenuid
5598 } else {
5599 set oldid $rowmenuid
5600 set newid [lindex $displayorder $selectedline]
5602 addtohistory [list doseldiff $oldid $newid]
5603 doseldiff $oldid $newid
5606 proc doseldiff {oldid newid} {
5607 global ctext
5608 global commitinfo
5610 $ctext conf -state normal
5611 clear_ctext
5612 init_flist "Top"
5613 $ctext insert end "From "
5614 $ctext tag conf link -foreground blue -underline 1
5615 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5616 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5617 $ctext tag bind link0 <1> [list selbyid $oldid]
5618 $ctext insert end $oldid [list link link0]
5619 $ctext insert end "\n "
5620 $ctext insert end [lindex $commitinfo($oldid) 0]
5621 $ctext insert end "\n\nTo "
5622 $ctext tag bind link1 <1> [list selbyid $newid]
5623 $ctext insert end $newid [list link link1]
5624 $ctext insert end "\n "
5625 $ctext insert end [lindex $commitinfo($newid) 0]
5626 $ctext insert end "\n"
5627 $ctext conf -state disabled
5628 $ctext tag remove found 1.0 end
5629 startdiff [list $oldid $newid]
5632 proc mkpatch {} {
5633 global rowmenuid currentid commitinfo patchtop patchnum
5635 if {![info exists currentid]} return
5636 set oldid $currentid
5637 set oldhead [lindex $commitinfo($oldid) 0]
5638 set newid $rowmenuid
5639 set newhead [lindex $commitinfo($newid) 0]
5640 set top .patch
5641 set patchtop $top
5642 catch {destroy $top}
5643 toplevel $top
5644 label $top.title -text "Generate patch"
5645 grid $top.title - -pady 10
5646 label $top.from -text "From:"
5647 entry $top.fromsha1 -width 40 -relief flat
5648 $top.fromsha1 insert 0 $oldid
5649 $top.fromsha1 conf -state readonly
5650 grid $top.from $top.fromsha1 -sticky w
5651 entry $top.fromhead -width 60 -relief flat
5652 $top.fromhead insert 0 $oldhead
5653 $top.fromhead conf -state readonly
5654 grid x $top.fromhead -sticky w
5655 label $top.to -text "To:"
5656 entry $top.tosha1 -width 40 -relief flat
5657 $top.tosha1 insert 0 $newid
5658 $top.tosha1 conf -state readonly
5659 grid $top.to $top.tosha1 -sticky w
5660 entry $top.tohead -width 60 -relief flat
5661 $top.tohead insert 0 $newhead
5662 $top.tohead conf -state readonly
5663 grid x $top.tohead -sticky w
5664 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5665 grid $top.rev x -pady 10
5666 label $top.flab -text "Output file:"
5667 entry $top.fname -width 60
5668 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5669 incr patchnum
5670 grid $top.flab $top.fname -sticky w
5671 frame $top.buts
5672 button $top.buts.gen -text "Generate" -command mkpatchgo
5673 button $top.buts.can -text "Cancel" -command mkpatchcan
5674 grid $top.buts.gen $top.buts.can
5675 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5676 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5677 grid $top.buts - -pady 10 -sticky ew
5678 focus $top.fname
5681 proc mkpatchrev {} {
5682 global patchtop
5684 set oldid [$patchtop.fromsha1 get]
5685 set oldhead [$patchtop.fromhead get]
5686 set newid [$patchtop.tosha1 get]
5687 set newhead [$patchtop.tohead get]
5688 foreach e [list fromsha1 fromhead tosha1 tohead] \
5689 v [list $newid $newhead $oldid $oldhead] {
5690 $patchtop.$e conf -state normal
5691 $patchtop.$e delete 0 end
5692 $patchtop.$e insert 0 $v
5693 $patchtop.$e conf -state readonly
5697 proc mkpatchgo {} {
5698 global patchtop nullid nullid2
5700 set oldid [$patchtop.fromsha1 get]
5701 set newid [$patchtop.tosha1 get]
5702 set fname [$patchtop.fname get]
5703 set cmd [diffcmd [list $oldid $newid] -p]
5704 lappend cmd >$fname &
5705 if {[catch {eval exec $cmd} err]} {
5706 error_popup "Error creating patch: $err"
5708 catch {destroy $patchtop}
5709 unset patchtop
5712 proc mkpatchcan {} {
5713 global patchtop
5715 catch {destroy $patchtop}
5716 unset patchtop
5719 proc mktag {} {
5720 global rowmenuid mktagtop commitinfo
5722 set top .maketag
5723 set mktagtop $top
5724 catch {destroy $top}
5725 toplevel $top
5726 label $top.title -text "Create tag"
5727 grid $top.title - -pady 10
5728 label $top.id -text "ID:"
5729 entry $top.sha1 -width 40 -relief flat
5730 $top.sha1 insert 0 $rowmenuid
5731 $top.sha1 conf -state readonly
5732 grid $top.id $top.sha1 -sticky w
5733 entry $top.head -width 60 -relief flat
5734 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5735 $top.head conf -state readonly
5736 grid x $top.head -sticky w
5737 label $top.tlab -text "Tag name:"
5738 entry $top.tag -width 60
5739 grid $top.tlab $top.tag -sticky w
5740 frame $top.buts
5741 button $top.buts.gen -text "Create" -command mktaggo
5742 button $top.buts.can -text "Cancel" -command mktagcan
5743 grid $top.buts.gen $top.buts.can
5744 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5745 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5746 grid $top.buts - -pady 10 -sticky ew
5747 focus $top.tag
5750 proc domktag {} {
5751 global mktagtop env tagids idtags
5753 set id [$mktagtop.sha1 get]
5754 set tag [$mktagtop.tag get]
5755 if {$tag == {}} {
5756 error_popup "No tag name specified"
5757 return
5759 if {[info exists tagids($tag)]} {
5760 error_popup "Tag \"$tag\" already exists"
5761 return
5763 if {[catch {
5764 set dir [gitdir]
5765 set fname [file join $dir "refs/tags" $tag]
5766 set f [open $fname w]
5767 puts $f $id
5768 close $f
5769 } err]} {
5770 error_popup "Error creating tag: $err"
5771 return
5774 set tagids($tag) $id
5775 lappend idtags($id) $tag
5776 redrawtags $id
5777 addedtag $id
5780 proc redrawtags {id} {
5781 global canv linehtag commitrow idpos selectedline curview
5782 global mainfont canvxmax iddrawn
5784 if {![info exists commitrow($curview,$id)]} return
5785 if {![info exists iddrawn($id)]} return
5786 drawcommits $commitrow($curview,$id)
5787 $canv delete tag.$id
5788 set xt [eval drawtags $id $idpos($id)]
5789 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5790 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5791 set xr [expr {$xt + [font measure $mainfont $text]}]
5792 if {$xr > $canvxmax} {
5793 set canvxmax $xr
5794 setcanvscroll
5796 if {[info exists selectedline]
5797 && $selectedline == $commitrow($curview,$id)} {
5798 selectline $selectedline 0
5802 proc mktagcan {} {
5803 global mktagtop
5805 catch {destroy $mktagtop}
5806 unset mktagtop
5809 proc mktaggo {} {
5810 domktag
5811 mktagcan
5814 proc writecommit {} {
5815 global rowmenuid wrcomtop commitinfo wrcomcmd
5817 set top .writecommit
5818 set wrcomtop $top
5819 catch {destroy $top}
5820 toplevel $top
5821 label $top.title -text "Write commit to file"
5822 grid $top.title - -pady 10
5823 label $top.id -text "ID:"
5824 entry $top.sha1 -width 40 -relief flat
5825 $top.sha1 insert 0 $rowmenuid
5826 $top.sha1 conf -state readonly
5827 grid $top.id $top.sha1 -sticky w
5828 entry $top.head -width 60 -relief flat
5829 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5830 $top.head conf -state readonly
5831 grid x $top.head -sticky w
5832 label $top.clab -text "Command:"
5833 entry $top.cmd -width 60 -textvariable wrcomcmd
5834 grid $top.clab $top.cmd -sticky w -pady 10
5835 label $top.flab -text "Output file:"
5836 entry $top.fname -width 60
5837 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5838 grid $top.flab $top.fname -sticky w
5839 frame $top.buts
5840 button $top.buts.gen -text "Write" -command wrcomgo
5841 button $top.buts.can -text "Cancel" -command wrcomcan
5842 grid $top.buts.gen $top.buts.can
5843 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5844 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5845 grid $top.buts - -pady 10 -sticky ew
5846 focus $top.fname
5849 proc wrcomgo {} {
5850 global wrcomtop
5852 set id [$wrcomtop.sha1 get]
5853 set cmd "echo $id | [$wrcomtop.cmd get]"
5854 set fname [$wrcomtop.fname get]
5855 if {[catch {exec sh -c $cmd >$fname &} err]} {
5856 error_popup "Error writing commit: $err"
5858 catch {destroy $wrcomtop}
5859 unset wrcomtop
5862 proc wrcomcan {} {
5863 global wrcomtop
5865 catch {destroy $wrcomtop}
5866 unset wrcomtop
5869 proc mkbranch {} {
5870 global rowmenuid mkbrtop
5872 set top .makebranch
5873 catch {destroy $top}
5874 toplevel $top
5875 label $top.title -text "Create new branch"
5876 grid $top.title - -pady 10
5877 label $top.id -text "ID:"
5878 entry $top.sha1 -width 40 -relief flat
5879 $top.sha1 insert 0 $rowmenuid
5880 $top.sha1 conf -state readonly
5881 grid $top.id $top.sha1 -sticky w
5882 label $top.nlab -text "Name:"
5883 entry $top.name -width 40
5884 grid $top.nlab $top.name -sticky w
5885 frame $top.buts
5886 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5887 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5888 grid $top.buts.go $top.buts.can
5889 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5890 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5891 grid $top.buts - -pady 10 -sticky ew
5892 focus $top.name
5895 proc mkbrgo {top} {
5896 global headids idheads
5898 set name [$top.name get]
5899 set id [$top.sha1 get]
5900 if {$name eq {}} {
5901 error_popup "Please specify a name for the new branch"
5902 return
5904 catch {destroy $top}
5905 nowbusy newbranch
5906 update
5907 if {[catch {
5908 exec git branch $name $id
5909 } err]} {
5910 notbusy newbranch
5911 error_popup $err
5912 } else {
5913 set headids($name) $id
5914 lappend idheads($id) $name
5915 addedhead $id $name
5916 notbusy newbranch
5917 redrawtags $id
5918 dispneartags 0
5922 proc cherrypick {} {
5923 global rowmenuid curview commitrow
5924 global mainhead
5926 set oldhead [exec git rev-parse HEAD]
5927 set dheads [descheads $rowmenuid]
5928 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5929 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5930 included in branch $mainhead -- really re-apply it?"]
5931 if {!$ok} return
5933 nowbusy cherrypick
5934 update
5935 # Unfortunately git-cherry-pick writes stuff to stderr even when
5936 # no error occurs, and exec takes that as an indication of error...
5937 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5938 notbusy cherrypick
5939 error_popup $err
5940 return
5942 set newhead [exec git rev-parse HEAD]
5943 if {$newhead eq $oldhead} {
5944 notbusy cherrypick
5945 error_popup "No changes committed"
5946 return
5948 addnewchild $newhead $oldhead
5949 if {[info exists commitrow($curview,$oldhead)]} {
5950 insertrow $commitrow($curview,$oldhead) $newhead
5951 if {$mainhead ne {}} {
5952 movehead $newhead $mainhead
5953 movedhead $newhead $mainhead
5955 redrawtags $oldhead
5956 redrawtags $newhead
5958 notbusy cherrypick
5961 proc resethead {} {
5962 global mainheadid mainhead rowmenuid confirm_ok resettype
5963 global showlocalchanges
5965 set confirm_ok 0
5966 set w ".confirmreset"
5967 toplevel $w
5968 wm transient $w .
5969 wm title $w "Confirm reset"
5970 message $w.m -text \
5971 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5972 -justify center -aspect 1000
5973 pack $w.m -side top -fill x -padx 20 -pady 20
5974 frame $w.f -relief sunken -border 2
5975 message $w.f.rt -text "Reset type:" -aspect 1000
5976 grid $w.f.rt -sticky w
5977 set resettype mixed
5978 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5979 -text "Soft: Leave working tree and index untouched"
5980 grid $w.f.soft -sticky w
5981 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5982 -text "Mixed: Leave working tree untouched, reset index"
5983 grid $w.f.mixed -sticky w
5984 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5985 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5986 grid $w.f.hard -sticky w
5987 pack $w.f -side top -fill x
5988 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5989 pack $w.ok -side left -fill x -padx 20 -pady 20
5990 button $w.cancel -text Cancel -command "destroy $w"
5991 pack $w.cancel -side right -fill x -padx 20 -pady 20
5992 bind $w <Visibility> "grab $w; focus $w"
5993 tkwait window $w
5994 if {!$confirm_ok} return
5995 if {[catch {set fd [open \
5996 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5997 error_popup $err
5998 } else {
5999 dohidelocalchanges
6000 set w ".resetprogress"
6001 filerun $fd [list readresetstat $fd $w]
6002 toplevel $w
6003 wm transient $w
6004 wm title $w "Reset progress"
6005 message $w.m -text "Reset in progress, please wait..." \
6006 -justify center -aspect 1000
6007 pack $w.m -side top -fill x -padx 20 -pady 5
6008 canvas $w.c -width 150 -height 20 -bg white
6009 $w.c create rect 0 0 0 20 -fill green -tags rect
6010 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6011 nowbusy reset
6015 proc readresetstat {fd w} {
6016 global mainhead mainheadid showlocalchanges
6018 if {[gets $fd line] >= 0} {
6019 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6020 set x [expr {($m * 150) / $n}]
6021 $w.c coords rect 0 0 $x 20
6023 return 1
6025 destroy $w
6026 notbusy reset
6027 if {[catch {close $fd} err]} {
6028 error_popup $err
6030 set oldhead $mainheadid
6031 set newhead [exec git rev-parse HEAD]
6032 if {$newhead ne $oldhead} {
6033 movehead $newhead $mainhead
6034 movedhead $newhead $mainhead
6035 set mainheadid $newhead
6036 redrawtags $oldhead
6037 redrawtags $newhead
6039 if {$showlocalchanges} {
6040 doshowlocalchanges
6042 return 0
6045 # context menu for a head
6046 proc headmenu {x y id head} {
6047 global headmenuid headmenuhead headctxmenu mainhead
6049 set headmenuid $id
6050 set headmenuhead $head
6051 set state normal
6052 if {$head eq $mainhead} {
6053 set state disabled
6055 $headctxmenu entryconfigure 0 -state $state
6056 $headctxmenu entryconfigure 1 -state $state
6057 tk_popup $headctxmenu $x $y
6060 proc cobranch {} {
6061 global headmenuid headmenuhead mainhead headids
6062 global showlocalchanges mainheadid
6064 # check the tree is clean first??
6065 set oldmainhead $mainhead
6066 nowbusy checkout
6067 update
6068 dohidelocalchanges
6069 if {[catch {
6070 exec git checkout -q $headmenuhead
6071 } err]} {
6072 notbusy checkout
6073 error_popup $err
6074 } else {
6075 notbusy checkout
6076 set mainhead $headmenuhead
6077 set mainheadid $headmenuid
6078 if {[info exists headids($oldmainhead)]} {
6079 redrawtags $headids($oldmainhead)
6081 redrawtags $headmenuid
6083 if {$showlocalchanges} {
6084 dodiffindex
6088 proc rmbranch {} {
6089 global headmenuid headmenuhead mainhead
6090 global headids idheads
6092 set head $headmenuhead
6093 set id $headmenuid
6094 # this check shouldn't be needed any more...
6095 if {$head eq $mainhead} {
6096 error_popup "Cannot delete the currently checked-out branch"
6097 return
6099 set dheads [descheads $id]
6100 if {$dheads eq $headids($head)} {
6101 # the stuff on this branch isn't on any other branch
6102 if {![confirm_popup "The commits on branch $head aren't on any other\
6103 branch.\nReally delete branch $head?"]} return
6105 nowbusy rmbranch
6106 update
6107 if {[catch {exec git branch -D $head} err]} {
6108 notbusy rmbranch
6109 error_popup $err
6110 return
6112 removehead $id $head
6113 removedhead $id $head
6114 redrawtags $id
6115 notbusy rmbranch
6116 dispneartags 0
6119 # Stuff for finding nearby tags
6120 proc getallcommits {} {
6121 global allcommits allids nbmp nextarc seeds
6123 set allids {}
6124 set nbmp 0
6125 set nextarc 0
6126 set allcommits 0
6127 set seeds {}
6128 regetallcommits
6131 # Called when the graph might have changed
6132 proc regetallcommits {} {
6133 global allcommits seeds
6135 set cmd [concat | git rev-list --all --parents]
6136 foreach id $seeds {
6137 lappend cmd "^$id"
6139 set fd [open $cmd r]
6140 fconfigure $fd -blocking 0
6141 incr allcommits
6142 nowbusy allcommits
6143 filerun $fd [list getallclines $fd]
6146 # Since most commits have 1 parent and 1 child, we group strings of
6147 # such commits into "arcs" joining branch/merge points (BMPs), which
6148 # are commits that either don't have 1 parent or don't have 1 child.
6150 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6151 # arcout(id) - outgoing arcs for BMP
6152 # arcids(a) - list of IDs on arc including end but not start
6153 # arcstart(a) - BMP ID at start of arc
6154 # arcend(a) - BMP ID at end of arc
6155 # growing(a) - arc a is still growing
6156 # arctags(a) - IDs out of arcids (excluding end) that have tags
6157 # archeads(a) - IDs out of arcids (excluding end) that have heads
6158 # The start of an arc is at the descendent end, so "incoming" means
6159 # coming from descendents, and "outgoing" means going towards ancestors.
6161 proc getallclines {fd} {
6162 global allids allparents allchildren idtags idheads nextarc nbmp
6163 global arcnos arcids arctags arcout arcend arcstart archeads growing
6164 global seeds allcommits
6166 set nid 0
6167 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6168 set id [lindex $line 0]
6169 if {[info exists allparents($id)]} {
6170 # seen it already
6171 continue
6173 lappend allids $id
6174 set olds [lrange $line 1 end]
6175 set allparents($id) $olds
6176 if {![info exists allchildren($id)]} {
6177 set allchildren($id) {}
6178 set arcnos($id) {}
6179 lappend seeds $id
6180 } else {
6181 set a $arcnos($id)
6182 if {[llength $olds] == 1 && [llength $a] == 1} {
6183 lappend arcids($a) $id
6184 if {[info exists idtags($id)]} {
6185 lappend arctags($a) $id
6187 if {[info exists idheads($id)]} {
6188 lappend archeads($a) $id
6190 if {[info exists allparents($olds)]} {
6191 # seen parent already
6192 if {![info exists arcout($olds)]} {
6193 splitarc $olds
6195 lappend arcids($a) $olds
6196 set arcend($a) $olds
6197 unset growing($a)
6199 lappend allchildren($olds) $id
6200 lappend arcnos($olds) $a
6201 continue
6204 incr nbmp
6205 foreach a $arcnos($id) {
6206 lappend arcids($a) $id
6207 set arcend($a) $id
6208 unset growing($a)
6211 set ao {}
6212 foreach p $olds {
6213 lappend allchildren($p) $id
6214 set a [incr nextarc]
6215 set arcstart($a) $id
6216 set archeads($a) {}
6217 set arctags($a) {}
6218 set archeads($a) {}
6219 set arcids($a) {}
6220 lappend ao $a
6221 set growing($a) 1
6222 if {[info exists allparents($p)]} {
6223 # seen it already, may need to make a new branch
6224 if {![info exists arcout($p)]} {
6225 splitarc $p
6227 lappend arcids($a) $p
6228 set arcend($a) $p
6229 unset growing($a)
6231 lappend arcnos($p) $a
6233 set arcout($id) $ao
6235 if {$nid > 0} {
6236 global cached_dheads cached_dtags cached_atags
6237 catch {unset cached_dheads}
6238 catch {unset cached_dtags}
6239 catch {unset cached_atags}
6241 if {![eof $fd]} {
6242 return [expr {$nid >= 1000? 2: 1}]
6244 close $fd
6245 if {[incr allcommits -1] == 0} {
6246 notbusy allcommits
6248 dispneartags 0
6249 return 0
6252 proc recalcarc {a} {
6253 global arctags archeads arcids idtags idheads
6255 set at {}
6256 set ah {}
6257 foreach id [lrange $arcids($a) 0 end-1] {
6258 if {[info exists idtags($id)]} {
6259 lappend at $id
6261 if {[info exists idheads($id)]} {
6262 lappend ah $id
6265 set arctags($a) $at
6266 set archeads($a) $ah
6269 proc splitarc {p} {
6270 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6271 global arcstart arcend arcout allparents growing
6273 set a $arcnos($p)
6274 if {[llength $a] != 1} {
6275 puts "oops splitarc called but [llength $a] arcs already"
6276 return
6278 set a [lindex $a 0]
6279 set i [lsearch -exact $arcids($a) $p]
6280 if {$i < 0} {
6281 puts "oops splitarc $p not in arc $a"
6282 return
6284 set na [incr nextarc]
6285 if {[info exists arcend($a)]} {
6286 set arcend($na) $arcend($a)
6287 } else {
6288 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6289 set j [lsearch -exact $arcnos($l) $a]
6290 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6292 set tail [lrange $arcids($a) [expr {$i+1}] end]
6293 set arcids($a) [lrange $arcids($a) 0 $i]
6294 set arcend($a) $p
6295 set arcstart($na) $p
6296 set arcout($p) $na
6297 set arcids($na) $tail
6298 if {[info exists growing($a)]} {
6299 set growing($na) 1
6300 unset growing($a)
6302 incr nbmp
6304 foreach id $tail {
6305 if {[llength $arcnos($id)] == 1} {
6306 set arcnos($id) $na
6307 } else {
6308 set j [lsearch -exact $arcnos($id) $a]
6309 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6313 # reconstruct tags and heads lists
6314 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6315 recalcarc $a
6316 recalcarc $na
6317 } else {
6318 set arctags($na) {}
6319 set archeads($na) {}
6323 # Update things for a new commit added that is a child of one
6324 # existing commit. Used when cherry-picking.
6325 proc addnewchild {id p} {
6326 global allids allparents allchildren idtags nextarc nbmp
6327 global arcnos arcids arctags arcout arcend arcstart archeads growing
6328 global seeds
6330 lappend allids $id
6331 set allparents($id) [list $p]
6332 set allchildren($id) {}
6333 set arcnos($id) {}
6334 lappend seeds $id
6335 incr nbmp
6336 lappend allchildren($p) $id
6337 set a [incr nextarc]
6338 set arcstart($a) $id
6339 set archeads($a) {}
6340 set arctags($a) {}
6341 set arcids($a) [list $p]
6342 set arcend($a) $p
6343 if {![info exists arcout($p)]} {
6344 splitarc $p
6346 lappend arcnos($p) $a
6347 set arcout($id) [list $a]
6350 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6351 # or 0 if neither is true.
6352 proc anc_or_desc {a b} {
6353 global arcout arcstart arcend arcnos cached_isanc
6355 if {$arcnos($a) eq $arcnos($b)} {
6356 # Both are on the same arc(s); either both are the same BMP,
6357 # or if one is not a BMP, the other is also not a BMP or is
6358 # the BMP at end of the arc (and it only has 1 incoming arc).
6359 # Or both can be BMPs with no incoming arcs.
6360 if {$a eq $b || $arcnos($a) eq {}} {
6361 return 0
6363 # assert {[llength $arcnos($a)] == 1}
6364 set arc [lindex $arcnos($a) 0]
6365 set i [lsearch -exact $arcids($arc) $a]
6366 set j [lsearch -exact $arcids($arc) $b]
6367 if {$i < 0 || $i > $j} {
6368 return 1
6369 } else {
6370 return -1
6374 if {![info exists arcout($a)]} {
6375 set arc [lindex $arcnos($a) 0]
6376 if {[info exists arcend($arc)]} {
6377 set aend $arcend($arc)
6378 } else {
6379 set aend {}
6381 set a $arcstart($arc)
6382 } else {
6383 set aend $a
6385 if {![info exists arcout($b)]} {
6386 set arc [lindex $arcnos($b) 0]
6387 if {[info exists arcend($arc)]} {
6388 set bend $arcend($arc)
6389 } else {
6390 set bend {}
6392 set b $arcstart($arc)
6393 } else {
6394 set bend $b
6396 if {$a eq $bend} {
6397 return 1
6399 if {$b eq $aend} {
6400 return -1
6402 if {[info exists cached_isanc($a,$bend)]} {
6403 if {$cached_isanc($a,$bend)} {
6404 return 1
6407 if {[info exists cached_isanc($b,$aend)]} {
6408 if {$cached_isanc($b,$aend)} {
6409 return -1
6411 if {[info exists cached_isanc($a,$bend)]} {
6412 return 0
6416 set todo [list $a $b]
6417 set anc($a) a
6418 set anc($b) b
6419 for {set i 0} {$i < [llength $todo]} {incr i} {
6420 set x [lindex $todo $i]
6421 if {$anc($x) eq {}} {
6422 continue
6424 foreach arc $arcnos($x) {
6425 set xd $arcstart($arc)
6426 if {$xd eq $bend} {
6427 set cached_isanc($a,$bend) 1
6428 set cached_isanc($b,$aend) 0
6429 return 1
6430 } elseif {$xd eq $aend} {
6431 set cached_isanc($b,$aend) 1
6432 set cached_isanc($a,$bend) 0
6433 return -1
6435 if {![info exists anc($xd)]} {
6436 set anc($xd) $anc($x)
6437 lappend todo $xd
6438 } elseif {$anc($xd) ne $anc($x)} {
6439 set anc($xd) {}
6443 set cached_isanc($a,$bend) 0
6444 set cached_isanc($b,$aend) 0
6445 return 0
6448 # This identifies whether $desc has an ancestor that is
6449 # a growing tip of the graph and which is not an ancestor of $anc
6450 # and returns 0 if so and 1 if not.
6451 # If we subsequently discover a tag on such a growing tip, and that
6452 # turns out to be a descendent of $anc (which it could, since we
6453 # don't necessarily see children before parents), then $desc
6454 # isn't a good choice to display as a descendent tag of
6455 # $anc (since it is the descendent of another tag which is
6456 # a descendent of $anc). Similarly, $anc isn't a good choice to
6457 # display as a ancestor tag of $desc.
6459 proc is_certain {desc anc} {
6460 global arcnos arcout arcstart arcend growing problems
6462 set certain {}
6463 if {[llength $arcnos($anc)] == 1} {
6464 # tags on the same arc are certain
6465 if {$arcnos($desc) eq $arcnos($anc)} {
6466 return 1
6468 if {![info exists arcout($anc)]} {
6469 # if $anc is partway along an arc, use the start of the arc instead
6470 set a [lindex $arcnos($anc) 0]
6471 set anc $arcstart($a)
6474 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6475 set x $desc
6476 } else {
6477 set a [lindex $arcnos($desc) 0]
6478 set x $arcend($a)
6480 if {$x == $anc} {
6481 return 1
6483 set anclist [list $x]
6484 set dl($x) 1
6485 set nnh 1
6486 set ngrowanc 0
6487 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6488 set x [lindex $anclist $i]
6489 if {$dl($x)} {
6490 incr nnh -1
6492 set done($x) 1
6493 foreach a $arcout($x) {
6494 if {[info exists growing($a)]} {
6495 if {![info exists growanc($x)] && $dl($x)} {
6496 set growanc($x) 1
6497 incr ngrowanc
6499 } else {
6500 set y $arcend($a)
6501 if {[info exists dl($y)]} {
6502 if {$dl($y)} {
6503 if {!$dl($x)} {
6504 set dl($y) 0
6505 if {![info exists done($y)]} {
6506 incr nnh -1
6508 if {[info exists growanc($x)]} {
6509 incr ngrowanc -1
6511 set xl [list $y]
6512 for {set k 0} {$k < [llength $xl]} {incr k} {
6513 set z [lindex $xl $k]
6514 foreach c $arcout($z) {
6515 if {[info exists arcend($c)]} {
6516 set v $arcend($c)
6517 if {[info exists dl($v)] && $dl($v)} {
6518 set dl($v) 0
6519 if {![info exists done($v)]} {
6520 incr nnh -1
6522 if {[info exists growanc($v)]} {
6523 incr ngrowanc -1
6525 lappend xl $v
6532 } elseif {$y eq $anc || !$dl($x)} {
6533 set dl($y) 0
6534 lappend anclist $y
6535 } else {
6536 set dl($y) 1
6537 lappend anclist $y
6538 incr nnh
6543 foreach x [array names growanc] {
6544 if {$dl($x)} {
6545 return 0
6547 return 0
6549 return 1
6552 proc validate_arctags {a} {
6553 global arctags idtags
6555 set i -1
6556 set na $arctags($a)
6557 foreach id $arctags($a) {
6558 incr i
6559 if {![info exists idtags($id)]} {
6560 set na [lreplace $na $i $i]
6561 incr i -1
6564 set arctags($a) $na
6567 proc validate_archeads {a} {
6568 global archeads idheads
6570 set i -1
6571 set na $archeads($a)
6572 foreach id $archeads($a) {
6573 incr i
6574 if {![info exists idheads($id)]} {
6575 set na [lreplace $na $i $i]
6576 incr i -1
6579 set archeads($a) $na
6582 # Return the list of IDs that have tags that are descendents of id,
6583 # ignoring IDs that are descendents of IDs already reported.
6584 proc desctags {id} {
6585 global arcnos arcstart arcids arctags idtags allparents
6586 global growing cached_dtags
6588 if {![info exists allparents($id)]} {
6589 return {}
6591 set t1 [clock clicks -milliseconds]
6592 set argid $id
6593 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6594 # part-way along an arc; check that arc first
6595 set a [lindex $arcnos($id) 0]
6596 if {$arctags($a) ne {}} {
6597 validate_arctags $a
6598 set i [lsearch -exact $arcids($a) $id]
6599 set tid {}
6600 foreach t $arctags($a) {
6601 set j [lsearch -exact $arcids($a) $t]
6602 if {$j >= $i} break
6603 set tid $t
6605 if {$tid ne {}} {
6606 return $tid
6609 set id $arcstart($a)
6610 if {[info exists idtags($id)]} {
6611 return $id
6614 if {[info exists cached_dtags($id)]} {
6615 return $cached_dtags($id)
6618 set origid $id
6619 set todo [list $id]
6620 set queued($id) 1
6621 set nc 1
6622 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6623 set id [lindex $todo $i]
6624 set done($id) 1
6625 set ta [info exists hastaggedancestor($id)]
6626 if {!$ta} {
6627 incr nc -1
6629 # ignore tags on starting node
6630 if {!$ta && $i > 0} {
6631 if {[info exists idtags($id)]} {
6632 set tagloc($id) $id
6633 set ta 1
6634 } elseif {[info exists cached_dtags($id)]} {
6635 set tagloc($id) $cached_dtags($id)
6636 set ta 1
6639 foreach a $arcnos($id) {
6640 set d $arcstart($a)
6641 if {!$ta && $arctags($a) ne {}} {
6642 validate_arctags $a
6643 if {$arctags($a) ne {}} {
6644 lappend tagloc($id) [lindex $arctags($a) end]
6647 if {$ta || $arctags($a) ne {}} {
6648 set tomark [list $d]
6649 for {set j 0} {$j < [llength $tomark]} {incr j} {
6650 set dd [lindex $tomark $j]
6651 if {![info exists hastaggedancestor($dd)]} {
6652 if {[info exists done($dd)]} {
6653 foreach b $arcnos($dd) {
6654 lappend tomark $arcstart($b)
6656 if {[info exists tagloc($dd)]} {
6657 unset tagloc($dd)
6659 } elseif {[info exists queued($dd)]} {
6660 incr nc -1
6662 set hastaggedancestor($dd) 1
6666 if {![info exists queued($d)]} {
6667 lappend todo $d
6668 set queued($d) 1
6669 if {![info exists hastaggedancestor($d)]} {
6670 incr nc
6675 set tags {}
6676 foreach id [array names tagloc] {
6677 if {![info exists hastaggedancestor($id)]} {
6678 foreach t $tagloc($id) {
6679 if {[lsearch -exact $tags $t] < 0} {
6680 lappend tags $t
6685 set t2 [clock clicks -milliseconds]
6686 set loopix $i
6688 # remove tags that are descendents of other tags
6689 for {set i 0} {$i < [llength $tags]} {incr i} {
6690 set a [lindex $tags $i]
6691 for {set j 0} {$j < $i} {incr j} {
6692 set b [lindex $tags $j]
6693 set r [anc_or_desc $a $b]
6694 if {$r == 1} {
6695 set tags [lreplace $tags $j $j]
6696 incr j -1
6697 incr i -1
6698 } elseif {$r == -1} {
6699 set tags [lreplace $tags $i $i]
6700 incr i -1
6701 break
6706 if {[array names growing] ne {}} {
6707 # graph isn't finished, need to check if any tag could get
6708 # eclipsed by another tag coming later. Simply ignore any
6709 # tags that could later get eclipsed.
6710 set ctags {}
6711 foreach t $tags {
6712 if {[is_certain $t $origid]} {
6713 lappend ctags $t
6716 if {$tags eq $ctags} {
6717 set cached_dtags($origid) $tags
6718 } else {
6719 set tags $ctags
6721 } else {
6722 set cached_dtags($origid) $tags
6724 set t3 [clock clicks -milliseconds]
6725 if {0 && $t3 - $t1 >= 100} {
6726 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6727 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6729 return $tags
6732 proc anctags {id} {
6733 global arcnos arcids arcout arcend arctags idtags allparents
6734 global growing cached_atags
6736 if {![info exists allparents($id)]} {
6737 return {}
6739 set t1 [clock clicks -milliseconds]
6740 set argid $id
6741 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6742 # part-way along an arc; check that arc first
6743 set a [lindex $arcnos($id) 0]
6744 if {$arctags($a) ne {}} {
6745 validate_arctags $a
6746 set i [lsearch -exact $arcids($a) $id]
6747 foreach t $arctags($a) {
6748 set j [lsearch -exact $arcids($a) $t]
6749 if {$j > $i} {
6750 return $t
6754 if {![info exists arcend($a)]} {
6755 return {}
6757 set id $arcend($a)
6758 if {[info exists idtags($id)]} {
6759 return $id
6762 if {[info exists cached_atags($id)]} {
6763 return $cached_atags($id)
6766 set origid $id
6767 set todo [list $id]
6768 set queued($id) 1
6769 set taglist {}
6770 set nc 1
6771 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6772 set id [lindex $todo $i]
6773 set done($id) 1
6774 set td [info exists hastaggeddescendent($id)]
6775 if {!$td} {
6776 incr nc -1
6778 # ignore tags on starting node
6779 if {!$td && $i > 0} {
6780 if {[info exists idtags($id)]} {
6781 set tagloc($id) $id
6782 set td 1
6783 } elseif {[info exists cached_atags($id)]} {
6784 set tagloc($id) $cached_atags($id)
6785 set td 1
6788 foreach a $arcout($id) {
6789 if {!$td && $arctags($a) ne {}} {
6790 validate_arctags $a
6791 if {$arctags($a) ne {}} {
6792 lappend tagloc($id) [lindex $arctags($a) 0]
6795 if {![info exists arcend($a)]} continue
6796 set d $arcend($a)
6797 if {$td || $arctags($a) ne {}} {
6798 set tomark [list $d]
6799 for {set j 0} {$j < [llength $tomark]} {incr j} {
6800 set dd [lindex $tomark $j]
6801 if {![info exists hastaggeddescendent($dd)]} {
6802 if {[info exists done($dd)]} {
6803 foreach b $arcout($dd) {
6804 if {[info exists arcend($b)]} {
6805 lappend tomark $arcend($b)
6808 if {[info exists tagloc($dd)]} {
6809 unset tagloc($dd)
6811 } elseif {[info exists queued($dd)]} {
6812 incr nc -1
6814 set hastaggeddescendent($dd) 1
6818 if {![info exists queued($d)]} {
6819 lappend todo $d
6820 set queued($d) 1
6821 if {![info exists hastaggeddescendent($d)]} {
6822 incr nc
6827 set t2 [clock clicks -milliseconds]
6828 set loopix $i
6829 set tags {}
6830 foreach id [array names tagloc] {
6831 if {![info exists hastaggeddescendent($id)]} {
6832 foreach t $tagloc($id) {
6833 if {[lsearch -exact $tags $t] < 0} {
6834 lappend tags $t
6840 # remove tags that are ancestors of other tags
6841 for {set i 0} {$i < [llength $tags]} {incr i} {
6842 set a [lindex $tags $i]
6843 for {set j 0} {$j < $i} {incr j} {
6844 set b [lindex $tags $j]
6845 set r [anc_or_desc $a $b]
6846 if {$r == -1} {
6847 set tags [lreplace $tags $j $j]
6848 incr j -1
6849 incr i -1
6850 } elseif {$r == 1} {
6851 set tags [lreplace $tags $i $i]
6852 incr i -1
6853 break
6858 if {[array names growing] ne {}} {
6859 # graph isn't finished, need to check if any tag could get
6860 # eclipsed by another tag coming later. Simply ignore any
6861 # tags that could later get eclipsed.
6862 set ctags {}
6863 foreach t $tags {
6864 if {[is_certain $origid $t]} {
6865 lappend ctags $t
6868 if {$tags eq $ctags} {
6869 set cached_atags($origid) $tags
6870 } else {
6871 set tags $ctags
6873 } else {
6874 set cached_atags($origid) $tags
6876 set t3 [clock clicks -milliseconds]
6877 if {0 && $t3 - $t1 >= 100} {
6878 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6879 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6881 return $tags
6884 # Return the list of IDs that have heads that are descendents of id,
6885 # including id itself if it has a head.
6886 proc descheads {id} {
6887 global arcnos arcstart arcids archeads idheads cached_dheads
6888 global allparents
6890 if {![info exists allparents($id)]} {
6891 return {}
6893 set aret {}
6894 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6895 # part-way along an arc; check it first
6896 set a [lindex $arcnos($id) 0]
6897 if {$archeads($a) ne {}} {
6898 validate_archeads $a
6899 set i [lsearch -exact $arcids($a) $id]
6900 foreach t $archeads($a) {
6901 set j [lsearch -exact $arcids($a) $t]
6902 if {$j > $i} break
6903 lappend aret $t
6906 set id $arcstart($a)
6908 set origid $id
6909 set todo [list $id]
6910 set seen($id) 1
6911 set ret {}
6912 for {set i 0} {$i < [llength $todo]} {incr i} {
6913 set id [lindex $todo $i]
6914 if {[info exists cached_dheads($id)]} {
6915 set ret [concat $ret $cached_dheads($id)]
6916 } else {
6917 if {[info exists idheads($id)]} {
6918 lappend ret $id
6920 foreach a $arcnos($id) {
6921 if {$archeads($a) ne {}} {
6922 validate_archeads $a
6923 if {$archeads($a) ne {}} {
6924 set ret [concat $ret $archeads($a)]
6927 set d $arcstart($a)
6928 if {![info exists seen($d)]} {
6929 lappend todo $d
6930 set seen($d) 1
6935 set ret [lsort -unique $ret]
6936 set cached_dheads($origid) $ret
6937 return [concat $ret $aret]
6940 proc addedtag {id} {
6941 global arcnos arcout cached_dtags cached_atags
6943 if {![info exists arcnos($id)]} return
6944 if {![info exists arcout($id)]} {
6945 recalcarc [lindex $arcnos($id) 0]
6947 catch {unset cached_dtags}
6948 catch {unset cached_atags}
6951 proc addedhead {hid head} {
6952 global arcnos arcout cached_dheads
6954 if {![info exists arcnos($hid)]} return
6955 if {![info exists arcout($hid)]} {
6956 recalcarc [lindex $arcnos($hid) 0]
6958 catch {unset cached_dheads}
6961 proc removedhead {hid head} {
6962 global cached_dheads
6964 catch {unset cached_dheads}
6967 proc movedhead {hid head} {
6968 global arcnos arcout cached_dheads
6970 if {![info exists arcnos($hid)]} return
6971 if {![info exists arcout($hid)]} {
6972 recalcarc [lindex $arcnos($hid) 0]
6974 catch {unset cached_dheads}
6977 proc changedrefs {} {
6978 global cached_dheads cached_dtags cached_atags
6979 global arctags archeads arcnos arcout idheads idtags
6981 foreach id [concat [array names idheads] [array names idtags]] {
6982 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6983 set a [lindex $arcnos($id) 0]
6984 if {![info exists donearc($a)]} {
6985 recalcarc $a
6986 set donearc($a) 1
6990 catch {unset cached_dtags}
6991 catch {unset cached_atags}
6992 catch {unset cached_dheads}
6995 proc rereadrefs {} {
6996 global idtags idheads idotherrefs mainhead
6998 set refids [concat [array names idtags] \
6999 [array names idheads] [array names idotherrefs]]
7000 foreach id $refids {
7001 if {![info exists ref($id)]} {
7002 set ref($id) [listrefs $id]
7005 set oldmainhead $mainhead
7006 readrefs
7007 changedrefs
7008 set refids [lsort -unique [concat $refids [array names idtags] \
7009 [array names idheads] [array names idotherrefs]]]
7010 foreach id $refids {
7011 set v [listrefs $id]
7012 if {![info exists ref($id)] || $ref($id) != $v ||
7013 ($id eq $oldmainhead && $id ne $mainhead) ||
7014 ($id eq $mainhead && $id ne $oldmainhead)} {
7015 redrawtags $id
7020 proc listrefs {id} {
7021 global idtags idheads idotherrefs
7023 set x {}
7024 if {[info exists idtags($id)]} {
7025 set x $idtags($id)
7027 set y {}
7028 if {[info exists idheads($id)]} {
7029 set y $idheads($id)
7031 set z {}
7032 if {[info exists idotherrefs($id)]} {
7033 set z $idotherrefs($id)
7035 return [list $x $y $z]
7038 proc showtag {tag isnew} {
7039 global ctext tagcontents tagids linknum tagobjid
7041 if {$isnew} {
7042 addtohistory [list showtag $tag 0]
7044 $ctext conf -state normal
7045 clear_ctext
7046 set linknum 0
7047 if {![info exists tagcontents($tag)]} {
7048 catch {
7049 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7052 if {[info exists tagcontents($tag)]} {
7053 set text $tagcontents($tag)
7054 } else {
7055 set text "Tag: $tag\nId: $tagids($tag)"
7057 appendwithlinks $text {}
7058 $ctext conf -state disabled
7059 init_flist {}
7062 proc doquit {} {
7063 global stopped
7064 set stopped 100
7065 savestuff .
7066 destroy .
7069 proc doprefs {} {
7070 global maxwidth maxgraphpct diffopts
7071 global oldprefs prefstop showneartags showlocalchanges
7072 global bgcolor fgcolor ctext diffcolors selectbgcolor
7073 global uifont tabstop
7075 set top .gitkprefs
7076 set prefstop $top
7077 if {[winfo exists $top]} {
7078 raise $top
7079 return
7081 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7082 set oldprefs($v) [set $v]
7084 toplevel $top
7085 wm title $top "Gitk preferences"
7086 label $top.ldisp -text "Commit list display options"
7087 $top.ldisp configure -font $uifont
7088 grid $top.ldisp - -sticky w -pady 10
7089 label $top.spacer -text " "
7090 label $top.maxwidthl -text "Maximum graph width (lines)" \
7091 -font optionfont
7092 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7093 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7094 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7095 -font optionfont
7096 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7097 grid x $top.maxpctl $top.maxpct -sticky w
7098 frame $top.showlocal
7099 label $top.showlocal.l -text "Show local changes" -font optionfont
7100 checkbutton $top.showlocal.b -variable showlocalchanges
7101 pack $top.showlocal.b $top.showlocal.l -side left
7102 grid x $top.showlocal -sticky w
7104 label $top.ddisp -text "Diff display options"
7105 $top.ddisp configure -font $uifont
7106 grid $top.ddisp - -sticky w -pady 10
7107 label $top.diffoptl -text "Options for diff program" \
7108 -font optionfont
7109 entry $top.diffopt -width 20 -textvariable diffopts
7110 grid x $top.diffoptl $top.diffopt -sticky w
7111 frame $top.ntag
7112 label $top.ntag.l -text "Display nearby tags" -font optionfont
7113 checkbutton $top.ntag.b -variable showneartags
7114 pack $top.ntag.b $top.ntag.l -side left
7115 grid x $top.ntag -sticky w
7116 label $top.tabstopl -text "tabstop" -font optionfont
7117 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7118 grid x $top.tabstopl $top.tabstop -sticky w
7120 label $top.cdisp -text "Colors: press to choose"
7121 $top.cdisp configure -font $uifont
7122 grid $top.cdisp - -sticky w -pady 10
7123 label $top.bg -padx 40 -relief sunk -background $bgcolor
7124 button $top.bgbut -text "Background" -font optionfont \
7125 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7126 grid x $top.bgbut $top.bg -sticky w
7127 label $top.fg -padx 40 -relief sunk -background $fgcolor
7128 button $top.fgbut -text "Foreground" -font optionfont \
7129 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7130 grid x $top.fgbut $top.fg -sticky w
7131 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7132 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7133 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7134 [list $ctext tag conf d0 -foreground]]
7135 grid x $top.diffoldbut $top.diffold -sticky w
7136 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7137 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7138 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7139 [list $ctext tag conf d1 -foreground]]
7140 grid x $top.diffnewbut $top.diffnew -sticky w
7141 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7142 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7143 -command [list choosecolor diffcolors 2 $top.hunksep \
7144 "diff hunk header" \
7145 [list $ctext tag conf hunksep -foreground]]
7146 grid x $top.hunksepbut $top.hunksep -sticky w
7147 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7148 button $top.selbgbut -text "Select bg" -font optionfont \
7149 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7150 grid x $top.selbgbut $top.selbgsep -sticky w
7152 frame $top.buts
7153 button $top.buts.ok -text "OK" -command prefsok -default active
7154 $top.buts.ok configure -font $uifont
7155 button $top.buts.can -text "Cancel" -command prefscan -default normal
7156 $top.buts.can configure -font $uifont
7157 grid $top.buts.ok $top.buts.can
7158 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7159 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7160 grid $top.buts - - -pady 10 -sticky ew
7161 bind $top <Visibility> "focus $top.buts.ok"
7164 proc choosecolor {v vi w x cmd} {
7165 global $v
7167 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7168 -title "Gitk: choose color for $x"]
7169 if {$c eq {}} return
7170 $w conf -background $c
7171 lset $v $vi $c
7172 eval $cmd $c
7175 proc setselbg {c} {
7176 global bglist cflist
7177 foreach w $bglist {
7178 $w configure -selectbackground $c
7180 $cflist tag configure highlight \
7181 -background [$cflist cget -selectbackground]
7182 allcanvs itemconf secsel -fill $c
7185 proc setbg {c} {
7186 global bglist
7188 foreach w $bglist {
7189 $w conf -background $c
7193 proc setfg {c} {
7194 global fglist canv
7196 foreach w $fglist {
7197 $w conf -foreground $c
7199 allcanvs itemconf text -fill $c
7200 $canv itemconf circle -outline $c
7203 proc prefscan {} {
7204 global maxwidth maxgraphpct diffopts
7205 global oldprefs prefstop showneartags showlocalchanges
7207 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7208 set $v $oldprefs($v)
7210 catch {destroy $prefstop}
7211 unset prefstop
7214 proc prefsok {} {
7215 global maxwidth maxgraphpct
7216 global oldprefs prefstop showneartags showlocalchanges
7217 global charspc ctext tabstop
7219 catch {destroy $prefstop}
7220 unset prefstop
7221 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7222 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7223 if {$showlocalchanges} {
7224 doshowlocalchanges
7225 } else {
7226 dohidelocalchanges
7229 if {$maxwidth != $oldprefs(maxwidth)
7230 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7231 redisplay
7232 } elseif {$showneartags != $oldprefs(showneartags)} {
7233 reselectline
7237 proc formatdate {d} {
7238 if {$d ne {}} {
7239 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7241 return $d
7244 # This list of encoding names and aliases is distilled from
7245 # http://www.iana.org/assignments/character-sets.
7246 # Not all of them are supported by Tcl.
7247 set encoding_aliases {
7248 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7249 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7250 { ISO-10646-UTF-1 csISO10646UTF1 }
7251 { ISO_646.basic:1983 ref csISO646basic1983 }
7252 { INVARIANT csINVARIANT }
7253 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7254 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7255 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7256 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7257 { NATS-DANO iso-ir-9-1 csNATSDANO }
7258 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7259 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7260 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7261 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7262 { ISO-2022-KR csISO2022KR }
7263 { EUC-KR csEUCKR }
7264 { ISO-2022-JP csISO2022JP }
7265 { ISO-2022-JP-2 csISO2022JP2 }
7266 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7267 csISO13JISC6220jp }
7268 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7269 { IT iso-ir-15 ISO646-IT csISO15Italian }
7270 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7271 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7272 { greek7-old iso-ir-18 csISO18Greek7Old }
7273 { latin-greek iso-ir-19 csISO19LatinGreek }
7274 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7275 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7276 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7277 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7278 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7279 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7280 { INIS iso-ir-49 csISO49INIS }
7281 { INIS-8 iso-ir-50 csISO50INIS8 }
7282 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7283 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7284 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7285 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7286 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7287 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7288 csISO60Norwegian1 }
7289 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7290 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7291 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7292 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7293 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7294 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7295 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7296 { greek7 iso-ir-88 csISO88Greek7 }
7297 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7298 { iso-ir-90 csISO90 }
7299 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7300 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7301 csISO92JISC62991984b }
7302 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7303 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7304 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7305 csISO95JIS62291984handadd }
7306 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7307 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7308 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7309 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7310 CP819 csISOLatin1 }
7311 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7312 { T.61-7bit iso-ir-102 csISO102T617bit }
7313 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7314 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7315 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7316 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7317 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7318 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7319 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7320 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7321 arabic csISOLatinArabic }
7322 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7323 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7324 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7325 greek greek8 csISOLatinGreek }
7326 { T.101-G2 iso-ir-128 csISO128T101G2 }
7327 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7328 csISOLatinHebrew }
7329 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7330 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7331 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7332 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7333 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7334 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7335 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7336 csISOLatinCyrillic }
7337 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7338 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7339 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7340 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7341 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7342 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7343 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7344 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7345 { ISO_10367-box iso-ir-155 csISO10367Box }
7346 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7347 { latin-lap lap iso-ir-158 csISO158Lap }
7348 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7349 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7350 { us-dk csUSDK }
7351 { dk-us csDKUS }
7352 { JIS_X0201 X0201 csHalfWidthKatakana }
7353 { KSC5636 ISO646-KR csKSC5636 }
7354 { ISO-10646-UCS-2 csUnicode }
7355 { ISO-10646-UCS-4 csUCS4 }
7356 { DEC-MCS dec csDECMCS }
7357 { hp-roman8 roman8 r8 csHPRoman8 }
7358 { macintosh mac csMacintosh }
7359 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7360 csIBM037 }
7361 { IBM038 EBCDIC-INT cp038 csIBM038 }
7362 { IBM273 CP273 csIBM273 }
7363 { IBM274 EBCDIC-BE CP274 csIBM274 }
7364 { IBM275 EBCDIC-BR cp275 csIBM275 }
7365 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7366 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7367 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7368 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7369 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7370 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7371 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7372 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7373 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7374 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7375 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7376 { IBM437 cp437 437 csPC8CodePage437 }
7377 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7378 { IBM775 cp775 csPC775Baltic }
7379 { IBM850 cp850 850 csPC850Multilingual }
7380 { IBM851 cp851 851 csIBM851 }
7381 { IBM852 cp852 852 csPCp852 }
7382 { IBM855 cp855 855 csIBM855 }
7383 { IBM857 cp857 857 csIBM857 }
7384 { IBM860 cp860 860 csIBM860 }
7385 { IBM861 cp861 861 cp-is csIBM861 }
7386 { IBM862 cp862 862 csPC862LatinHebrew }
7387 { IBM863 cp863 863 csIBM863 }
7388 { IBM864 cp864 csIBM864 }
7389 { IBM865 cp865 865 csIBM865 }
7390 { IBM866 cp866 866 csIBM866 }
7391 { IBM868 CP868 cp-ar csIBM868 }
7392 { IBM869 cp869 869 cp-gr csIBM869 }
7393 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7394 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7395 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7396 { IBM891 cp891 csIBM891 }
7397 { IBM903 cp903 csIBM903 }
7398 { IBM904 cp904 904 csIBBM904 }
7399 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7400 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7401 { IBM1026 CP1026 csIBM1026 }
7402 { EBCDIC-AT-DE csIBMEBCDICATDE }
7403 { EBCDIC-AT-DE-A csEBCDICATDEA }
7404 { EBCDIC-CA-FR csEBCDICCAFR }
7405 { EBCDIC-DK-NO csEBCDICDKNO }
7406 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7407 { EBCDIC-FI-SE csEBCDICFISE }
7408 { EBCDIC-FI-SE-A csEBCDICFISEA }
7409 { EBCDIC-FR csEBCDICFR }
7410 { EBCDIC-IT csEBCDICIT }
7411 { EBCDIC-PT csEBCDICPT }
7412 { EBCDIC-ES csEBCDICES }
7413 { EBCDIC-ES-A csEBCDICESA }
7414 { EBCDIC-ES-S csEBCDICESS }
7415 { EBCDIC-UK csEBCDICUK }
7416 { EBCDIC-US csEBCDICUS }
7417 { UNKNOWN-8BIT csUnknown8BiT }
7418 { MNEMONIC csMnemonic }
7419 { MNEM csMnem }
7420 { VISCII csVISCII }
7421 { VIQR csVIQR }
7422 { KOI8-R csKOI8R }
7423 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7424 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7425 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7426 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7427 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7428 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7429 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7430 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7431 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7432 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7433 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7434 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7435 { IBM1047 IBM-1047 }
7436 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7437 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7438 { UNICODE-1-1 csUnicode11 }
7439 { CESU-8 csCESU-8 }
7440 { BOCU-1 csBOCU-1 }
7441 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7442 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7443 l8 }
7444 { ISO-8859-15 ISO_8859-15 Latin-9 }
7445 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7446 { GBK CP936 MS936 windows-936 }
7447 { JIS_Encoding csJISEncoding }
7448 { Shift_JIS MS_Kanji csShiftJIS }
7449 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7450 EUC-JP }
7451 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7452 { ISO-10646-UCS-Basic csUnicodeASCII }
7453 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7454 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7455 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7456 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7457 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7458 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7459 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7460 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7461 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7462 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7463 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7464 { Ventura-US csVenturaUS }
7465 { Ventura-International csVenturaInternational }
7466 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7467 { PC8-Turkish csPC8Turkish }
7468 { IBM-Symbols csIBMSymbols }
7469 { IBM-Thai csIBMThai }
7470 { HP-Legal csHPLegal }
7471 { HP-Pi-font csHPPiFont }
7472 { HP-Math8 csHPMath8 }
7473 { Adobe-Symbol-Encoding csHPPSMath }
7474 { HP-DeskTop csHPDesktop }
7475 { Ventura-Math csVenturaMath }
7476 { Microsoft-Publishing csMicrosoftPublishing }
7477 { Windows-31J csWindows31J }
7478 { GB2312 csGB2312 }
7479 { Big5 csBig5 }
7482 proc tcl_encoding {enc} {
7483 global encoding_aliases
7484 set names [encoding names]
7485 set lcnames [string tolower $names]
7486 set enc [string tolower $enc]
7487 set i [lsearch -exact $lcnames $enc]
7488 if {$i < 0} {
7489 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7490 if {[regsub {^iso[-_]} $enc iso encx]} {
7491 set i [lsearch -exact $lcnames $encx]
7494 if {$i < 0} {
7495 foreach l $encoding_aliases {
7496 set ll [string tolower $l]
7497 if {[lsearch -exact $ll $enc] < 0} continue
7498 # look through the aliases for one that tcl knows about
7499 foreach e $ll {
7500 set i [lsearch -exact $lcnames $e]
7501 if {$i < 0} {
7502 if {[regsub {^iso[-_]} $e iso ex]} {
7503 set i [lsearch -exact $lcnames $ex]
7506 if {$i >= 0} break
7508 break
7511 if {$i >= 0} {
7512 return [lindex $names $i]
7514 return {}
7517 # defaults...
7518 set datemode 0
7519 set diffopts "-U 5 -p"
7520 set wrcomcmd "git diff-tree --stdin -p --pretty"
7522 set gitencoding {}
7523 catch {
7524 set gitencoding [exec git config --get i18n.commitencoding]
7526 if {$gitencoding == ""} {
7527 set gitencoding "utf-8"
7529 set tclencoding [tcl_encoding $gitencoding]
7530 if {$tclencoding == {}} {
7531 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7534 set mainfont {Helvetica 9}
7535 set textfont {Courier 9}
7536 set uifont {Helvetica 9 bold}
7537 set tabstop 8
7538 set findmergefiles 0
7539 set maxgraphpct 50
7540 set maxwidth 16
7541 set revlistorder 0
7542 set fastdate 0
7543 set uparrowlen 5
7544 set downarrowlen 5
7545 set mingaplen 100
7546 set cmitmode "patch"
7547 set wrapcomment "none"
7548 set showneartags 1
7549 set maxrefs 20
7550 set maxlinelen 200
7551 set showlocalchanges 1
7553 set colors {green red blue magenta darkgrey brown orange}
7554 set bgcolor white
7555 set fgcolor black
7556 set diffcolors {red "#00a000" blue}
7557 set selectbgcolor gray85
7559 catch {source ~/.gitk}
7561 font create optionfont -family sans-serif -size -12
7563 # check that we can find a .git directory somewhere...
7564 set gitdir [gitdir]
7565 if {![file isdirectory $gitdir]} {
7566 show_error {} . "Cannot find the git directory \"$gitdir\"."
7567 exit 1
7570 set revtreeargs {}
7571 set cmdline_files {}
7572 set i 0
7573 foreach arg $argv {
7574 switch -- $arg {
7575 "" { }
7576 "-d" { set datemode 1 }
7577 "--" {
7578 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7579 break
7581 default {
7582 lappend revtreeargs $arg
7585 incr i
7588 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7589 # no -- on command line, but some arguments (other than -d)
7590 if {[catch {
7591 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7592 set cmdline_files [split $f "\n"]
7593 set n [llength $cmdline_files]
7594 set revtreeargs [lrange $revtreeargs 0 end-$n]
7595 # Unfortunately git rev-parse doesn't produce an error when
7596 # something is both a revision and a filename. To be consistent
7597 # with git log and git rev-list, check revtreeargs for filenames.
7598 foreach arg $revtreeargs {
7599 if {[file exists $arg]} {
7600 show_error {} . "Ambiguous argument '$arg': both revision\
7601 and filename"
7602 exit 1
7605 } err]} {
7606 # unfortunately we get both stdout and stderr in $err,
7607 # so look for "fatal:".
7608 set i [string first "fatal:" $err]
7609 if {$i > 0} {
7610 set err [string range $err [expr {$i + 6}] end]
7612 show_error {} . "Bad arguments to gitk:\n$err"
7613 exit 1
7617 set nullid "0000000000000000000000000000000000000000"
7618 set nullid2 "0000000000000000000000000000000000000001"
7621 set runq {}
7622 set history {}
7623 set historyindex 0
7624 set fh_serial 0
7625 set nhl_names {}
7626 set highlight_paths {}
7627 set searchdirn -forwards
7628 set boldrows {}
7629 set boldnamerows {}
7630 set diffelide {0 0}
7631 set markingmatches 0
7633 set optim_delay 16
7635 set nextviewnum 1
7636 set curview 0
7637 set selectedview 0
7638 set selectedhlview None
7639 set viewfiles(0) {}
7640 set viewperm(0) 0
7641 set viewargs(0) {}
7643 set cmdlineok 0
7644 set stopped 0
7645 set stuffsaved 0
7646 set patchnum 0
7647 set lookingforhead 0
7648 set localirow -1
7649 set localfrow -1
7650 set lserial 0
7651 setcoords
7652 makewindow
7653 # wait for the window to become visible
7654 tkwait visibility .
7655 wm title . "[file tail $argv0]: [file tail [pwd]]"
7656 readrefs
7658 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7659 # create a view for the files/dirs specified on the command line
7660 set curview 1
7661 set selectedview 1
7662 set nextviewnum 2
7663 set viewname(1) "Command line"
7664 set viewfiles(1) $cmdline_files
7665 set viewargs(1) $revtreeargs
7666 set viewperm(1) 0
7667 addviewmenu 1
7668 .bar.view entryconf Edit* -state normal
7669 .bar.view entryconf Delete* -state normal
7672 if {[info exists permviews]} {
7673 foreach v $permviews {
7674 set n $nextviewnum
7675 incr nextviewnum
7676 set viewname($n) [lindex $v 0]
7677 set viewfiles($n) [lindex $v 1]
7678 set viewargs($n) [lindex $v 2]
7679 set viewperm($n) 1
7680 addviewmenu $n
7683 getcommits