gitk: Fix bug causing the "can't unset idinlist(...)" error
[git/dkf.git] / gitk
blob44b04f017a0cadc56a1f3896d1d3d84657b21c58
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
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set order "--topo-order"
91 if {$datemode} {
92 set order "--date-order"
94 if {[catch {
95 set fd [open [concat | git log -z --pretty=raw $order --parents \
96 --boundary $viewargs($view) "--" $viewfiles($view)] r]
97 } err]} {
98 error_popup "Error executing git rev-list: $err"
99 exit 1
101 set commfd($view) $fd
102 set leftover($view) {}
103 set lookingforhead $showlocalchanges
104 fconfigure $fd -blocking 0 -translation lf -eofchar {}
105 if {$tclencoding != {}} {
106 fconfigure $fd -encoding $tclencoding
108 filerun $fd [list getcommitlines $fd $view]
109 nowbusy $view
112 proc stop_rev_list {} {
113 global commfd curview
115 if {![info exists commfd($curview)]} return
116 set fd $commfd($curview)
117 catch {
118 set pid [pid $fd]
119 exec kill $pid
121 catch {close $fd}
122 unset commfd($curview)
125 proc getcommits {} {
126 global phase canv mainfont curview
128 set phase getcommits
129 initlayout
130 start_rev_list $curview
131 show_status "Reading commits..."
134 proc getcommitlines {fd view} {
135 global commitlisted
136 global leftover commfd
137 global displayorder commitidx commitrow commitdata
138 global parentlist children curview hlview
139 global vparentlist vdisporder vcmitlisted
141 set stuff [read $fd 500000]
142 # git log doesn't terminate the last commit with a null...
143 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
144 set stuff "\0"
146 if {$stuff == {}} {
147 if {![eof $fd]} {
148 return 1
150 global viewname
151 unset commfd($view)
152 notbusy $view
153 # set it blocking so we wait for the process to terminate
154 fconfigure $fd -blocking 1
155 if {[catch {close $fd} err]} {
156 set fv {}
157 if {$view != $curview} {
158 set fv " for the \"$viewname($view)\" view"
160 if {[string range $err 0 4] == "usage"} {
161 set err "Gitk: error reading commits$fv:\
162 bad arguments to git rev-list."
163 if {$viewname($view) eq "Command line"} {
164 append err \
165 " (Note: arguments to gitk are passed to git rev-list\
166 to allow selection of commits to be displayed.)"
168 } else {
169 set err "Error reading commits$fv: $err"
171 error_popup $err
173 if {$view == $curview} {
174 run chewcommits $view
176 return 0
178 set start 0
179 set gotsome 0
180 while 1 {
181 set i [string first "\0" $stuff $start]
182 if {$i < 0} {
183 append leftover($view) [string range $stuff $start end]
184 break
186 if {$start == 0} {
187 set cmit $leftover($view)
188 append cmit [string range $stuff 0 [expr {$i - 1}]]
189 set leftover($view) {}
190 } else {
191 set cmit [string range $stuff $start [expr {$i - 1}]]
193 set start [expr {$i + 1}]
194 set j [string first "\n" $cmit]
195 set ok 0
196 set listed 1
197 if {$j >= 0 && [string match "commit *" $cmit]} {
198 set ids [string range $cmit 7 [expr {$j - 1}]]
199 if {[string match {[-<>]*} $ids]} {
200 switch -- [string index $ids 0] {
201 "-" {set listed 0}
202 "<" {set listed 2}
203 ">" {set listed 3}
205 set ids [string range $ids 1 end]
207 set ok 1
208 foreach id $ids {
209 if {[string length $id] != 40} {
210 set ok 0
211 break
215 if {!$ok} {
216 set shortcmit $cmit
217 if {[string length $shortcmit] > 80} {
218 set shortcmit "[string range $shortcmit 0 80]..."
220 error_popup "Can't parse git log output: {$shortcmit}"
221 exit 1
223 set id [lindex $ids 0]
224 if {$listed} {
225 set olds [lrange $ids 1 end]
226 set i 0
227 foreach p $olds {
228 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
229 lappend children($view,$p) $id
231 incr i
233 } else {
234 set olds {}
236 if {![info exists children($view,$id)]} {
237 set children($view,$id) {}
239 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
240 set commitrow($view,$id) $commitidx($view)
241 incr commitidx($view)
242 if {$view == $curview} {
243 lappend parentlist $olds
244 lappend displayorder $id
245 lappend commitlisted $listed
246 } else {
247 lappend vparentlist($view) $olds
248 lappend vdisporder($view) $id
249 lappend vcmitlisted($view) $listed
251 set gotsome 1
253 if {$gotsome} {
254 run chewcommits $view
256 return 2
259 proc chewcommits {view} {
260 global curview hlview commfd
261 global selectedline pending_select
263 set more 0
264 if {$view == $curview} {
265 set allread [expr {![info exists commfd($view)]}]
266 set tlimit [expr {[clock clicks -milliseconds] + 50}]
267 set more [layoutmore $tlimit $allread]
268 if {$allread && !$more} {
269 global displayorder commitidx phase
270 global numcommits startmsecs
272 if {[info exists pending_select]} {
273 set row [first_real_row]
274 selectline $row 1
276 if {$commitidx($curview) > 0} {
277 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
278 #puts "overall $ms ms for $numcommits commits"
279 } else {
280 show_status "No commits selected"
282 notbusy layout
283 set phase {}
286 if {[info exists hlview] && $view == $hlview} {
287 vhighlightmore
289 return $more
292 proc readcommit {id} {
293 if {[catch {set contents [exec git cat-file commit $id]}]} return
294 parsecommit $id $contents 0
297 proc updatecommits {} {
298 global viewdata curview phase displayorder
299 global children commitrow selectedline thickerline
301 if {$phase ne {}} {
302 stop_rev_list
303 set phase {}
305 set n $curview
306 foreach id $displayorder {
307 catch {unset children($n,$id)}
308 catch {unset commitrow($n,$id)}
310 set curview -1
311 catch {unset selectedline}
312 catch {unset thickerline}
313 catch {unset viewdata($n)}
314 readrefs
315 changedrefs
316 regetallcommits
317 showview $n
320 proc parsecommit {id contents listed} {
321 global commitinfo cdate
323 set inhdr 1
324 set comment {}
325 set headline {}
326 set auname {}
327 set audate {}
328 set comname {}
329 set comdate {}
330 set hdrend [string first "\n\n" $contents]
331 if {$hdrend < 0} {
332 # should never happen...
333 set hdrend [string length $contents]
335 set header [string range $contents 0 [expr {$hdrend - 1}]]
336 set comment [string range $contents [expr {$hdrend + 2}] end]
337 foreach line [split $header "\n"] {
338 set tag [lindex $line 0]
339 if {$tag == "author"} {
340 set audate [lindex $line end-1]
341 set auname [lrange $line 1 end-2]
342 } elseif {$tag == "committer"} {
343 set comdate [lindex $line end-1]
344 set comname [lrange $line 1 end-2]
347 set headline {}
348 # take the first non-blank line of the comment as the headline
349 set headline [string trimleft $comment]
350 set i [string first "\n" $headline]
351 if {$i >= 0} {
352 set headline [string range $headline 0 $i]
354 set headline [string trimright $headline]
355 set i [string first "\r" $headline]
356 if {$i >= 0} {
357 set headline [string trimright [string range $headline 0 $i]]
359 if {!$listed} {
360 # git rev-list indents the comment by 4 spaces;
361 # if we got this via git cat-file, add the indentation
362 set newcomment {}
363 foreach line [split $comment "\n"] {
364 append newcomment " "
365 append newcomment $line
366 append newcomment "\n"
368 set comment $newcomment
370 if {$comdate != {}} {
371 set cdate($id) $comdate
373 set commitinfo($id) [list $headline $auname $audate \
374 $comname $comdate $comment]
377 proc getcommit {id} {
378 global commitdata commitinfo
380 if {[info exists commitdata($id)]} {
381 parsecommit $id $commitdata($id) 1
382 } else {
383 readcommit $id
384 if {![info exists commitinfo($id)]} {
385 set commitinfo($id) {"No commit information available"}
388 return 1
391 proc readrefs {} {
392 global tagids idtags headids idheads tagobjid
393 global otherrefids idotherrefs mainhead mainheadid
395 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
396 catch {unset $v}
398 set refd [open [list | git show-ref -d] r]
399 while {[gets $refd line] >= 0} {
400 if {[string index $line 40] ne " "} continue
401 set id [string range $line 0 39]
402 set ref [string range $line 41 end]
403 if {![string match "refs/*" $ref]} continue
404 set name [string range $ref 5 end]
405 if {[string match "remotes/*" $name]} {
406 if {![string match "*/HEAD" $name]} {
407 set headids($name) $id
408 lappend idheads($id) $name
410 } elseif {[string match "heads/*" $name]} {
411 set name [string range $name 6 end]
412 set headids($name) $id
413 lappend idheads($id) $name
414 } elseif {[string match "tags/*" $name]} {
415 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
416 # which is what we want since the former is the commit ID
417 set name [string range $name 5 end]
418 if {[string match "*^{}" $name]} {
419 set name [string range $name 0 end-3]
420 } else {
421 set tagobjid($name) $id
423 set tagids($name) $id
424 lappend idtags($id) $name
425 } else {
426 set otherrefids($name) $id
427 lappend idotherrefs($id) $name
430 close $refd
431 set mainhead {}
432 set mainheadid {}
433 catch {
434 set thehead [exec git symbolic-ref HEAD]
435 if {[string match "refs/heads/*" $thehead]} {
436 set mainhead [string range $thehead 11 end]
437 if {[info exists headids($mainhead)]} {
438 set mainheadid $headids($mainhead)
444 # skip over fake commits
445 proc first_real_row {} {
446 global nullid nullid2 displayorder numcommits
448 for {set row 0} {$row < $numcommits} {incr row} {
449 set id [lindex $displayorder $row]
450 if {$id ne $nullid && $id ne $nullid2} {
451 break
454 return $row
457 # update things for a head moved to a child of its previous location
458 proc movehead {id name} {
459 global headids idheads
461 removehead $headids($name) $name
462 set headids($name) $id
463 lappend idheads($id) $name
466 # update things when a head has been removed
467 proc removehead {id name} {
468 global headids idheads
470 if {$idheads($id) eq $name} {
471 unset idheads($id)
472 } else {
473 set i [lsearch -exact $idheads($id) $name]
474 if {$i >= 0} {
475 set idheads($id) [lreplace $idheads($id) $i $i]
478 unset headids($name)
481 proc show_error {w top msg} {
482 message $w.m -text $msg -justify center -aspect 400
483 pack $w.m -side top -fill x -padx 20 -pady 20
484 button $w.ok -text OK -command "destroy $top"
485 pack $w.ok -side bottom -fill x
486 bind $top <Visibility> "grab $top; focus $top"
487 bind $top <Key-Return> "destroy $top"
488 tkwait window $top
491 proc error_popup msg {
492 set w .error
493 toplevel $w
494 wm transient $w .
495 show_error $w $w $msg
498 proc confirm_popup msg {
499 global confirm_ok
500 set confirm_ok 0
501 set w .confirm
502 toplevel $w
503 wm transient $w .
504 message $w.m -text $msg -justify center -aspect 400
505 pack $w.m -side top -fill x -padx 20 -pady 20
506 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
507 pack $w.ok -side left -fill x
508 button $w.cancel -text Cancel -command "destroy $w"
509 pack $w.cancel -side right -fill x
510 bind $w <Visibility> "grab $w; focus $w"
511 tkwait window $w
512 return $confirm_ok
515 proc makewindow {} {
516 global canv canv2 canv3 linespc charspc ctext cflist
517 global textfont mainfont uifont tabstop
518 global findtype findtypemenu findloc findstring fstring geometry
519 global entries sha1entry sha1string sha1but
520 global maincursor textcursor curtextcursor
521 global rowctxmenu fakerowmenu mergemax wrapcomment
522 global highlight_files gdttype
523 global searchstring sstring
524 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
525 global headctxmenu
527 menu .bar
528 .bar add cascade -label "File" -menu .bar.file
529 .bar configure -font $uifont
530 menu .bar.file
531 .bar.file add command -label "Update" -command updatecommits
532 .bar.file add command -label "Reread references" -command rereadrefs
533 .bar.file add command -label "Quit" -command doquit
534 .bar.file configure -font $uifont
535 menu .bar.edit
536 .bar add cascade -label "Edit" -menu .bar.edit
537 .bar.edit add command -label "Preferences" -command doprefs
538 .bar.edit configure -font $uifont
540 menu .bar.view -font $uifont
541 .bar add cascade -label "View" -menu .bar.view
542 .bar.view add command -label "New view..." -command {newview 0}
543 .bar.view add command -label "Edit view..." -command editview \
544 -state disabled
545 .bar.view add command -label "Delete view" -command delview -state disabled
546 .bar.view add separator
547 .bar.view add radiobutton -label "All files" -command {showview 0} \
548 -variable selectedview -value 0
550 menu .bar.help
551 .bar add cascade -label "Help" -menu .bar.help
552 .bar.help add command -label "About gitk" -command about
553 .bar.help add command -label "Key bindings" -command keys
554 .bar.help configure -font $uifont
555 . configure -menu .bar
557 # the gui has upper and lower half, parts of a paned window.
558 panedwindow .ctop -orient vertical
560 # possibly use assumed geometry
561 if {![info exists geometry(pwsash0)]} {
562 set geometry(topheight) [expr {15 * $linespc}]
563 set geometry(topwidth) [expr {80 * $charspc}]
564 set geometry(botheight) [expr {15 * $linespc}]
565 set geometry(botwidth) [expr {50 * $charspc}]
566 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
567 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
570 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
571 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
572 frame .tf.histframe
573 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
575 # create three canvases
576 set cscroll .tf.histframe.csb
577 set canv .tf.histframe.pwclist.canv
578 canvas $canv \
579 -selectbackground $selectbgcolor \
580 -background $bgcolor -bd 0 \
581 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
582 .tf.histframe.pwclist add $canv
583 set canv2 .tf.histframe.pwclist.canv2
584 canvas $canv2 \
585 -selectbackground $selectbgcolor \
586 -background $bgcolor -bd 0 -yscrollincr $linespc
587 .tf.histframe.pwclist add $canv2
588 set canv3 .tf.histframe.pwclist.canv3
589 canvas $canv3 \
590 -selectbackground $selectbgcolor \
591 -background $bgcolor -bd 0 -yscrollincr $linespc
592 .tf.histframe.pwclist add $canv3
593 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
594 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
596 # a scroll bar to rule them
597 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
598 pack $cscroll -side right -fill y
599 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
600 lappend bglist $canv $canv2 $canv3
601 pack .tf.histframe.pwclist -fill both -expand 1 -side left
603 # we have two button bars at bottom of top frame. Bar 1
604 frame .tf.bar
605 frame .tf.lbar -height 15
607 set sha1entry .tf.bar.sha1
608 set entries $sha1entry
609 set sha1but .tf.bar.sha1label
610 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
611 -command gotocommit -width 8 -font $uifont
612 $sha1but conf -disabledforeground [$sha1but cget -foreground]
613 pack .tf.bar.sha1label -side left
614 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
615 trace add variable sha1string write sha1change
616 pack $sha1entry -side left -pady 2
618 image create bitmap bm-left -data {
619 #define left_width 16
620 #define left_height 16
621 static unsigned char left_bits[] = {
622 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
623 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
624 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
626 image create bitmap bm-right -data {
627 #define right_width 16
628 #define right_height 16
629 static unsigned char right_bits[] = {
630 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
631 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
632 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
634 button .tf.bar.leftbut -image bm-left -command goback \
635 -state disabled -width 26
636 pack .tf.bar.leftbut -side left -fill y
637 button .tf.bar.rightbut -image bm-right -command goforw \
638 -state disabled -width 26
639 pack .tf.bar.rightbut -side left -fill y
641 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
642 pack .tf.bar.findbut -side left
643 set findstring {}
644 set fstring .tf.bar.findstring
645 lappend entries $fstring
646 entry $fstring -width 30 -font $textfont -textvariable findstring
647 trace add variable findstring write find_change
648 pack $fstring -side left -expand 1 -fill x -in .tf.bar
649 set findtype Exact
650 set findtypemenu [tk_optionMenu .tf.bar.findtype \
651 findtype Exact IgnCase Regexp]
652 trace add variable findtype write find_change
653 .tf.bar.findtype configure -font $uifont
654 .tf.bar.findtype.menu configure -font $uifont
655 set findloc "All fields"
656 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
657 Comments Author Committer
658 trace add variable findloc write find_change
659 .tf.bar.findloc configure -font $uifont
660 .tf.bar.findloc.menu configure -font $uifont
661 pack .tf.bar.findloc -side right
662 pack .tf.bar.findtype -side right
664 # build up the bottom bar of upper window
665 label .tf.lbar.flabel -text "Highlight: Commits " \
666 -font $uifont
667 pack .tf.lbar.flabel -side left -fill y
668 set gdttype "touching paths:"
669 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
670 "adding/removing string:"]
671 trace add variable gdttype write hfiles_change
672 $gm conf -font $uifont
673 .tf.lbar.gdttype conf -font $uifont
674 pack .tf.lbar.gdttype -side left -fill y
675 entry .tf.lbar.fent -width 25 -font $textfont \
676 -textvariable highlight_files
677 trace add variable highlight_files write hfiles_change
678 lappend entries .tf.lbar.fent
679 pack .tf.lbar.fent -side left -fill x -expand 1
680 label .tf.lbar.vlabel -text " OR in view" -font $uifont
681 pack .tf.lbar.vlabel -side left -fill y
682 global viewhlmenu selectedhlview
683 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
684 $viewhlmenu entryconf None -command delvhighlight
685 $viewhlmenu conf -font $uifont
686 .tf.lbar.vhl conf -font $uifont
687 pack .tf.lbar.vhl -side left -fill y
688 label .tf.lbar.rlabel -text " OR " -font $uifont
689 pack .tf.lbar.rlabel -side left -fill y
690 global highlight_related
691 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
692 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
693 $m conf -font $uifont
694 .tf.lbar.relm conf -font $uifont
695 trace add variable highlight_related write vrel_change
696 pack .tf.lbar.relm -side left -fill y
698 # Finish putting the upper half of the viewer together
699 pack .tf.lbar -in .tf -side bottom -fill x
700 pack .tf.bar -in .tf -side bottom -fill x
701 pack .tf.histframe -fill both -side top -expand 1
702 .ctop add .tf
703 .ctop paneconfigure .tf -height $geometry(topheight)
704 .ctop paneconfigure .tf -width $geometry(topwidth)
706 # now build up the bottom
707 panedwindow .pwbottom -orient horizontal
709 # lower left, a text box over search bar, scroll bar to the right
710 # if we know window height, then that will set the lower text height, otherwise
711 # we set lower text height which will drive window height
712 if {[info exists geometry(main)]} {
713 frame .bleft -width $geometry(botwidth)
714 } else {
715 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
717 frame .bleft.top
718 frame .bleft.mid
720 button .bleft.top.search -text "Search" -command dosearch \
721 -font $uifont
722 pack .bleft.top.search -side left -padx 5
723 set sstring .bleft.top.sstring
724 entry $sstring -width 20 -font $textfont -textvariable searchstring
725 lappend entries $sstring
726 trace add variable searchstring write incrsearch
727 pack $sstring -side left -expand 1 -fill x
728 radiobutton .bleft.mid.diff -text "Diff" \
729 -command changediffdisp -variable diffelide -value {0 0}
730 radiobutton .bleft.mid.old -text "Old version" \
731 -command changediffdisp -variable diffelide -value {0 1}
732 radiobutton .bleft.mid.new -text "New version" \
733 -command changediffdisp -variable diffelide -value {1 0}
734 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
735 set ctext .bleft.ctext
736 text $ctext -background $bgcolor -foreground $fgcolor \
737 -tabs "[expr {$tabstop * $charspc}]" \
738 -state disabled -font $textfont \
739 -yscrollcommand scrolltext -wrap none
740 scrollbar .bleft.sb -command "$ctext yview"
741 pack .bleft.top -side top -fill x
742 pack .bleft.mid -side top -fill x
743 pack .bleft.sb -side right -fill y
744 pack $ctext -side left -fill both -expand 1
745 lappend bglist $ctext
746 lappend fglist $ctext
748 $ctext tag conf comment -wrap $wrapcomment
749 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
750 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
751 $ctext tag conf d0 -fore [lindex $diffcolors 0]
752 $ctext tag conf d1 -fore [lindex $diffcolors 1]
753 $ctext tag conf m0 -fore red
754 $ctext tag conf m1 -fore blue
755 $ctext tag conf m2 -fore green
756 $ctext tag conf m3 -fore purple
757 $ctext tag conf m4 -fore brown
758 $ctext tag conf m5 -fore "#009090"
759 $ctext tag conf m6 -fore magenta
760 $ctext tag conf m7 -fore "#808000"
761 $ctext tag conf m8 -fore "#009000"
762 $ctext tag conf m9 -fore "#ff0080"
763 $ctext tag conf m10 -fore cyan
764 $ctext tag conf m11 -fore "#b07070"
765 $ctext tag conf m12 -fore "#70b0f0"
766 $ctext tag conf m13 -fore "#70f0b0"
767 $ctext tag conf m14 -fore "#f0b070"
768 $ctext tag conf m15 -fore "#ff70b0"
769 $ctext tag conf mmax -fore darkgrey
770 set mergemax 16
771 $ctext tag conf mresult -font [concat $textfont bold]
772 $ctext tag conf msep -font [concat $textfont bold]
773 $ctext tag conf found -back yellow
775 .pwbottom add .bleft
776 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
778 # lower right
779 frame .bright
780 frame .bright.mode
781 radiobutton .bright.mode.patch -text "Patch" \
782 -command reselectline -variable cmitmode -value "patch"
783 .bright.mode.patch configure -font $uifont
784 radiobutton .bright.mode.tree -text "Tree" \
785 -command reselectline -variable cmitmode -value "tree"
786 .bright.mode.tree configure -font $uifont
787 grid .bright.mode.patch .bright.mode.tree -sticky ew
788 pack .bright.mode -side top -fill x
789 set cflist .bright.cfiles
790 set indent [font measure $mainfont "nn"]
791 text $cflist \
792 -selectbackground $selectbgcolor \
793 -background $bgcolor -foreground $fgcolor \
794 -font $mainfont \
795 -tabs [list $indent [expr {2 * $indent}]] \
796 -yscrollcommand ".bright.sb set" \
797 -cursor [. cget -cursor] \
798 -spacing1 1 -spacing3 1
799 lappend bglist $cflist
800 lappend fglist $cflist
801 scrollbar .bright.sb -command "$cflist yview"
802 pack .bright.sb -side right -fill y
803 pack $cflist -side left -fill both -expand 1
804 $cflist tag configure highlight \
805 -background [$cflist cget -selectbackground]
806 $cflist tag configure bold -font [concat $mainfont bold]
808 .pwbottom add .bright
809 .ctop add .pwbottom
811 # restore window position if known
812 if {[info exists geometry(main)]} {
813 wm geometry . "$geometry(main)"
816 if {[tk windowingsystem] eq {aqua}} {
817 set M1B M1
818 } else {
819 set M1B Control
822 bind .pwbottom <Configure> {resizecdetpanes %W %w}
823 pack .ctop -fill both -expand 1
824 bindall <1> {selcanvline %W %x %y}
825 #bindall <B1-Motion> {selcanvline %W %x %y}
826 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
827 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
828 bindall <2> "canvscan mark %W %x %y"
829 bindall <B2-Motion> "canvscan dragto %W %x %y"
830 bindkey <Home> selfirstline
831 bindkey <End> sellastline
832 bind . <Key-Up> "selnextline -1"
833 bind . <Key-Down> "selnextline 1"
834 bind . <Shift-Key-Up> "next_highlight -1"
835 bind . <Shift-Key-Down> "next_highlight 1"
836 bindkey <Key-Right> "goforw"
837 bindkey <Key-Left> "goback"
838 bind . <Key-Prior> "selnextpage -1"
839 bind . <Key-Next> "selnextpage 1"
840 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
841 bind . <$M1B-End> "allcanvs yview moveto 1.0"
842 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
843 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
844 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
845 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
846 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
847 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
848 bindkey <Key-space> "$ctext yview scroll 1 pages"
849 bindkey p "selnextline -1"
850 bindkey n "selnextline 1"
851 bindkey z "goback"
852 bindkey x "goforw"
853 bindkey i "selnextline -1"
854 bindkey k "selnextline 1"
855 bindkey j "goback"
856 bindkey l "goforw"
857 bindkey b "$ctext yview scroll -1 pages"
858 bindkey d "$ctext yview scroll 18 units"
859 bindkey u "$ctext yview scroll -18 units"
860 bindkey / {findnext 1}
861 bindkey <Key-Return> {findnext 0}
862 bindkey ? findprev
863 bindkey f nextfile
864 bindkey <F5> updatecommits
865 bind . <$M1B-q> doquit
866 bind . <$M1B-f> dofind
867 bind . <$M1B-g> {findnext 0}
868 bind . <$M1B-r> dosearchback
869 bind . <$M1B-s> dosearch
870 bind . <$M1B-equal> {incrfont 1}
871 bind . <$M1B-KP_Add> {incrfont 1}
872 bind . <$M1B-minus> {incrfont -1}
873 bind . <$M1B-KP_Subtract> {incrfont -1}
874 wm protocol . WM_DELETE_WINDOW doquit
875 bind . <Button-1> "click %W"
876 bind $fstring <Key-Return> dofind
877 bind $sha1entry <Key-Return> gotocommit
878 bind $sha1entry <<PasteSelection>> clearsha1
879 bind $cflist <1> {sel_flist %W %x %y; break}
880 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
881 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
882 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
884 set maincursor [. cget -cursor]
885 set textcursor [$ctext cget -cursor]
886 set curtextcursor $textcursor
888 set rowctxmenu .rowctxmenu
889 menu $rowctxmenu -tearoff 0
890 $rowctxmenu add command -label "Diff this -> selected" \
891 -command {diffvssel 0}
892 $rowctxmenu add command -label "Diff selected -> this" \
893 -command {diffvssel 1}
894 $rowctxmenu add command -label "Make patch" -command mkpatch
895 $rowctxmenu add command -label "Create tag" -command mktag
896 $rowctxmenu add command -label "Write commit to file" -command writecommit
897 $rowctxmenu add command -label "Create new branch" -command mkbranch
898 $rowctxmenu add command -label "Cherry-pick this commit" \
899 -command cherrypick
900 $rowctxmenu add command -label "Reset HEAD branch to here" \
901 -command resethead
903 set fakerowmenu .fakerowmenu
904 menu $fakerowmenu -tearoff 0
905 $fakerowmenu add command -label "Diff this -> selected" \
906 -command {diffvssel 0}
907 $fakerowmenu add command -label "Diff selected -> this" \
908 -command {diffvssel 1}
909 $fakerowmenu add command -label "Make patch" -command mkpatch
910 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
911 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
912 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
914 set headctxmenu .headctxmenu
915 menu $headctxmenu -tearoff 0
916 $headctxmenu add command -label "Check out this branch" \
917 -command cobranch
918 $headctxmenu add command -label "Remove this branch" \
919 -command rmbranch
921 global flist_menu
922 set flist_menu .flistctxmenu
923 menu $flist_menu -tearoff 0
924 $flist_menu add command -label "Highlight this too" \
925 -command {flist_hl 0}
926 $flist_menu add command -label "Highlight this only" \
927 -command {flist_hl 1}
930 # mouse-2 makes all windows scan vertically, but only the one
931 # the cursor is in scans horizontally
932 proc canvscan {op w x y} {
933 global canv canv2 canv3
934 foreach c [list $canv $canv2 $canv3] {
935 if {$c == $w} {
936 $c scan $op $x $y
937 } else {
938 $c scan $op 0 $y
943 proc scrollcanv {cscroll f0 f1} {
944 $cscroll set $f0 $f1
945 drawfrac $f0 $f1
946 flushhighlights
949 # when we make a key binding for the toplevel, make sure
950 # it doesn't get triggered when that key is pressed in the
951 # find string entry widget.
952 proc bindkey {ev script} {
953 global entries
954 bind . $ev $script
955 set escript [bind Entry $ev]
956 if {$escript == {}} {
957 set escript [bind Entry <Key>]
959 foreach e $entries {
960 bind $e $ev "$escript; break"
964 # set the focus back to the toplevel for any click outside
965 # the entry widgets
966 proc click {w} {
967 global entries
968 foreach e $entries {
969 if {$w == $e} return
971 focus .
974 proc savestuff {w} {
975 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
976 global stuffsaved findmergefiles maxgraphpct
977 global maxwidth showneartags showlocalchanges
978 global viewname viewfiles viewargs viewperm nextviewnum
979 global cmitmode wrapcomment
980 global colors bgcolor fgcolor diffcolors selectbgcolor
982 if {$stuffsaved} return
983 if {![winfo viewable .]} return
984 catch {
985 set f [open "~/.gitk-new" w]
986 puts $f [list set mainfont $mainfont]
987 puts $f [list set textfont $textfont]
988 puts $f [list set uifont $uifont]
989 puts $f [list set tabstop $tabstop]
990 puts $f [list set findmergefiles $findmergefiles]
991 puts $f [list set maxgraphpct $maxgraphpct]
992 puts $f [list set maxwidth $maxwidth]
993 puts $f [list set cmitmode $cmitmode]
994 puts $f [list set wrapcomment $wrapcomment]
995 puts $f [list set showneartags $showneartags]
996 puts $f [list set showlocalchanges $showlocalchanges]
997 puts $f [list set bgcolor $bgcolor]
998 puts $f [list set fgcolor $fgcolor]
999 puts $f [list set colors $colors]
1000 puts $f [list set diffcolors $diffcolors]
1001 puts $f [list set selectbgcolor $selectbgcolor]
1003 puts $f "set geometry(main) [wm geometry .]"
1004 puts $f "set geometry(topwidth) [winfo width .tf]"
1005 puts $f "set geometry(topheight) [winfo height .tf]"
1006 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1007 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1008 puts $f "set geometry(botwidth) [winfo width .bleft]"
1009 puts $f "set geometry(botheight) [winfo height .bleft]"
1011 puts -nonewline $f "set permviews {"
1012 for {set v 0} {$v < $nextviewnum} {incr v} {
1013 if {$viewperm($v)} {
1014 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1017 puts $f "}"
1018 close $f
1019 file rename -force "~/.gitk-new" "~/.gitk"
1021 set stuffsaved 1
1024 proc resizeclistpanes {win w} {
1025 global oldwidth
1026 if {[info exists oldwidth($win)]} {
1027 set s0 [$win sash coord 0]
1028 set s1 [$win sash coord 1]
1029 if {$w < 60} {
1030 set sash0 [expr {int($w/2 - 2)}]
1031 set sash1 [expr {int($w*5/6 - 2)}]
1032 } else {
1033 set factor [expr {1.0 * $w / $oldwidth($win)}]
1034 set sash0 [expr {int($factor * [lindex $s0 0])}]
1035 set sash1 [expr {int($factor * [lindex $s1 0])}]
1036 if {$sash0 < 30} {
1037 set sash0 30
1039 if {$sash1 < $sash0 + 20} {
1040 set sash1 [expr {$sash0 + 20}]
1042 if {$sash1 > $w - 10} {
1043 set sash1 [expr {$w - 10}]
1044 if {$sash0 > $sash1 - 20} {
1045 set sash0 [expr {$sash1 - 20}]
1049 $win sash place 0 $sash0 [lindex $s0 1]
1050 $win sash place 1 $sash1 [lindex $s1 1]
1052 set oldwidth($win) $w
1055 proc resizecdetpanes {win w} {
1056 global oldwidth
1057 if {[info exists oldwidth($win)]} {
1058 set s0 [$win sash coord 0]
1059 if {$w < 60} {
1060 set sash0 [expr {int($w*3/4 - 2)}]
1061 } else {
1062 set factor [expr {1.0 * $w / $oldwidth($win)}]
1063 set sash0 [expr {int($factor * [lindex $s0 0])}]
1064 if {$sash0 < 45} {
1065 set sash0 45
1067 if {$sash0 > $w - 15} {
1068 set sash0 [expr {$w - 15}]
1071 $win sash place 0 $sash0 [lindex $s0 1]
1073 set oldwidth($win) $w
1076 proc allcanvs args {
1077 global canv canv2 canv3
1078 eval $canv $args
1079 eval $canv2 $args
1080 eval $canv3 $args
1083 proc bindall {event action} {
1084 global canv canv2 canv3
1085 bind $canv $event $action
1086 bind $canv2 $event $action
1087 bind $canv3 $event $action
1090 proc about {} {
1091 global uifont
1092 set w .about
1093 if {[winfo exists $w]} {
1094 raise $w
1095 return
1097 toplevel $w
1098 wm title $w "About gitk"
1099 message $w.m -text {
1100 Gitk - a commit viewer for git
1102 Copyright © 2005-2006 Paul Mackerras
1104 Use and redistribute under the terms of the GNU General Public License} \
1105 -justify center -aspect 400 -border 2 -bg white -relief groove
1106 pack $w.m -side top -fill x -padx 2 -pady 2
1107 $w.m configure -font $uifont
1108 button $w.ok -text Close -command "destroy $w" -default active
1109 pack $w.ok -side bottom
1110 $w.ok configure -font $uifont
1111 bind $w <Visibility> "focus $w.ok"
1112 bind $w <Key-Escape> "destroy $w"
1113 bind $w <Key-Return> "destroy $w"
1116 proc keys {} {
1117 global uifont
1118 set w .keys
1119 if {[winfo exists $w]} {
1120 raise $w
1121 return
1123 if {[tk windowingsystem] eq {aqua}} {
1124 set M1T Cmd
1125 } else {
1126 set M1T Ctrl
1128 toplevel $w
1129 wm title $w "Gitk key bindings"
1130 message $w.m -text "
1131 Gitk key bindings:
1133 <$M1T-Q> Quit
1134 <Home> Move to first commit
1135 <End> Move to last commit
1136 <Up>, p, i Move up one commit
1137 <Down>, n, k Move down one commit
1138 <Left>, z, j Go back in history list
1139 <Right>, x, l Go forward in history list
1140 <PageUp> Move up one page in commit list
1141 <PageDown> Move down one page in commit list
1142 <$M1T-Home> Scroll to top of commit list
1143 <$M1T-End> Scroll to bottom of commit list
1144 <$M1T-Up> Scroll commit list up one line
1145 <$M1T-Down> Scroll commit list down one line
1146 <$M1T-PageUp> Scroll commit list up one page
1147 <$M1T-PageDown> Scroll commit list down one page
1148 <Shift-Up> Move to previous highlighted line
1149 <Shift-Down> Move to next highlighted line
1150 <Delete>, b Scroll diff view up one page
1151 <Backspace> Scroll diff view up one page
1152 <Space> Scroll diff view down one page
1153 u Scroll diff view up 18 lines
1154 d Scroll diff view down 18 lines
1155 <$M1T-F> Find
1156 <$M1T-G> Move to next find hit
1157 <Return> Move to next find hit
1158 / Move to next find hit, or redo find
1159 ? Move to previous find hit
1160 f Scroll diff view to next file
1161 <$M1T-S> Search for next hit in diff view
1162 <$M1T-R> Search for previous hit in diff view
1163 <$M1T-KP+> Increase font size
1164 <$M1T-plus> Increase font size
1165 <$M1T-KP-> Decrease font size
1166 <$M1T-minus> Decrease font size
1167 <F5> Update
1169 -justify left -bg white -border 2 -relief groove
1170 pack $w.m -side top -fill both -padx 2 -pady 2
1171 $w.m configure -font $uifont
1172 button $w.ok -text Close -command "destroy $w" -default active
1173 pack $w.ok -side bottom
1174 $w.ok configure -font $uifont
1175 bind $w <Visibility> "focus $w.ok"
1176 bind $w <Key-Escape> "destroy $w"
1177 bind $w <Key-Return> "destroy $w"
1180 # Procedures for manipulating the file list window at the
1181 # bottom right of the overall window.
1183 proc treeview {w l openlevs} {
1184 global treecontents treediropen treeheight treeparent treeindex
1186 set ix 0
1187 set treeindex() 0
1188 set lev 0
1189 set prefix {}
1190 set prefixend -1
1191 set prefendstack {}
1192 set htstack {}
1193 set ht 0
1194 set treecontents() {}
1195 $w conf -state normal
1196 foreach f $l {
1197 while {[string range $f 0 $prefixend] ne $prefix} {
1198 if {$lev <= $openlevs} {
1199 $w mark set e:$treeindex($prefix) "end -1c"
1200 $w mark gravity e:$treeindex($prefix) left
1202 set treeheight($prefix) $ht
1203 incr ht [lindex $htstack end]
1204 set htstack [lreplace $htstack end end]
1205 set prefixend [lindex $prefendstack end]
1206 set prefendstack [lreplace $prefendstack end end]
1207 set prefix [string range $prefix 0 $prefixend]
1208 incr lev -1
1210 set tail [string range $f [expr {$prefixend+1}] end]
1211 while {[set slash [string first "/" $tail]] >= 0} {
1212 lappend htstack $ht
1213 set ht 0
1214 lappend prefendstack $prefixend
1215 incr prefixend [expr {$slash + 1}]
1216 set d [string range $tail 0 $slash]
1217 lappend treecontents($prefix) $d
1218 set oldprefix $prefix
1219 append prefix $d
1220 set treecontents($prefix) {}
1221 set treeindex($prefix) [incr ix]
1222 set treeparent($prefix) $oldprefix
1223 set tail [string range $tail [expr {$slash+1}] end]
1224 if {$lev <= $openlevs} {
1225 set ht 1
1226 set treediropen($prefix) [expr {$lev < $openlevs}]
1227 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1228 $w mark set d:$ix "end -1c"
1229 $w mark gravity d:$ix left
1230 set str "\n"
1231 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1232 $w insert end $str
1233 $w image create end -align center -image $bm -padx 1 \
1234 -name a:$ix
1235 $w insert end $d [highlight_tag $prefix]
1236 $w mark set s:$ix "end -1c"
1237 $w mark gravity s:$ix left
1239 incr lev
1241 if {$tail ne {}} {
1242 if {$lev <= $openlevs} {
1243 incr ht
1244 set str "\n"
1245 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1246 $w insert end $str
1247 $w insert end $tail [highlight_tag $f]
1249 lappend treecontents($prefix) $tail
1252 while {$htstack ne {}} {
1253 set treeheight($prefix) $ht
1254 incr ht [lindex $htstack end]
1255 set htstack [lreplace $htstack end end]
1256 set prefixend [lindex $prefendstack end]
1257 set prefendstack [lreplace $prefendstack end end]
1258 set prefix [string range $prefix 0 $prefixend]
1260 $w conf -state disabled
1263 proc linetoelt {l} {
1264 global treeheight treecontents
1266 set y 2
1267 set prefix {}
1268 while {1} {
1269 foreach e $treecontents($prefix) {
1270 if {$y == $l} {
1271 return "$prefix$e"
1273 set n 1
1274 if {[string index $e end] eq "/"} {
1275 set n $treeheight($prefix$e)
1276 if {$y + $n > $l} {
1277 append prefix $e
1278 incr y
1279 break
1282 incr y $n
1287 proc highlight_tree {y prefix} {
1288 global treeheight treecontents cflist
1290 foreach e $treecontents($prefix) {
1291 set path $prefix$e
1292 if {[highlight_tag $path] ne {}} {
1293 $cflist tag add bold $y.0 "$y.0 lineend"
1295 incr y
1296 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1297 set y [highlight_tree $y $path]
1300 return $y
1303 proc treeclosedir {w dir} {
1304 global treediropen treeheight treeparent treeindex
1306 set ix $treeindex($dir)
1307 $w conf -state normal
1308 $w delete s:$ix e:$ix
1309 set treediropen($dir) 0
1310 $w image configure a:$ix -image tri-rt
1311 $w conf -state disabled
1312 set n [expr {1 - $treeheight($dir)}]
1313 while {$dir ne {}} {
1314 incr treeheight($dir) $n
1315 set dir $treeparent($dir)
1319 proc treeopendir {w dir} {
1320 global treediropen treeheight treeparent treecontents treeindex
1322 set ix $treeindex($dir)
1323 $w conf -state normal
1324 $w image configure a:$ix -image tri-dn
1325 $w mark set e:$ix s:$ix
1326 $w mark gravity e:$ix right
1327 set lev 0
1328 set str "\n"
1329 set n [llength $treecontents($dir)]
1330 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1331 incr lev
1332 append str "\t"
1333 incr treeheight($x) $n
1335 foreach e $treecontents($dir) {
1336 set de $dir$e
1337 if {[string index $e end] eq "/"} {
1338 set iy $treeindex($de)
1339 $w mark set d:$iy e:$ix
1340 $w mark gravity d:$iy left
1341 $w insert e:$ix $str
1342 set treediropen($de) 0
1343 $w image create e:$ix -align center -image tri-rt -padx 1 \
1344 -name a:$iy
1345 $w insert e:$ix $e [highlight_tag $de]
1346 $w mark set s:$iy e:$ix
1347 $w mark gravity s:$iy left
1348 set treeheight($de) 1
1349 } else {
1350 $w insert e:$ix $str
1351 $w insert e:$ix $e [highlight_tag $de]
1354 $w mark gravity e:$ix left
1355 $w conf -state disabled
1356 set treediropen($dir) 1
1357 set top [lindex [split [$w index @0,0] .] 0]
1358 set ht [$w cget -height]
1359 set l [lindex [split [$w index s:$ix] .] 0]
1360 if {$l < $top} {
1361 $w yview $l.0
1362 } elseif {$l + $n + 1 > $top + $ht} {
1363 set top [expr {$l + $n + 2 - $ht}]
1364 if {$l < $top} {
1365 set top $l
1367 $w yview $top.0
1371 proc treeclick {w x y} {
1372 global treediropen cmitmode ctext cflist cflist_top
1374 if {$cmitmode ne "tree"} return
1375 if {![info exists cflist_top]} return
1376 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1377 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1378 $cflist tag add highlight $l.0 "$l.0 lineend"
1379 set cflist_top $l
1380 if {$l == 1} {
1381 $ctext yview 1.0
1382 return
1384 set e [linetoelt $l]
1385 if {[string index $e end] ne "/"} {
1386 showfile $e
1387 } elseif {$treediropen($e)} {
1388 treeclosedir $w $e
1389 } else {
1390 treeopendir $w $e
1394 proc setfilelist {id} {
1395 global treefilelist cflist
1397 treeview $cflist $treefilelist($id) 0
1400 image create bitmap tri-rt -background black -foreground blue -data {
1401 #define tri-rt_width 13
1402 #define tri-rt_height 13
1403 static unsigned char tri-rt_bits[] = {
1404 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1405 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1406 0x00, 0x00};
1407 } -maskdata {
1408 #define tri-rt-mask_width 13
1409 #define tri-rt-mask_height 13
1410 static unsigned char tri-rt-mask_bits[] = {
1411 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1412 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1413 0x08, 0x00};
1415 image create bitmap tri-dn -background black -foreground blue -data {
1416 #define tri-dn_width 13
1417 #define tri-dn_height 13
1418 static unsigned char tri-dn_bits[] = {
1419 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1420 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1421 0x00, 0x00};
1422 } -maskdata {
1423 #define tri-dn-mask_width 13
1424 #define tri-dn-mask_height 13
1425 static unsigned char tri-dn-mask_bits[] = {
1426 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1427 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1428 0x00, 0x00};
1431 proc init_flist {first} {
1432 global cflist cflist_top selectedline difffilestart
1434 $cflist conf -state normal
1435 $cflist delete 0.0 end
1436 if {$first ne {}} {
1437 $cflist insert end $first
1438 set cflist_top 1
1439 $cflist tag add highlight 1.0 "1.0 lineend"
1440 } else {
1441 catch {unset cflist_top}
1443 $cflist conf -state disabled
1444 set difffilestart {}
1447 proc highlight_tag {f} {
1448 global highlight_paths
1450 foreach p $highlight_paths {
1451 if {[string match $p $f]} {
1452 return "bold"
1455 return {}
1458 proc highlight_filelist {} {
1459 global cmitmode cflist
1461 $cflist conf -state normal
1462 if {$cmitmode ne "tree"} {
1463 set end [lindex [split [$cflist index end] .] 0]
1464 for {set l 2} {$l < $end} {incr l} {
1465 set line [$cflist get $l.0 "$l.0 lineend"]
1466 if {[highlight_tag $line] ne {}} {
1467 $cflist tag add bold $l.0 "$l.0 lineend"
1470 } else {
1471 highlight_tree 2 {}
1473 $cflist conf -state disabled
1476 proc unhighlight_filelist {} {
1477 global cflist
1479 $cflist conf -state normal
1480 $cflist tag remove bold 1.0 end
1481 $cflist conf -state disabled
1484 proc add_flist {fl} {
1485 global cflist
1487 $cflist conf -state normal
1488 foreach f $fl {
1489 $cflist insert end "\n"
1490 $cflist insert end $f [highlight_tag $f]
1492 $cflist conf -state disabled
1495 proc sel_flist {w x y} {
1496 global ctext difffilestart cflist cflist_top cmitmode
1498 if {$cmitmode eq "tree"} return
1499 if {![info exists cflist_top]} return
1500 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1501 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1502 $cflist tag add highlight $l.0 "$l.0 lineend"
1503 set cflist_top $l
1504 if {$l == 1} {
1505 $ctext yview 1.0
1506 } else {
1507 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1511 proc pop_flist_menu {w X Y x y} {
1512 global ctext cflist cmitmode flist_menu flist_menu_file
1513 global treediffs diffids
1515 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1516 if {$l <= 1} return
1517 if {$cmitmode eq "tree"} {
1518 set e [linetoelt $l]
1519 if {[string index $e end] eq "/"} return
1520 } else {
1521 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1523 set flist_menu_file $e
1524 tk_popup $flist_menu $X $Y
1527 proc flist_hl {only} {
1528 global flist_menu_file highlight_files
1530 set x [shellquote $flist_menu_file]
1531 if {$only || $highlight_files eq {}} {
1532 set highlight_files $x
1533 } else {
1534 append highlight_files " " $x
1538 # Functions for adding and removing shell-type quoting
1540 proc shellquote {str} {
1541 if {![string match "*\['\"\\ \t]*" $str]} {
1542 return $str
1544 if {![string match "*\['\"\\]*" $str]} {
1545 return "\"$str\""
1547 if {![string match "*'*" $str]} {
1548 return "'$str'"
1550 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1553 proc shellarglist {l} {
1554 set str {}
1555 foreach a $l {
1556 if {$str ne {}} {
1557 append str " "
1559 append str [shellquote $a]
1561 return $str
1564 proc shelldequote {str} {
1565 set ret {}
1566 set used -1
1567 while {1} {
1568 incr used
1569 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1570 append ret [string range $str $used end]
1571 set used [string length $str]
1572 break
1574 set first [lindex $first 0]
1575 set ch [string index $str $first]
1576 if {$first > $used} {
1577 append ret [string range $str $used [expr {$first - 1}]]
1578 set used $first
1580 if {$ch eq " " || $ch eq "\t"} break
1581 incr used
1582 if {$ch eq "'"} {
1583 set first [string first "'" $str $used]
1584 if {$first < 0} {
1585 error "unmatched single-quote"
1587 append ret [string range $str $used [expr {$first - 1}]]
1588 set used $first
1589 continue
1591 if {$ch eq "\\"} {
1592 if {$used >= [string length $str]} {
1593 error "trailing backslash"
1595 append ret [string index $str $used]
1596 continue
1598 # here ch == "\""
1599 while {1} {
1600 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1601 error "unmatched double-quote"
1603 set first [lindex $first 0]
1604 set ch [string index $str $first]
1605 if {$first > $used} {
1606 append ret [string range $str $used [expr {$first - 1}]]
1607 set used $first
1609 if {$ch eq "\""} break
1610 incr used
1611 append ret [string index $str $used]
1612 incr used
1615 return [list $used $ret]
1618 proc shellsplit {str} {
1619 set l {}
1620 while {1} {
1621 set str [string trimleft $str]
1622 if {$str eq {}} break
1623 set dq [shelldequote $str]
1624 set n [lindex $dq 0]
1625 set word [lindex $dq 1]
1626 set str [string range $str $n end]
1627 lappend l $word
1629 return $l
1632 # Code to implement multiple views
1634 proc newview {ishighlight} {
1635 global nextviewnum newviewname newviewperm uifont newishighlight
1636 global newviewargs revtreeargs
1638 set newishighlight $ishighlight
1639 set top .gitkview
1640 if {[winfo exists $top]} {
1641 raise $top
1642 return
1644 set newviewname($nextviewnum) "View $nextviewnum"
1645 set newviewperm($nextviewnum) 0
1646 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1647 vieweditor $top $nextviewnum "Gitk view definition"
1650 proc editview {} {
1651 global curview
1652 global viewname viewperm newviewname newviewperm
1653 global viewargs newviewargs
1655 set top .gitkvedit-$curview
1656 if {[winfo exists $top]} {
1657 raise $top
1658 return
1660 set newviewname($curview) $viewname($curview)
1661 set newviewperm($curview) $viewperm($curview)
1662 set newviewargs($curview) [shellarglist $viewargs($curview)]
1663 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1666 proc vieweditor {top n title} {
1667 global newviewname newviewperm viewfiles
1668 global uifont
1670 toplevel $top
1671 wm title $top $title
1672 label $top.nl -text "Name" -font $uifont
1673 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1674 grid $top.nl $top.name -sticky w -pady 5
1675 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1676 -font $uifont
1677 grid $top.perm - -pady 5 -sticky w
1678 message $top.al -aspect 1000 -font $uifont \
1679 -text "Commits to include (arguments to git rev-list):"
1680 grid $top.al - -sticky w -pady 5
1681 entry $top.args -width 50 -textvariable newviewargs($n) \
1682 -background white -font $uifont
1683 grid $top.args - -sticky ew -padx 5
1684 message $top.l -aspect 1000 -font $uifont \
1685 -text "Enter files and directories to include, one per line:"
1686 grid $top.l - -sticky w
1687 text $top.t -width 40 -height 10 -background white -font $uifont
1688 if {[info exists viewfiles($n)]} {
1689 foreach f $viewfiles($n) {
1690 $top.t insert end $f
1691 $top.t insert end "\n"
1693 $top.t delete {end - 1c} end
1694 $top.t mark set insert 0.0
1696 grid $top.t - -sticky ew -padx 5
1697 frame $top.buts
1698 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1699 -font $uifont
1700 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1701 -font $uifont
1702 grid $top.buts.ok $top.buts.can
1703 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1704 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1705 grid $top.buts - -pady 10 -sticky ew
1706 focus $top.t
1709 proc doviewmenu {m first cmd op argv} {
1710 set nmenu [$m index end]
1711 for {set i $first} {$i <= $nmenu} {incr i} {
1712 if {[$m entrycget $i -command] eq $cmd} {
1713 eval $m $op $i $argv
1714 break
1719 proc allviewmenus {n op args} {
1720 global viewhlmenu
1722 doviewmenu .bar.view 5 [list showview $n] $op $args
1723 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1726 proc newviewok {top n} {
1727 global nextviewnum newviewperm newviewname newishighlight
1728 global viewname viewfiles viewperm selectedview curview
1729 global viewargs newviewargs viewhlmenu
1731 if {[catch {
1732 set newargs [shellsplit $newviewargs($n)]
1733 } err]} {
1734 error_popup "Error in commit selection arguments: $err"
1735 wm raise $top
1736 focus $top
1737 return
1739 set files {}
1740 foreach f [split [$top.t get 0.0 end] "\n"] {
1741 set ft [string trim $f]
1742 if {$ft ne {}} {
1743 lappend files $ft
1746 if {![info exists viewfiles($n)]} {
1747 # creating a new view
1748 incr nextviewnum
1749 set viewname($n) $newviewname($n)
1750 set viewperm($n) $newviewperm($n)
1751 set viewfiles($n) $files
1752 set viewargs($n) $newargs
1753 addviewmenu $n
1754 if {!$newishighlight} {
1755 run showview $n
1756 } else {
1757 run addvhighlight $n
1759 } else {
1760 # editing an existing view
1761 set viewperm($n) $newviewperm($n)
1762 if {$newviewname($n) ne $viewname($n)} {
1763 set viewname($n) $newviewname($n)
1764 doviewmenu .bar.view 5 [list showview $n] \
1765 entryconf [list -label $viewname($n)]
1766 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1767 entryconf [list -label $viewname($n) -value $viewname($n)]
1769 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1770 set viewfiles($n) $files
1771 set viewargs($n) $newargs
1772 if {$curview == $n} {
1773 run updatecommits
1777 catch {destroy $top}
1780 proc delview {} {
1781 global curview viewdata viewperm hlview selectedhlview
1783 if {$curview == 0} return
1784 if {[info exists hlview] && $hlview == $curview} {
1785 set selectedhlview None
1786 unset hlview
1788 allviewmenus $curview delete
1789 set viewdata($curview) {}
1790 set viewperm($curview) 0
1791 showview 0
1794 proc addviewmenu {n} {
1795 global viewname viewhlmenu
1797 .bar.view add radiobutton -label $viewname($n) \
1798 -command [list showview $n] -variable selectedview -value $n
1799 $viewhlmenu add radiobutton -label $viewname($n) \
1800 -command [list addvhighlight $n] -variable selectedhlview
1803 proc flatten {var} {
1804 global $var
1806 set ret {}
1807 foreach i [array names $var] {
1808 lappend ret $i [set $var\($i\)]
1810 return $ret
1813 proc unflatten {var l} {
1814 global $var
1816 catch {unset $var}
1817 foreach {i v} $l {
1818 set $var\($i\) $v
1822 proc showview {n} {
1823 global curview viewdata viewfiles
1824 global displayorder parentlist rowidlist rowoffsets
1825 global colormap rowtextx commitrow nextcolor canvxmax
1826 global numcommits rowrangelist commitlisted idrowranges rowchk
1827 global selectedline currentid canv canvy0
1828 global treediffs
1829 global pending_select phase
1830 global commitidx rowlaidout rowoptim
1831 global commfd
1832 global selectedview selectfirst
1833 global vparentlist vdisporder vcmitlisted
1834 global hlview selectedhlview
1836 if {$n == $curview} return
1837 set selid {}
1838 if {[info exists selectedline]} {
1839 set selid $currentid
1840 set y [yc $selectedline]
1841 set ymax [lindex [$canv cget -scrollregion] 3]
1842 set span [$canv yview]
1843 set ytop [expr {[lindex $span 0] * $ymax}]
1844 set ybot [expr {[lindex $span 1] * $ymax}]
1845 if {$ytop < $y && $y < $ybot} {
1846 set yscreen [expr {$y - $ytop}]
1847 } else {
1848 set yscreen [expr {($ybot - $ytop) / 2}]
1850 } elseif {[info exists pending_select]} {
1851 set selid $pending_select
1852 unset pending_select
1854 unselectline
1855 normalline
1856 if {$curview >= 0} {
1857 set vparentlist($curview) $parentlist
1858 set vdisporder($curview) $displayorder
1859 set vcmitlisted($curview) $commitlisted
1860 if {$phase ne {}} {
1861 set viewdata($curview) \
1862 [list $phase $rowidlist $rowoffsets $rowrangelist \
1863 [flatten idrowranges] [flatten idinlist] \
1864 $rowlaidout $rowoptim $numcommits]
1865 } elseif {![info exists viewdata($curview)]
1866 || [lindex $viewdata($curview) 0] ne {}} {
1867 set viewdata($curview) \
1868 [list {} $rowidlist $rowoffsets $rowrangelist]
1871 catch {unset treediffs}
1872 clear_display
1873 if {[info exists hlview] && $hlview == $n} {
1874 unset hlview
1875 set selectedhlview None
1878 set curview $n
1879 set selectedview $n
1880 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1881 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1883 if {![info exists viewdata($n)]} {
1884 if {$selid ne {}} {
1885 set pending_select $selid
1887 getcommits
1888 return
1891 set v $viewdata($n)
1892 set phase [lindex $v 0]
1893 set displayorder $vdisporder($n)
1894 set parentlist $vparentlist($n)
1895 set commitlisted $vcmitlisted($n)
1896 set rowidlist [lindex $v 1]
1897 set rowoffsets [lindex $v 2]
1898 set rowrangelist [lindex $v 3]
1899 if {$phase eq {}} {
1900 set numcommits [llength $displayorder]
1901 catch {unset idrowranges}
1902 } else {
1903 unflatten idrowranges [lindex $v 4]
1904 unflatten idinlist [lindex $v 5]
1905 set rowlaidout [lindex $v 6]
1906 set rowoptim [lindex $v 7]
1907 set numcommits [lindex $v 8]
1908 catch {unset rowchk}
1911 catch {unset colormap}
1912 catch {unset rowtextx}
1913 set nextcolor 0
1914 set canvxmax [$canv cget -width]
1915 set curview $n
1916 set row 0
1917 setcanvscroll
1918 set yf 0
1919 set row {}
1920 set selectfirst 0
1921 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1922 set row $commitrow($n,$selid)
1923 # try to get the selected row in the same position on the screen
1924 set ymax [lindex [$canv cget -scrollregion] 3]
1925 set ytop [expr {[yc $row] - $yscreen}]
1926 if {$ytop < 0} {
1927 set ytop 0
1929 set yf [expr {$ytop * 1.0 / $ymax}]
1931 allcanvs yview moveto $yf
1932 drawvisible
1933 if {$row ne {}} {
1934 selectline $row 0
1935 } elseif {$selid ne {}} {
1936 set pending_select $selid
1937 } else {
1938 set row [first_real_row]
1939 if {$row < $numcommits} {
1940 selectline $row 0
1941 } else {
1942 set selectfirst 1
1945 if {$phase ne {}} {
1946 if {$phase eq "getcommits"} {
1947 show_status "Reading commits..."
1949 run chewcommits $n
1950 } elseif {$numcommits == 0} {
1951 show_status "No commits selected"
1955 # Stuff relating to the highlighting facility
1957 proc ishighlighted {row} {
1958 global vhighlights fhighlights nhighlights rhighlights
1960 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1961 return $nhighlights($row)
1963 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1964 return $vhighlights($row)
1966 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1967 return $fhighlights($row)
1969 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1970 return $rhighlights($row)
1972 return 0
1975 proc bolden {row font} {
1976 global canv linehtag selectedline boldrows
1978 lappend boldrows $row
1979 $canv itemconf $linehtag($row) -font $font
1980 if {[info exists selectedline] && $row == $selectedline} {
1981 $canv delete secsel
1982 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1983 -outline {{}} -tags secsel \
1984 -fill [$canv cget -selectbackground]]
1985 $canv lower $t
1989 proc bolden_name {row font} {
1990 global canv2 linentag selectedline boldnamerows
1992 lappend boldnamerows $row
1993 $canv2 itemconf $linentag($row) -font $font
1994 if {[info exists selectedline] && $row == $selectedline} {
1995 $canv2 delete secsel
1996 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1997 -outline {{}} -tags secsel \
1998 -fill [$canv2 cget -selectbackground]]
1999 $canv2 lower $t
2003 proc unbolden {} {
2004 global mainfont boldrows
2006 set stillbold {}
2007 foreach row $boldrows {
2008 if {![ishighlighted $row]} {
2009 bolden $row $mainfont
2010 } else {
2011 lappend stillbold $row
2014 set boldrows $stillbold
2017 proc addvhighlight {n} {
2018 global hlview curview viewdata vhl_done vhighlights commitidx
2020 if {[info exists hlview]} {
2021 delvhighlight
2023 set hlview $n
2024 if {$n != $curview && ![info exists viewdata($n)]} {
2025 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
2026 set vparentlist($n) {}
2027 set vdisporder($n) {}
2028 set vcmitlisted($n) {}
2029 start_rev_list $n
2031 set vhl_done $commitidx($hlview)
2032 if {$vhl_done > 0} {
2033 drawvisible
2037 proc delvhighlight {} {
2038 global hlview vhighlights
2040 if {![info exists hlview]} return
2041 unset hlview
2042 catch {unset vhighlights}
2043 unbolden
2046 proc vhighlightmore {} {
2047 global hlview vhl_done commitidx vhighlights
2048 global displayorder vdisporder curview mainfont
2050 set font [concat $mainfont bold]
2051 set max $commitidx($hlview)
2052 if {$hlview == $curview} {
2053 set disp $displayorder
2054 } else {
2055 set disp $vdisporder($hlview)
2057 set vr [visiblerows]
2058 set r0 [lindex $vr 0]
2059 set r1 [lindex $vr 1]
2060 for {set i $vhl_done} {$i < $max} {incr i} {
2061 set id [lindex $disp $i]
2062 if {[info exists commitrow($curview,$id)]} {
2063 set row $commitrow($curview,$id)
2064 if {$r0 <= $row && $row <= $r1} {
2065 if {![highlighted $row]} {
2066 bolden $row $font
2068 set vhighlights($row) 1
2072 set vhl_done $max
2075 proc askvhighlight {row id} {
2076 global hlview vhighlights commitrow iddrawn mainfont
2078 if {[info exists commitrow($hlview,$id)]} {
2079 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2080 bolden $row [concat $mainfont bold]
2082 set vhighlights($row) 1
2083 } else {
2084 set vhighlights($row) 0
2088 proc hfiles_change {name ix op} {
2089 global highlight_files filehighlight fhighlights fh_serial
2090 global mainfont highlight_paths
2092 if {[info exists filehighlight]} {
2093 # delete previous highlights
2094 catch {close $filehighlight}
2095 unset filehighlight
2096 catch {unset fhighlights}
2097 unbolden
2098 unhighlight_filelist
2100 set highlight_paths {}
2101 after cancel do_file_hl $fh_serial
2102 incr fh_serial
2103 if {$highlight_files ne {}} {
2104 after 300 do_file_hl $fh_serial
2108 proc makepatterns {l} {
2109 set ret {}
2110 foreach e $l {
2111 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2112 if {[string index $ee end] eq "/"} {
2113 lappend ret "$ee*"
2114 } else {
2115 lappend ret $ee
2116 lappend ret "$ee/*"
2119 return $ret
2122 proc do_file_hl {serial} {
2123 global highlight_files filehighlight highlight_paths gdttype fhl_list
2125 if {$gdttype eq "touching paths:"} {
2126 if {[catch {set paths [shellsplit $highlight_files]}]} return
2127 set highlight_paths [makepatterns $paths]
2128 highlight_filelist
2129 set gdtargs [concat -- $paths]
2130 } else {
2131 set gdtargs [list "-S$highlight_files"]
2133 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2134 set filehighlight [open $cmd r+]
2135 fconfigure $filehighlight -blocking 0
2136 filerun $filehighlight readfhighlight
2137 set fhl_list {}
2138 drawvisible
2139 flushhighlights
2142 proc flushhighlights {} {
2143 global filehighlight fhl_list
2145 if {[info exists filehighlight]} {
2146 lappend fhl_list {}
2147 puts $filehighlight ""
2148 flush $filehighlight
2152 proc askfilehighlight {row id} {
2153 global filehighlight fhighlights fhl_list
2155 lappend fhl_list $id
2156 set fhighlights($row) -1
2157 puts $filehighlight $id
2160 proc readfhighlight {} {
2161 global filehighlight fhighlights commitrow curview mainfont iddrawn
2162 global fhl_list
2164 if {![info exists filehighlight]} {
2165 return 0
2167 set nr 0
2168 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2169 set line [string trim $line]
2170 set i [lsearch -exact $fhl_list $line]
2171 if {$i < 0} continue
2172 for {set j 0} {$j < $i} {incr j} {
2173 set id [lindex $fhl_list $j]
2174 if {[info exists commitrow($curview,$id)]} {
2175 set fhighlights($commitrow($curview,$id)) 0
2178 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2179 if {$line eq {}} continue
2180 if {![info exists commitrow($curview,$line)]} continue
2181 set row $commitrow($curview,$line)
2182 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2183 bolden $row [concat $mainfont bold]
2185 set fhighlights($row) 1
2187 if {[eof $filehighlight]} {
2188 # strange...
2189 puts "oops, git diff-tree died"
2190 catch {close $filehighlight}
2191 unset filehighlight
2192 return 0
2194 next_hlcont
2195 return 1
2198 proc find_change {name ix op} {
2199 global nhighlights mainfont boldnamerows
2200 global findstring findpattern findtype
2202 # delete previous highlights, if any
2203 foreach row $boldnamerows {
2204 bolden_name $row $mainfont
2206 set boldnamerows {}
2207 catch {unset nhighlights}
2208 unbolden
2209 unmarkmatches
2210 if {$findtype ne "Regexp"} {
2211 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2212 $findstring]
2213 set findpattern "*$e*"
2215 drawvisible
2218 proc doesmatch {f} {
2219 global findtype findstring findpattern
2221 if {$findtype eq "Regexp"} {
2222 return [regexp $findstring $f]
2223 } elseif {$findtype eq "IgnCase"} {
2224 return [string match -nocase $findpattern $f]
2225 } else {
2226 return [string match $findpattern $f]
2230 proc askfindhighlight {row id} {
2231 global nhighlights commitinfo iddrawn mainfont
2232 global findloc
2233 global markingmatches
2235 if {![info exists commitinfo($id)]} {
2236 getcommit $id
2238 set info $commitinfo($id)
2239 set isbold 0
2240 set fldtypes {Headline Author Date Committer CDate Comments}
2241 foreach f $info ty $fldtypes {
2242 if {($findloc eq "All fields" || $findloc eq $ty) &&
2243 [doesmatch $f]} {
2244 if {$ty eq "Author"} {
2245 set isbold 2
2246 break
2248 set isbold 1
2251 if {$isbold && [info exists iddrawn($id)]} {
2252 set f [concat $mainfont bold]
2253 if {![ishighlighted $row]} {
2254 bolden $row $f
2255 if {$isbold > 1} {
2256 bolden_name $row $f
2259 if {$markingmatches} {
2260 markrowmatches $row $id
2263 set nhighlights($row) $isbold
2266 proc markrowmatches {row id} {
2267 global canv canv2 linehtag linentag commitinfo findloc
2269 set headline [lindex $commitinfo($id) 0]
2270 set author [lindex $commitinfo($id) 1]
2271 $canv delete match$row
2272 $canv2 delete match$row
2273 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2274 set m [findmatches $headline]
2275 if {$m ne {}} {
2276 markmatches $canv $row $headline $linehtag($row) $m \
2277 [$canv itemcget $linehtag($row) -font] $row
2280 if {$findloc eq "All fields" || $findloc eq "Author"} {
2281 set m [findmatches $author]
2282 if {$m ne {}} {
2283 markmatches $canv2 $row $author $linentag($row) $m \
2284 [$canv2 itemcget $linentag($row) -font] $row
2289 proc vrel_change {name ix op} {
2290 global highlight_related
2292 rhighlight_none
2293 if {$highlight_related ne "None"} {
2294 run drawvisible
2298 # prepare for testing whether commits are descendents or ancestors of a
2299 proc rhighlight_sel {a} {
2300 global descendent desc_todo ancestor anc_todo
2301 global highlight_related rhighlights
2303 catch {unset descendent}
2304 set desc_todo [list $a]
2305 catch {unset ancestor}
2306 set anc_todo [list $a]
2307 if {$highlight_related ne "None"} {
2308 rhighlight_none
2309 run drawvisible
2313 proc rhighlight_none {} {
2314 global rhighlights
2316 catch {unset rhighlights}
2317 unbolden
2320 proc is_descendent {a} {
2321 global curview children commitrow descendent desc_todo
2323 set v $curview
2324 set la $commitrow($v,$a)
2325 set todo $desc_todo
2326 set leftover {}
2327 set done 0
2328 for {set i 0} {$i < [llength $todo]} {incr i} {
2329 set do [lindex $todo $i]
2330 if {$commitrow($v,$do) < $la} {
2331 lappend leftover $do
2332 continue
2334 foreach nk $children($v,$do) {
2335 if {![info exists descendent($nk)]} {
2336 set descendent($nk) 1
2337 lappend todo $nk
2338 if {$nk eq $a} {
2339 set done 1
2343 if {$done} {
2344 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2345 return
2348 set descendent($a) 0
2349 set desc_todo $leftover
2352 proc is_ancestor {a} {
2353 global curview parentlist commitrow ancestor anc_todo
2355 set v $curview
2356 set la $commitrow($v,$a)
2357 set todo $anc_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 {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2363 lappend leftover $do
2364 continue
2366 foreach np [lindex $parentlist $commitrow($v,$do)] {
2367 if {![info exists ancestor($np)]} {
2368 set ancestor($np) 1
2369 lappend todo $np
2370 if {$np eq $a} {
2371 set done 1
2375 if {$done} {
2376 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2377 return
2380 set ancestor($a) 0
2381 set anc_todo $leftover
2384 proc askrelhighlight {row id} {
2385 global descendent highlight_related iddrawn mainfont rhighlights
2386 global selectedline ancestor
2388 if {![info exists selectedline]} return
2389 set isbold 0
2390 if {$highlight_related eq "Descendent" ||
2391 $highlight_related eq "Not descendent"} {
2392 if {![info exists descendent($id)]} {
2393 is_descendent $id
2395 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2396 set isbold 1
2398 } elseif {$highlight_related eq "Ancestor" ||
2399 $highlight_related eq "Not ancestor"} {
2400 if {![info exists ancestor($id)]} {
2401 is_ancestor $id
2403 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2404 set isbold 1
2407 if {[info exists iddrawn($id)]} {
2408 if {$isbold && ![ishighlighted $row]} {
2409 bolden $row [concat $mainfont bold]
2412 set rhighlights($row) $isbold
2415 proc next_hlcont {} {
2416 global fhl_row fhl_dirn displayorder numcommits
2417 global vhighlights fhighlights nhighlights rhighlights
2418 global hlview filehighlight findstring highlight_related
2420 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2421 set row $fhl_row
2422 while {1} {
2423 if {$row < 0 || $row >= $numcommits} {
2424 bell
2425 set fhl_dirn 0
2426 return
2428 set id [lindex $displayorder $row]
2429 if {[info exists hlview]} {
2430 if {![info exists vhighlights($row)]} {
2431 askvhighlight $row $id
2433 if {$vhighlights($row) > 0} break
2435 if {$findstring ne {}} {
2436 if {![info exists nhighlights($row)]} {
2437 askfindhighlight $row $id
2439 if {$nhighlights($row) > 0} break
2441 if {$highlight_related ne "None"} {
2442 if {![info exists rhighlights($row)]} {
2443 askrelhighlight $row $id
2445 if {$rhighlights($row) > 0} break
2447 if {[info exists filehighlight]} {
2448 if {![info exists fhighlights($row)]} {
2449 # ask for a few more while we're at it...
2450 set r $row
2451 for {set n 0} {$n < 100} {incr n} {
2452 if {![info exists fhighlights($r)]} {
2453 askfilehighlight $r [lindex $displayorder $r]
2455 incr r $fhl_dirn
2456 if {$r < 0 || $r >= $numcommits} break
2458 flushhighlights
2460 if {$fhighlights($row) < 0} {
2461 set fhl_row $row
2462 return
2464 if {$fhighlights($row) > 0} break
2466 incr row $fhl_dirn
2468 set fhl_dirn 0
2469 selectline $row 1
2472 proc next_highlight {dirn} {
2473 global selectedline fhl_row fhl_dirn
2474 global hlview filehighlight findstring highlight_related
2476 if {![info exists selectedline]} return
2477 if {!([info exists hlview] || $findstring ne {} ||
2478 $highlight_related ne "None" || [info exists filehighlight])} return
2479 set fhl_row [expr {$selectedline + $dirn}]
2480 set fhl_dirn $dirn
2481 next_hlcont
2484 proc cancel_next_highlight {} {
2485 global fhl_dirn
2487 set fhl_dirn 0
2490 # Graph layout functions
2492 proc shortids {ids} {
2493 set res {}
2494 foreach id $ids {
2495 if {[llength $id] > 1} {
2496 lappend res [shortids $id]
2497 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2498 lappend res [string range $id 0 7]
2499 } else {
2500 lappend res $id
2503 return $res
2506 proc incrange {l x o} {
2507 set n [llength $l]
2508 while {$x < $n} {
2509 set e [lindex $l $x]
2510 if {$e ne {}} {
2511 lset l $x [expr {$e + $o}]
2513 incr x
2515 return $l
2518 proc ntimes {n o} {
2519 set ret {}
2520 for {} {$n > 0} {incr n -1} {
2521 lappend ret $o
2523 return $ret
2526 proc usedinrange {id l1 l2} {
2527 global children commitrow curview
2529 if {[info exists commitrow($curview,$id)]} {
2530 set r $commitrow($curview,$id)
2531 if {$l1 <= $r && $r <= $l2} {
2532 return [expr {$r - $l1 + 1}]
2535 set kids $children($curview,$id)
2536 foreach c $kids {
2537 set r $commitrow($curview,$c)
2538 if {$l1 <= $r && $r <= $l2} {
2539 return [expr {$r - $l1 + 1}]
2542 return 0
2545 proc sanity {row {full 0}} {
2546 global rowidlist rowoffsets
2548 set col -1
2549 set ids [lindex $rowidlist $row]
2550 foreach id $ids {
2551 incr col
2552 if {$id eq {}} continue
2553 if {$col < [llength $ids] - 1 &&
2554 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2555 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2557 set o [lindex $rowoffsets $row $col]
2558 set y $row
2559 set x $col
2560 while {$o ne {}} {
2561 incr y -1
2562 incr x $o
2563 if {[lindex $rowidlist $y $x] != $id} {
2564 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2565 puts " id=[shortids $id] check started at row $row"
2566 for {set i $row} {$i >= $y} {incr i -1} {
2567 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2569 break
2571 if {!$full} break
2572 set o [lindex $rowoffsets $y $x]
2577 proc makeuparrow {oid x y z} {
2578 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2580 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2581 incr y -1
2582 incr x $z
2583 set off0 [lindex $rowoffsets $y]
2584 for {set x0 $x} {1} {incr x0} {
2585 if {$x0 >= [llength $off0]} {
2586 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2587 break
2589 set z [lindex $off0 $x0]
2590 if {$z ne {}} {
2591 incr x0 $z
2592 break
2595 set z [expr {$x0 - $x}]
2596 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2597 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2599 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2600 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2601 lappend idrowranges($oid) [lindex $displayorder $y]
2604 proc initlayout {} {
2605 global rowidlist rowoffsets displayorder commitlisted
2606 global rowlaidout rowoptim
2607 global idinlist rowchk rowrangelist idrowranges
2608 global numcommits canvxmax canv
2609 global nextcolor
2610 global parentlist
2611 global colormap rowtextx
2612 global selectfirst
2614 set numcommits 0
2615 set displayorder {}
2616 set commitlisted {}
2617 set parentlist {}
2618 set rowrangelist {}
2619 set nextcolor 0
2620 set rowidlist {{}}
2621 set rowoffsets {{}}
2622 catch {unset idinlist}
2623 catch {unset rowchk}
2624 set rowlaidout 0
2625 set rowoptim 0
2626 set canvxmax [$canv cget -width]
2627 catch {unset colormap}
2628 catch {unset rowtextx}
2629 catch {unset idrowranges}
2630 set selectfirst 1
2633 proc setcanvscroll {} {
2634 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2636 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2637 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2638 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2639 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2642 proc visiblerows {} {
2643 global canv numcommits linespc
2645 set ymax [lindex [$canv cget -scrollregion] 3]
2646 if {$ymax eq {} || $ymax == 0} return
2647 set f [$canv yview]
2648 set y0 [expr {int([lindex $f 0] * $ymax)}]
2649 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2650 if {$r0 < 0} {
2651 set r0 0
2653 set y1 [expr {int([lindex $f 1] * $ymax)}]
2654 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2655 if {$r1 >= $numcommits} {
2656 set r1 [expr {$numcommits - 1}]
2658 return [list $r0 $r1]
2661 proc layoutmore {tmax allread} {
2662 global rowlaidout rowoptim commitidx numcommits optim_delay
2663 global uparrowlen curview rowidlist idinlist
2665 set showlast 0
2666 set showdelay $optim_delay
2667 set optdelay [expr {$uparrowlen + 1}]
2668 while {1} {
2669 if {$rowoptim - $showdelay > $numcommits} {
2670 showstuff [expr {$rowoptim - $showdelay}] $showlast
2671 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2672 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2673 if {$nr > 100} {
2674 set nr 100
2676 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2677 incr rowoptim $nr
2678 } elseif {$commitidx($curview) > $rowlaidout} {
2679 set nr [expr {$commitidx($curview) - $rowlaidout}]
2680 # may need to increase this threshold if uparrowlen or
2681 # mingaplen are increased...
2682 if {$nr > 150} {
2683 set nr 150
2685 set row $rowlaidout
2686 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2687 if {$rowlaidout == $row} {
2688 return 0
2690 } elseif {$allread} {
2691 set optdelay 0
2692 set nrows $commitidx($curview)
2693 if {[lindex $rowidlist $nrows] ne {} ||
2694 [array names idinlist] ne {}} {
2695 layouttail
2696 set rowlaidout $commitidx($curview)
2697 } elseif {$rowoptim == $nrows} {
2698 set showdelay 0
2699 set showlast 1
2700 if {$numcommits == $nrows} {
2701 return 0
2704 } else {
2705 return 0
2707 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2708 return 1
2713 proc showstuff {canshow last} {
2714 global numcommits commitrow pending_select selectedline curview
2715 global lookingforhead mainheadid displayorder selectfirst
2716 global lastscrollset
2718 if {$numcommits == 0} {
2719 global phase
2720 set phase "incrdraw"
2721 allcanvs delete all
2723 set r0 $numcommits
2724 set prev $numcommits
2725 set numcommits $canshow
2726 set t [clock clicks -milliseconds]
2727 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2728 set lastscrollset $t
2729 setcanvscroll
2731 set rows [visiblerows]
2732 set r1 [lindex $rows 1]
2733 if {$r1 >= $canshow} {
2734 set r1 [expr {$canshow - 1}]
2736 if {$r0 <= $r1} {
2737 drawcommits $r0 $r1
2739 if {[info exists pending_select] &&
2740 [info exists commitrow($curview,$pending_select)] &&
2741 $commitrow($curview,$pending_select) < $numcommits} {
2742 selectline $commitrow($curview,$pending_select) 1
2744 if {$selectfirst} {
2745 if {[info exists selectedline] || [info exists pending_select]} {
2746 set selectfirst 0
2747 } else {
2748 set l [first_real_row]
2749 selectline $l 1
2750 set selectfirst 0
2753 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2754 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2755 set lookingforhead 0
2756 dodiffindex
2760 proc doshowlocalchanges {} {
2761 global lookingforhead curview mainheadid phase commitrow
2763 if {[info exists commitrow($curview,$mainheadid)] &&
2764 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2765 dodiffindex
2766 } elseif {$phase ne {}} {
2767 set lookingforhead 1
2771 proc dohidelocalchanges {} {
2772 global lookingforhead localfrow localirow lserial
2774 set lookingforhead 0
2775 if {$localfrow >= 0} {
2776 removerow $localfrow
2777 set localfrow -1
2778 if {$localirow > 0} {
2779 incr localirow -1
2782 if {$localirow >= 0} {
2783 removerow $localirow
2784 set localirow -1
2786 incr lserial
2789 # spawn off a process to do git diff-index --cached HEAD
2790 proc dodiffindex {} {
2791 global localirow localfrow lserial
2793 incr lserial
2794 set localfrow -1
2795 set localirow -1
2796 set fd [open "|git diff-index --cached HEAD" r]
2797 fconfigure $fd -blocking 0
2798 filerun $fd [list readdiffindex $fd $lserial]
2801 proc readdiffindex {fd serial} {
2802 global localirow commitrow mainheadid nullid2 curview
2803 global commitinfo commitdata lserial
2805 set isdiff 1
2806 if {[gets $fd line] < 0} {
2807 if {![eof $fd]} {
2808 return 1
2810 set isdiff 0
2812 # we only need to see one line and we don't really care what it says...
2813 close $fd
2815 # now see if there are any local changes not checked in to the index
2816 if {$serial == $lserial} {
2817 set fd [open "|git diff-files" r]
2818 fconfigure $fd -blocking 0
2819 filerun $fd [list readdifffiles $fd $serial]
2822 if {$isdiff && $serial == $lserial && $localirow == -1} {
2823 # add the line for the changes in the index to the graph
2824 set localirow $commitrow($curview,$mainheadid)
2825 set hl "Local changes checked in to index but not committed"
2826 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2827 set commitdata($nullid2) "\n $hl\n"
2828 insertrow $localirow $nullid2
2830 return 0
2833 proc readdifffiles {fd serial} {
2834 global localirow localfrow commitrow mainheadid nullid curview
2835 global commitinfo commitdata lserial
2837 set isdiff 1
2838 if {[gets $fd line] < 0} {
2839 if {![eof $fd]} {
2840 return 1
2842 set isdiff 0
2844 # we only need to see one line and we don't really care what it says...
2845 close $fd
2847 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2848 # add the line for the local diff to the graph
2849 if {$localirow >= 0} {
2850 set localfrow $localirow
2851 incr localirow
2852 } else {
2853 set localfrow $commitrow($curview,$mainheadid)
2855 set hl "Local uncommitted changes, not checked in to index"
2856 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2857 set commitdata($nullid) "\n $hl\n"
2858 insertrow $localfrow $nullid
2860 return 0
2863 proc layoutrows {row endrow last} {
2864 global rowidlist rowoffsets displayorder
2865 global uparrowlen downarrowlen maxwidth mingaplen
2866 global children parentlist
2867 global idrowranges
2868 global commitidx curview
2869 global idinlist rowchk rowrangelist
2871 set idlist [lindex $rowidlist $row]
2872 set offs [lindex $rowoffsets $row]
2873 while {$row < $endrow} {
2874 set id [lindex $displayorder $row]
2875 set oldolds {}
2876 set newolds {}
2877 foreach p [lindex $parentlist $row] {
2878 if {![info exists idinlist($p)]} {
2879 lappend newolds $p
2880 } elseif {!$idinlist($p)} {
2881 lappend oldolds $p
2883 set idinlist($p) 1
2885 set nev [expr {[llength $idlist] + [llength $newolds]
2886 + [llength $oldolds] - $maxwidth + 1}]
2887 if {$nev > 0} {
2888 if {!$last &&
2889 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2890 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2891 set i [lindex $idlist $x]
2892 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2893 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2894 [expr {$row + $uparrowlen + $mingaplen}]]
2895 if {$r == 0} {
2896 set idlist [lreplace $idlist $x $x]
2897 set offs [lreplace $offs $x $x]
2898 set offs [incrange $offs $x 1]
2899 set idinlist($i) 0
2900 set rm1 [expr {$row - 1}]
2901 lappend idrowranges($i) [lindex $displayorder $rm1]
2902 if {[incr nev -1] <= 0} break
2903 continue
2905 set rowchk($id) [expr {$row + $r}]
2908 lset rowidlist $row $idlist
2909 lset rowoffsets $row $offs
2911 set col [lsearch -exact $idlist $id]
2912 if {$col < 0} {
2913 set col [llength $idlist]
2914 lappend idlist $id
2915 lset rowidlist $row $idlist
2916 set z {}
2917 if {$children($curview,$id) ne {}} {
2918 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2919 unset idinlist($id)
2921 lappend offs $z
2922 lset rowoffsets $row $offs
2923 if {$z ne {}} {
2924 makeuparrow $id $col $row $z
2926 } else {
2927 unset idinlist($id)
2929 set ranges {}
2930 if {[info exists idrowranges($id)]} {
2931 set ranges $idrowranges($id)
2932 lappend ranges $id
2933 unset idrowranges($id)
2935 lappend rowrangelist $ranges
2936 incr row
2937 set offs [ntimes [llength $idlist] 0]
2938 set l [llength $newolds]
2939 set idlist [eval lreplace \$idlist $col $col $newolds]
2940 set o 0
2941 if {$l != 1} {
2942 set offs [lrange $offs 0 [expr {$col - 1}]]
2943 foreach x $newolds {
2944 lappend offs {}
2945 incr o -1
2947 incr o
2948 set tmp [expr {[llength $idlist] - [llength $offs]}]
2949 if {$tmp > 0} {
2950 set offs [concat $offs [ntimes $tmp $o]]
2952 } else {
2953 lset offs $col {}
2955 foreach i $newolds {
2956 set idrowranges($i) $id
2958 incr col $l
2959 foreach oid $oldolds {
2960 set idlist [linsert $idlist $col $oid]
2961 set offs [linsert $offs $col $o]
2962 makeuparrow $oid $col $row $o
2963 incr col
2965 lappend rowidlist $idlist
2966 lappend rowoffsets $offs
2968 return $row
2971 proc addextraid {id row} {
2972 global displayorder commitrow commitinfo
2973 global commitidx commitlisted
2974 global parentlist children curview
2976 incr commitidx($curview)
2977 lappend displayorder $id
2978 lappend commitlisted 0
2979 lappend parentlist {}
2980 set commitrow($curview,$id) $row
2981 readcommit $id
2982 if {![info exists commitinfo($id)]} {
2983 set commitinfo($id) {"No commit information available"}
2985 if {![info exists children($curview,$id)]} {
2986 set children($curview,$id) {}
2990 proc layouttail {} {
2991 global rowidlist rowoffsets idinlist commitidx curview
2992 global idrowranges rowrangelist
2994 set row $commitidx($curview)
2995 set idlist [lindex $rowidlist $row]
2996 while {$idlist ne {}} {
2997 set col [expr {[llength $idlist] - 1}]
2998 set id [lindex $idlist $col]
2999 addextraid $id $row
3000 catch {unset idinlist($id)}
3001 lappend idrowranges($id) $id
3002 lappend rowrangelist $idrowranges($id)
3003 unset idrowranges($id)
3004 incr row
3005 set offs [ntimes $col 0]
3006 set idlist [lreplace $idlist $col $col]
3007 lappend rowidlist $idlist
3008 lappend rowoffsets $offs
3011 foreach id [array names idinlist] {
3012 unset idinlist($id)
3013 addextraid $id $row
3014 lset rowidlist $row [list $id]
3015 lset rowoffsets $row 0
3016 makeuparrow $id 0 $row 0
3017 lappend idrowranges($id) $id
3018 lappend rowrangelist $idrowranges($id)
3019 unset idrowranges($id)
3020 incr row
3021 lappend rowidlist {}
3022 lappend rowoffsets {}
3026 proc insert_pad {row col npad} {
3027 global rowidlist rowoffsets
3029 set pad [ntimes $npad {}]
3030 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
3031 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
3032 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
3035 proc optimize_rows {row col endrow} {
3036 global rowidlist rowoffsets displayorder
3038 for {} {$row < $endrow} {incr row} {
3039 set idlist [lindex $rowidlist $row]
3040 set offs [lindex $rowoffsets $row]
3041 set haspad 0
3042 for {} {$col < [llength $offs]} {incr col} {
3043 if {[lindex $idlist $col] eq {}} {
3044 set haspad 1
3045 continue
3047 set z [lindex $offs $col]
3048 if {$z eq {}} continue
3049 set isarrow 0
3050 set x0 [expr {$col + $z}]
3051 set y0 [expr {$row - 1}]
3052 set z0 [lindex $rowoffsets $y0 $x0]
3053 if {$z0 eq {}} {
3054 set id [lindex $idlist $col]
3055 set ranges [rowranges $id]
3056 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3057 set isarrow 1
3060 # Looking at lines from this row to the previous row,
3061 # make them go straight up if they end in an arrow on
3062 # the previous row; otherwise make them go straight up
3063 # or at 45 degrees.
3064 if {$z < -1 || ($z < 0 && $isarrow)} {
3065 # Line currently goes left too much;
3066 # insert pads in the previous row, then optimize it
3067 set npad [expr {-1 - $z + $isarrow}]
3068 set offs [incrange $offs $col $npad]
3069 insert_pad $y0 $x0 $npad
3070 if {$y0 > 0} {
3071 optimize_rows $y0 $x0 $row
3073 set z [lindex $offs $col]
3074 set x0 [expr {$col + $z}]
3075 set z0 [lindex $rowoffsets $y0 $x0]
3076 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3077 # Line currently goes right too much;
3078 # insert pads in this line and adjust the next's rowoffsets
3079 set npad [expr {$z - 1 + $isarrow}]
3080 set y1 [expr {$row + 1}]
3081 set offs2 [lindex $rowoffsets $y1]
3082 set x1 -1
3083 foreach z $offs2 {
3084 incr x1
3085 if {$z eq {} || $x1 + $z < $col} continue
3086 if {$x1 + $z > $col} {
3087 incr npad
3089 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3090 break
3092 set pad [ntimes $npad {}]
3093 set idlist [eval linsert \$idlist $col $pad]
3094 set tmp [eval linsert \$offs $col $pad]
3095 incr col $npad
3096 set offs [incrange $tmp $col [expr {-$npad}]]
3097 set z [lindex $offs $col]
3098 set haspad 1
3100 if {$z0 eq {} && !$isarrow} {
3101 # this line links to its first child on row $row-2
3102 set rm2 [expr {$row - 2}]
3103 set id [lindex $displayorder $rm2]
3104 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3105 if {$xc >= 0} {
3106 set z0 [expr {$xc - $x0}]
3109 # avoid lines jigging left then immediately right
3110 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3111 insert_pad $y0 $x0 1
3112 set offs [incrange $offs $col 1]
3113 optimize_rows $y0 [expr {$x0 + 1}] $row
3116 if {!$haspad} {
3117 set o {}
3118 # Find the first column that doesn't have a line going right
3119 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3120 set o [lindex $offs $col]
3121 if {$o eq {}} {
3122 # check if this is the link to the first child
3123 set id [lindex $idlist $col]
3124 set ranges [rowranges $id]
3125 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3126 # it is, work out offset to child
3127 set y0 [expr {$row - 1}]
3128 set id [lindex $displayorder $y0]
3129 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3130 if {$x0 >= 0} {
3131 set o [expr {$x0 - $col}]
3135 if {$o eq {} || $o <= 0} break
3137 # Insert a pad at that column as long as it has a line and
3138 # isn't the last column, and adjust the next row' offsets
3139 if {$o ne {} && [incr col] < [llength $idlist]} {
3140 set y1 [expr {$row + 1}]
3141 set offs2 [lindex $rowoffsets $y1]
3142 set x1 -1
3143 foreach z $offs2 {
3144 incr x1
3145 if {$z eq {} || $x1 + $z < $col} continue
3146 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3147 break
3149 set idlist [linsert $idlist $col {}]
3150 set tmp [linsert $offs $col {}]
3151 incr col
3152 set offs [incrange $tmp $col -1]
3155 lset rowidlist $row $idlist
3156 lset rowoffsets $row $offs
3157 set col 0
3161 proc xc {row col} {
3162 global canvx0 linespc
3163 return [expr {$canvx0 + $col * $linespc}]
3166 proc yc {row} {
3167 global canvy0 linespc
3168 return [expr {$canvy0 + $row * $linespc}]
3171 proc linewidth {id} {
3172 global thickerline lthickness
3174 set wid $lthickness
3175 if {[info exists thickerline] && $id eq $thickerline} {
3176 set wid [expr {2 * $lthickness}]
3178 return $wid
3181 proc rowranges {id} {
3182 global phase idrowranges commitrow rowlaidout rowrangelist curview
3184 set ranges {}
3185 if {$phase eq {} ||
3186 ([info exists commitrow($curview,$id)]
3187 && $commitrow($curview,$id) < $rowlaidout)} {
3188 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3189 } elseif {[info exists idrowranges($id)]} {
3190 set ranges $idrowranges($id)
3192 set linenos {}
3193 foreach rid $ranges {
3194 lappend linenos $commitrow($curview,$rid)
3196 if {$linenos ne {}} {
3197 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3199 return $linenos
3202 # work around tk8.4 refusal to draw arrows on diagonal segments
3203 proc adjarrowhigh {coords} {
3204 global linespc
3206 set x0 [lindex $coords 0]
3207 set x1 [lindex $coords 2]
3208 if {$x0 != $x1} {
3209 set y0 [lindex $coords 1]
3210 set y1 [lindex $coords 3]
3211 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3212 # we have a nearby vertical segment, just trim off the diag bit
3213 set coords [lrange $coords 2 end]
3214 } else {
3215 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3216 set xi [expr {$x0 - $slope * $linespc / 2}]
3217 set yi [expr {$y0 - $linespc / 2}]
3218 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3221 return $coords
3224 proc drawlineseg {id row endrow arrowlow} {
3225 global rowidlist displayorder iddrawn linesegs
3226 global canv colormap linespc curview maxlinelen
3228 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3229 set le [expr {$row + 1}]
3230 set arrowhigh 1
3231 while {1} {
3232 set c [lsearch -exact [lindex $rowidlist $le] $id]
3233 if {$c < 0} {
3234 incr le -1
3235 break
3237 lappend cols $c
3238 set x [lindex $displayorder $le]
3239 if {$x eq $id} {
3240 set arrowhigh 0
3241 break
3243 if {[info exists iddrawn($x)] || $le == $endrow} {
3244 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3245 if {$c >= 0} {
3246 lappend cols $c
3247 set arrowhigh 0
3249 break
3251 incr le
3253 if {$le <= $row} {
3254 return $row
3257 set lines {}
3258 set i 0
3259 set joinhigh 0
3260 if {[info exists linesegs($id)]} {
3261 set lines $linesegs($id)
3262 foreach li $lines {
3263 set r0 [lindex $li 0]
3264 if {$r0 > $row} {
3265 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3266 set joinhigh 1
3268 break
3270 incr i
3273 set joinlow 0
3274 if {$i > 0} {
3275 set li [lindex $lines [expr {$i-1}]]
3276 set r1 [lindex $li 1]
3277 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3278 set joinlow 1
3282 set x [lindex $cols [expr {$le - $row}]]
3283 set xp [lindex $cols [expr {$le - 1 - $row}]]
3284 set dir [expr {$xp - $x}]
3285 if {$joinhigh} {
3286 set ith [lindex $lines $i 2]
3287 set coords [$canv coords $ith]
3288 set ah [$canv itemcget $ith -arrow]
3289 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3290 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3291 if {$x2 ne {} && $x - $x2 == $dir} {
3292 set coords [lrange $coords 0 end-2]
3294 } else {
3295 set coords [list [xc $le $x] [yc $le]]
3297 if {$joinlow} {
3298 set itl [lindex $lines [expr {$i-1}] 2]
3299 set al [$canv itemcget $itl -arrow]
3300 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3301 } elseif {$arrowlow &&
3302 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3303 set arrowlow 0
3305 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3306 for {set y $le} {[incr y -1] > $row} {} {
3307 set x $xp
3308 set xp [lindex $cols [expr {$y - 1 - $row}]]
3309 set ndir [expr {$xp - $x}]
3310 if {$dir != $ndir || $xp < 0} {
3311 lappend coords [xc $y $x] [yc $y]
3313 set dir $ndir
3315 if {!$joinlow} {
3316 if {$xp < 0} {
3317 # join parent line to first child
3318 set ch [lindex $displayorder $row]
3319 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3320 if {$xc < 0} {
3321 puts "oops: drawlineseg: child $ch not on row $row"
3322 } else {
3323 if {$xc < $x - 1} {
3324 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3325 } elseif {$xc > $x + 1} {
3326 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3328 set x $xc
3330 lappend coords [xc $row $x] [yc $row]
3331 } else {
3332 set xn [xc $row $xp]
3333 set yn [yc $row]
3334 # work around tk8.4 refusal to draw arrows on diagonal segments
3335 if {$arrowlow && $xn != [lindex $coords end-1]} {
3336 if {[llength $coords] < 4 ||
3337 [lindex $coords end-3] != [lindex $coords end-1] ||
3338 [lindex $coords end] - $yn > 2 * $linespc} {
3339 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3340 set yo [yc [expr {$row + 0.5}]]
3341 lappend coords $xn $yo $xn $yn
3343 } else {
3344 lappend coords $xn $yn
3347 if {!$joinhigh} {
3348 if {$arrowhigh} {
3349 set coords [adjarrowhigh $coords]
3351 assigncolor $id
3352 set t [$canv create line $coords -width [linewidth $id] \
3353 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3354 $canv lower $t
3355 bindline $t $id
3356 set lines [linsert $lines $i [list $row $le $t]]
3357 } else {
3358 $canv coords $ith $coords
3359 if {$arrow ne $ah} {
3360 $canv itemconf $ith -arrow $arrow
3362 lset lines $i 0 $row
3364 } else {
3365 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3366 set ndir [expr {$xo - $xp}]
3367 set clow [$canv coords $itl]
3368 if {$dir == $ndir} {
3369 set clow [lrange $clow 2 end]
3371 set coords [concat $coords $clow]
3372 if {!$joinhigh} {
3373 lset lines [expr {$i-1}] 1 $le
3374 if {$arrowhigh} {
3375 set coords [adjarrowhigh $coords]
3377 } else {
3378 # coalesce two pieces
3379 $canv delete $ith
3380 set b [lindex $lines [expr {$i-1}] 0]
3381 set e [lindex $lines $i 1]
3382 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3384 $canv coords $itl $coords
3385 if {$arrow ne $al} {
3386 $canv itemconf $itl -arrow $arrow
3390 set linesegs($id) $lines
3391 return $le
3394 proc drawparentlinks {id row} {
3395 global rowidlist canv colormap curview parentlist
3396 global idpos
3398 set rowids [lindex $rowidlist $row]
3399 set col [lsearch -exact $rowids $id]
3400 if {$col < 0} return
3401 set olds [lindex $parentlist $row]
3402 set row2 [expr {$row + 1}]
3403 set x [xc $row $col]
3404 set y [yc $row]
3405 set y2 [yc $row2]
3406 set ids [lindex $rowidlist $row2]
3407 # rmx = right-most X coord used
3408 set rmx 0
3409 foreach p $olds {
3410 set i [lsearch -exact $ids $p]
3411 if {$i < 0} {
3412 puts "oops, parent $p of $id not in list"
3413 continue
3415 set x2 [xc $row2 $i]
3416 if {$x2 > $rmx} {
3417 set rmx $x2
3419 if {[lsearch -exact $rowids $p] < 0} {
3420 # drawlineseg will do this one for us
3421 continue
3423 assigncolor $p
3424 # should handle duplicated parents here...
3425 set coords [list $x $y]
3426 if {$i < $col - 1} {
3427 lappend coords [xc $row [expr {$i + 1}]] $y
3428 } elseif {$i > $col + 1} {
3429 lappend coords [xc $row [expr {$i - 1}]] $y
3431 lappend coords $x2 $y2
3432 set t [$canv create line $coords -width [linewidth $p] \
3433 -fill $colormap($p) -tags lines.$p]
3434 $canv lower $t
3435 bindline $t $p
3437 if {$rmx > [lindex $idpos($id) 1]} {
3438 lset idpos($id) 1 $rmx
3439 redrawtags $id
3443 proc drawlines {id} {
3444 global canv
3446 $canv itemconf lines.$id -width [linewidth $id]
3449 proc drawcmittext {id row col} {
3450 global linespc canv canv2 canv3 canvy0 fgcolor curview
3451 global commitlisted commitinfo rowidlist parentlist
3452 global rowtextx idpos idtags idheads idotherrefs
3453 global linehtag linentag linedtag
3454 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3456 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3457 set listed [lindex $commitlisted $row]
3458 if {$id eq $nullid} {
3459 set ofill red
3460 } elseif {$id eq $nullid2} {
3461 set ofill green
3462 } else {
3463 set ofill [expr {$listed != 0? "blue": "white"}]
3465 set x [xc $row $col]
3466 set y [yc $row]
3467 set orad [expr {$linespc / 3}]
3468 if {$listed <= 1} {
3469 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3470 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3471 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3472 } elseif {$listed == 2} {
3473 # triangle pointing left for left-side commits
3474 set t [$canv create polygon \
3475 [expr {$x - $orad}] $y \
3476 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3477 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3478 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3479 } else {
3480 # triangle pointing right for right-side commits
3481 set t [$canv create polygon \
3482 [expr {$x + $orad - 1}] $y \
3483 [expr {$x - $orad}] [expr {$y - $orad}] \
3484 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3485 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3487 $canv raise $t
3488 $canv bind $t <1> {selcanvline {} %x %y}
3489 set rmx [llength [lindex $rowidlist $row]]
3490 set olds [lindex $parentlist $row]
3491 if {$olds ne {}} {
3492 set nextids [lindex $rowidlist [expr {$row + 1}]]
3493 foreach p $olds {
3494 set i [lsearch -exact $nextids $p]
3495 if {$i > $rmx} {
3496 set rmx $i
3500 set xt [xc $row $rmx]
3501 set rowtextx($row) $xt
3502 set idpos($id) [list $x $xt $y]
3503 if {[info exists idtags($id)] || [info exists idheads($id)]
3504 || [info exists idotherrefs($id)]} {
3505 set xt [drawtags $id $x $xt $y]
3507 set headline [lindex $commitinfo($id) 0]
3508 set name [lindex $commitinfo($id) 1]
3509 set date [lindex $commitinfo($id) 2]
3510 set date [formatdate $date]
3511 set font $mainfont
3512 set nfont $mainfont
3513 set isbold [ishighlighted $row]
3514 if {$isbold > 0} {
3515 lappend boldrows $row
3516 lappend font bold
3517 if {$isbold > 1} {
3518 lappend boldnamerows $row
3519 lappend nfont bold
3522 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3523 -text $headline -font $font -tags text]
3524 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3525 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3526 -text $name -font $nfont -tags text]
3527 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3528 -text $date -font $mainfont -tags text]
3529 set xr [expr {$xt + [font measure $mainfont $headline]}]
3530 if {$xr > $canvxmax} {
3531 set canvxmax $xr
3532 setcanvscroll
3536 proc drawcmitrow {row} {
3537 global displayorder rowidlist
3538 global iddrawn markingmatches
3539 global commitinfo parentlist numcommits
3540 global filehighlight fhighlights findstring nhighlights
3541 global hlview vhighlights
3542 global highlight_related rhighlights
3544 if {$row >= $numcommits} return
3546 set id [lindex $displayorder $row]
3547 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3548 askvhighlight $row $id
3550 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3551 askfilehighlight $row $id
3553 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3554 askfindhighlight $row $id
3556 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3557 askrelhighlight $row $id
3559 if {![info exists iddrawn($id)]} {
3560 set col [lsearch -exact [lindex $rowidlist $row] $id]
3561 if {$col < 0} {
3562 puts "oops, row $row id $id not in list"
3563 return
3565 if {![info exists commitinfo($id)]} {
3566 getcommit $id
3568 assigncolor $id
3569 drawcmittext $id $row $col
3570 set iddrawn($id) 1
3572 if {$markingmatches} {
3573 markrowmatches $row $id
3577 proc drawcommits {row {endrow {}}} {
3578 global numcommits iddrawn displayorder curview
3579 global parentlist rowidlist
3581 if {$row < 0} {
3582 set row 0
3584 if {$endrow eq {}} {
3585 set endrow $row
3587 if {$endrow >= $numcommits} {
3588 set endrow [expr {$numcommits - 1}]
3591 # make the lines join to already-drawn rows either side
3592 set r [expr {$row - 1}]
3593 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3594 set r $row
3596 set er [expr {$endrow + 1}]
3597 if {$er >= $numcommits ||
3598 ![info exists iddrawn([lindex $displayorder $er])]} {
3599 set er $endrow
3601 for {} {$r <= $er} {incr r} {
3602 set id [lindex $displayorder $r]
3603 set wasdrawn [info exists iddrawn($id)]
3604 drawcmitrow $r
3605 if {$r == $er} break
3606 set nextid [lindex $displayorder [expr {$r + 1}]]
3607 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3608 catch {unset prevlines}
3609 continue
3611 drawparentlinks $id $r
3613 if {[info exists lineends($r)]} {
3614 foreach lid $lineends($r) {
3615 unset prevlines($lid)
3618 set rowids [lindex $rowidlist $r]
3619 foreach lid $rowids {
3620 if {$lid eq {}} continue
3621 if {$lid eq $id} {
3622 # see if this is the first child of any of its parents
3623 foreach p [lindex $parentlist $r] {
3624 if {[lsearch -exact $rowids $p] < 0} {
3625 # make this line extend up to the child
3626 set le [drawlineseg $p $r $er 0]
3627 lappend lineends($le) $p
3628 set prevlines($p) 1
3631 } elseif {![info exists prevlines($lid)]} {
3632 set le [drawlineseg $lid $r $er 1]
3633 lappend lineends($le) $lid
3634 set prevlines($lid) 1
3640 proc drawfrac {f0 f1} {
3641 global canv linespc
3643 set ymax [lindex [$canv cget -scrollregion] 3]
3644 if {$ymax eq {} || $ymax == 0} return
3645 set y0 [expr {int($f0 * $ymax)}]
3646 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3647 set y1 [expr {int($f1 * $ymax)}]
3648 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3649 drawcommits $row $endrow
3652 proc drawvisible {} {
3653 global canv
3654 eval drawfrac [$canv yview]
3657 proc clear_display {} {
3658 global iddrawn linesegs
3659 global vhighlights fhighlights nhighlights rhighlights
3661 allcanvs delete all
3662 catch {unset iddrawn}
3663 catch {unset linesegs}
3664 catch {unset vhighlights}
3665 catch {unset fhighlights}
3666 catch {unset nhighlights}
3667 catch {unset rhighlights}
3670 proc findcrossings {id} {
3671 global rowidlist parentlist numcommits rowoffsets displayorder
3673 set cross {}
3674 set ccross {}
3675 foreach {s e} [rowranges $id] {
3676 if {$e >= $numcommits} {
3677 set e [expr {$numcommits - 1}]
3679 if {$e <= $s} continue
3680 set x [lsearch -exact [lindex $rowidlist $e] $id]
3681 if {$x < 0} {
3682 puts "findcrossings: oops, no [shortids $id] in row $e"
3683 continue
3685 for {set row $e} {[incr row -1] >= $s} {} {
3686 set olds [lindex $parentlist $row]
3687 set kid [lindex $displayorder $row]
3688 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3689 if {$kidx < 0} continue
3690 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3691 foreach p $olds {
3692 set px [lsearch -exact $nextrow $p]
3693 if {$px < 0} continue
3694 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3695 if {[lsearch -exact $ccross $p] >= 0} continue
3696 if {$x == $px + ($kidx < $px? -1: 1)} {
3697 lappend ccross $p
3698 } elseif {[lsearch -exact $cross $p] < 0} {
3699 lappend cross $p
3703 set inc [lindex $rowoffsets $row $x]
3704 if {$inc eq {}} break
3705 incr x $inc
3708 return [concat $ccross {{}} $cross]
3711 proc assigncolor {id} {
3712 global colormap colors nextcolor
3713 global commitrow parentlist children children curview
3715 if {[info exists colormap($id)]} return
3716 set ncolors [llength $colors]
3717 if {[info exists children($curview,$id)]} {
3718 set kids $children($curview,$id)
3719 } else {
3720 set kids {}
3722 if {[llength $kids] == 1} {
3723 set child [lindex $kids 0]
3724 if {[info exists colormap($child)]
3725 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3726 set colormap($id) $colormap($child)
3727 return
3730 set badcolors {}
3731 set origbad {}
3732 foreach x [findcrossings $id] {
3733 if {$x eq {}} {
3734 # delimiter between corner crossings and other crossings
3735 if {[llength $badcolors] >= $ncolors - 1} break
3736 set origbad $badcolors
3738 if {[info exists colormap($x)]
3739 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3740 lappend badcolors $colormap($x)
3743 if {[llength $badcolors] >= $ncolors} {
3744 set badcolors $origbad
3746 set origbad $badcolors
3747 if {[llength $badcolors] < $ncolors - 1} {
3748 foreach child $kids {
3749 if {[info exists colormap($child)]
3750 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3751 lappend badcolors $colormap($child)
3753 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3754 if {[info exists colormap($p)]
3755 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3756 lappend badcolors $colormap($p)
3760 if {[llength $badcolors] >= $ncolors} {
3761 set badcolors $origbad
3764 for {set i 0} {$i <= $ncolors} {incr i} {
3765 set c [lindex $colors $nextcolor]
3766 if {[incr nextcolor] >= $ncolors} {
3767 set nextcolor 0
3769 if {[lsearch -exact $badcolors $c]} break
3771 set colormap($id) $c
3774 proc bindline {t id} {
3775 global canv
3777 $canv bind $t <Enter> "lineenter %x %y $id"
3778 $canv bind $t <Motion> "linemotion %x %y $id"
3779 $canv bind $t <Leave> "lineleave $id"
3780 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3783 proc drawtags {id x xt y1} {
3784 global idtags idheads idotherrefs mainhead
3785 global linespc lthickness
3786 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3788 set marks {}
3789 set ntags 0
3790 set nheads 0
3791 if {[info exists idtags($id)]} {
3792 set marks $idtags($id)
3793 set ntags [llength $marks]
3795 if {[info exists idheads($id)]} {
3796 set marks [concat $marks $idheads($id)]
3797 set nheads [llength $idheads($id)]
3799 if {[info exists idotherrefs($id)]} {
3800 set marks [concat $marks $idotherrefs($id)]
3802 if {$marks eq {}} {
3803 return $xt
3806 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3807 set yt [expr {$y1 - 0.5 * $linespc}]
3808 set yb [expr {$yt + $linespc - 1}]
3809 set xvals {}
3810 set wvals {}
3811 set i -1
3812 foreach tag $marks {
3813 incr i
3814 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3815 set wid [font measure [concat $mainfont bold] $tag]
3816 } else {
3817 set wid [font measure $mainfont $tag]
3819 lappend xvals $xt
3820 lappend wvals $wid
3821 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3823 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3824 -width $lthickness -fill black -tags tag.$id]
3825 $canv lower $t
3826 foreach tag $marks x $xvals wid $wvals {
3827 set xl [expr {$x + $delta}]
3828 set xr [expr {$x + $delta + $wid + $lthickness}]
3829 set font $mainfont
3830 if {[incr ntags -1] >= 0} {
3831 # draw a tag
3832 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3833 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3834 -width 1 -outline black -fill yellow -tags tag.$id]
3835 $canv bind $t <1> [list showtag $tag 1]
3836 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3837 } else {
3838 # draw a head or other ref
3839 if {[incr nheads -1] >= 0} {
3840 set col green
3841 if {$tag eq $mainhead} {
3842 lappend font bold
3844 } else {
3845 set col "#ddddff"
3847 set xl [expr {$xl - $delta/2}]
3848 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3849 -width 1 -outline black -fill $col -tags tag.$id
3850 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3851 set rwid [font measure $mainfont $remoteprefix]
3852 set xi [expr {$x + 1}]
3853 set yti [expr {$yt + 1}]
3854 set xri [expr {$x + $rwid}]
3855 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3856 -width 0 -fill "#ffddaa" -tags tag.$id
3859 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3860 -font $font -tags [list tag.$id text]]
3861 if {$ntags >= 0} {
3862 $canv bind $t <1> [list showtag $tag 1]
3863 } elseif {$nheads >= 0} {
3864 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3867 return $xt
3870 proc xcoord {i level ln} {
3871 global canvx0 xspc1 xspc2
3873 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3874 if {$i > 0 && $i == $level} {
3875 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3876 } elseif {$i > $level} {
3877 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3879 return $x
3882 proc show_status {msg} {
3883 global canv mainfont fgcolor
3885 clear_display
3886 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3887 -tags text -fill $fgcolor
3890 # Insert a new commit as the child of the commit on row $row.
3891 # The new commit will be displayed on row $row and the commits
3892 # on that row and below will move down one row.
3893 proc insertrow {row newcmit} {
3894 global displayorder parentlist commitlisted children
3895 global commitrow curview rowidlist rowoffsets numcommits
3896 global rowrangelist rowlaidout rowoptim numcommits
3897 global selectedline rowchk commitidx
3899 if {$row >= $numcommits} {
3900 puts "oops, inserting new row $row but only have $numcommits rows"
3901 return
3903 set p [lindex $displayorder $row]
3904 set displayorder [linsert $displayorder $row $newcmit]
3905 set parentlist [linsert $parentlist $row $p]
3906 set kids $children($curview,$p)
3907 lappend kids $newcmit
3908 set children($curview,$p) $kids
3909 set children($curview,$newcmit) {}
3910 set commitlisted [linsert $commitlisted $row 1]
3911 set l [llength $displayorder]
3912 for {set r $row} {$r < $l} {incr r} {
3913 set id [lindex $displayorder $r]
3914 set commitrow($curview,$id) $r
3916 incr commitidx($curview)
3918 set idlist [lindex $rowidlist $row]
3919 set offs [lindex $rowoffsets $row]
3920 set newoffs {}
3921 foreach x $idlist {
3922 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3923 lappend newoffs {}
3924 } else {
3925 lappend newoffs 0
3928 if {[llength $kids] == 1} {
3929 set col [lsearch -exact $idlist $p]
3930 lset idlist $col $newcmit
3931 } else {
3932 set col [llength $idlist]
3933 lappend idlist $newcmit
3934 lappend offs {}
3935 lset rowoffsets $row $offs
3937 set rowidlist [linsert $rowidlist $row $idlist]
3938 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3940 set rowrangelist [linsert $rowrangelist $row {}]
3941 if {[llength $kids] > 1} {
3942 set rp1 [expr {$row + 1}]
3943 set ranges [lindex $rowrangelist $rp1]
3944 if {$ranges eq {}} {
3945 set ranges [list $newcmit $p]
3946 } elseif {[lindex $ranges end-1] eq $p} {
3947 lset ranges end-1 $newcmit
3949 lset rowrangelist $rp1 $ranges
3952 catch {unset rowchk}
3954 incr rowlaidout
3955 incr rowoptim
3956 incr numcommits
3958 if {[info exists selectedline] && $selectedline >= $row} {
3959 incr selectedline
3961 redisplay
3964 # Remove a commit that was inserted with insertrow on row $row.
3965 proc removerow {row} {
3966 global displayorder parentlist commitlisted children
3967 global commitrow curview rowidlist rowoffsets numcommits
3968 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3969 global linesegends selectedline rowchk commitidx
3971 if {$row >= $numcommits} {
3972 puts "oops, removing row $row but only have $numcommits rows"
3973 return
3975 set rp1 [expr {$row + 1}]
3976 set id [lindex $displayorder $row]
3977 set p [lindex $parentlist $row]
3978 set displayorder [lreplace $displayorder $row $row]
3979 set parentlist [lreplace $parentlist $row $row]
3980 set commitlisted [lreplace $commitlisted $row $row]
3981 set kids $children($curview,$p)
3982 set i [lsearch -exact $kids $id]
3983 if {$i >= 0} {
3984 set kids [lreplace $kids $i $i]
3985 set children($curview,$p) $kids
3987 set l [llength $displayorder]
3988 for {set r $row} {$r < $l} {incr r} {
3989 set id [lindex $displayorder $r]
3990 set commitrow($curview,$id) $r
3992 incr commitidx($curview) -1
3994 set rowidlist [lreplace $rowidlist $row $row]
3995 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3996 if {$kids ne {}} {
3997 set offs [lindex $rowoffsets $row]
3998 set offs [lreplace $offs end end]
3999 lset rowoffsets $row $offs
4002 set rowrangelist [lreplace $rowrangelist $row $row]
4003 if {[llength $kids] > 0} {
4004 set ranges [lindex $rowrangelist $row]
4005 if {[lindex $ranges end-1] eq $id} {
4006 set ranges [lreplace $ranges end-1 end]
4007 lset rowrangelist $row $ranges
4011 catch {unset rowchk}
4013 incr rowlaidout -1
4014 incr rowoptim -1
4015 incr numcommits -1
4017 if {[info exists selectedline] && $selectedline > $row} {
4018 incr selectedline -1
4020 redisplay
4023 # Don't change the text pane cursor if it is currently the hand cursor,
4024 # showing that we are over a sha1 ID link.
4025 proc settextcursor {c} {
4026 global ctext curtextcursor
4028 if {[$ctext cget -cursor] == $curtextcursor} {
4029 $ctext config -cursor $c
4031 set curtextcursor $c
4034 proc nowbusy {what} {
4035 global isbusy
4037 if {[array names isbusy] eq {}} {
4038 . config -cursor watch
4039 settextcursor watch
4041 set isbusy($what) 1
4044 proc notbusy {what} {
4045 global isbusy maincursor textcursor
4047 catch {unset isbusy($what)}
4048 if {[array names isbusy] eq {}} {
4049 . config -cursor $maincursor
4050 settextcursor $textcursor
4054 proc findmatches {f} {
4055 global findtype findstring
4056 if {$findtype == "Regexp"} {
4057 set matches [regexp -indices -all -inline $findstring $f]
4058 } else {
4059 set fs $findstring
4060 if {$findtype == "IgnCase"} {
4061 set f [string tolower $f]
4062 set fs [string tolower $fs]
4064 set matches {}
4065 set i 0
4066 set l [string length $fs]
4067 while {[set j [string first $fs $f $i]] >= 0} {
4068 lappend matches [list $j [expr {$j+$l-1}]]
4069 set i [expr {$j + $l}]
4072 return $matches
4075 proc dofind {{rev 0}} {
4076 global findstring findstartline findcurline selectedline numcommits
4078 unmarkmatches
4079 cancel_next_highlight
4080 focus .
4081 if {$findstring eq {} || $numcommits == 0} return
4082 if {![info exists selectedline]} {
4083 set findstartline [lindex [visiblerows] $rev]
4084 } else {
4085 set findstartline $selectedline
4087 set findcurline $findstartline
4088 nowbusy finding
4089 if {!$rev} {
4090 run findmore
4091 } else {
4092 if {$findcurline == 0} {
4093 set findcurline $numcommits
4095 incr findcurline -1
4096 run findmorerev
4100 proc findnext {restart} {
4101 global findcurline
4102 if {![info exists findcurline]} {
4103 if {$restart} {
4104 dofind
4105 } else {
4106 bell
4108 } else {
4109 run findmore
4110 nowbusy finding
4114 proc findprev {} {
4115 global findcurline
4116 if {![info exists findcurline]} {
4117 dofind 1
4118 } else {
4119 run findmorerev
4120 nowbusy finding
4124 proc findmore {} {
4125 global commitdata commitinfo numcommits findstring findpattern findloc
4126 global findstartline findcurline displayorder
4128 set fldtypes {Headline Author Date Committer CDate Comments}
4129 set l [expr {$findcurline + 1}]
4130 if {$l >= $numcommits} {
4131 set l 0
4133 if {$l <= $findstartline} {
4134 set lim [expr {$findstartline + 1}]
4135 } else {
4136 set lim $numcommits
4138 if {$lim - $l > 500} {
4139 set lim [expr {$l + 500}]
4141 set last 0
4142 for {} {$l < $lim} {incr l} {
4143 set id [lindex $displayorder $l]
4144 # shouldn't happen unless git log doesn't give all the commits...
4145 if {![info exists commitdata($id)]} continue
4146 if {![doesmatch $commitdata($id)]} continue
4147 if {![info exists commitinfo($id)]} {
4148 getcommit $id
4150 set info $commitinfo($id)
4151 foreach f $info ty $fldtypes {
4152 if {($findloc eq "All fields" || $findloc eq $ty) &&
4153 [doesmatch $f]} {
4154 findselectline $l
4155 notbusy finding
4156 return 0
4160 if {$l == $findstartline + 1} {
4161 bell
4162 unset findcurline
4163 notbusy finding
4164 return 0
4166 set findcurline [expr {$l - 1}]
4167 return 1
4170 proc findmorerev {} {
4171 global commitdata commitinfo numcommits findstring findpattern findloc
4172 global findstartline findcurline displayorder
4174 set fldtypes {Headline Author Date Committer CDate Comments}
4175 set l $findcurline
4176 if {$l == 0} {
4177 set l $numcommits
4179 incr l -1
4180 if {$l >= $findstartline} {
4181 set lim [expr {$findstartline - 1}]
4182 } else {
4183 set lim -1
4185 if {$l - $lim > 500} {
4186 set lim [expr {$l - 500}]
4188 set last 0
4189 for {} {$l > $lim} {incr l -1} {
4190 set id [lindex $displayorder $l]
4191 if {![doesmatch $commitdata($id)]} continue
4192 if {![info exists commitinfo($id)]} {
4193 getcommit $id
4195 set info $commitinfo($id)
4196 foreach f $info ty $fldtypes {
4197 if {($findloc eq "All fields" || $findloc eq $ty) &&
4198 [doesmatch $f]} {
4199 findselectline $l
4200 notbusy finding
4201 return 0
4205 if {$l == -1} {
4206 bell
4207 unset findcurline
4208 notbusy finding
4209 return 0
4211 set findcurline [expr {$l + 1}]
4212 return 1
4215 proc findselectline {l} {
4216 global findloc commentend ctext findcurline markingmatches
4218 set markingmatches 1
4219 set findcurline $l
4220 selectline $l 1
4221 if {$findloc == "All fields" || $findloc == "Comments"} {
4222 # highlight the matches in the comments
4223 set f [$ctext get 1.0 $commentend]
4224 set matches [findmatches $f]
4225 foreach match $matches {
4226 set start [lindex $match 0]
4227 set end [expr {[lindex $match 1] + 1}]
4228 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4231 drawvisible
4234 # mark the bits of a headline or author that match a find string
4235 proc markmatches {canv l str tag matches font row} {
4236 global selectedline
4238 set bbox [$canv bbox $tag]
4239 set x0 [lindex $bbox 0]
4240 set y0 [lindex $bbox 1]
4241 set y1 [lindex $bbox 3]
4242 foreach match $matches {
4243 set start [lindex $match 0]
4244 set end [lindex $match 1]
4245 if {$start > $end} continue
4246 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4247 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4248 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4249 [expr {$x0+$xlen+2}] $y1 \
4250 -outline {} -tags [list match$l matches] -fill yellow]
4251 $canv lower $t
4252 if {[info exists selectedline] && $row == $selectedline} {
4253 $canv raise $t secsel
4258 proc unmarkmatches {} {
4259 global findids markingmatches findcurline
4261 allcanvs delete matches
4262 catch {unset findids}
4263 set markingmatches 0
4264 catch {unset findcurline}
4267 proc selcanvline {w x y} {
4268 global canv canvy0 ctext linespc
4269 global rowtextx
4270 set ymax [lindex [$canv cget -scrollregion] 3]
4271 if {$ymax == {}} return
4272 set yfrac [lindex [$canv yview] 0]
4273 set y [expr {$y + $yfrac * $ymax}]
4274 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4275 if {$l < 0} {
4276 set l 0
4278 if {$w eq $canv} {
4279 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4281 unmarkmatches
4282 selectline $l 1
4285 proc commit_descriptor {p} {
4286 global commitinfo
4287 if {![info exists commitinfo($p)]} {
4288 getcommit $p
4290 set l "..."
4291 if {[llength $commitinfo($p)] > 1} {
4292 set l [lindex $commitinfo($p) 0]
4294 return "$p ($l)\n"
4297 # append some text to the ctext widget, and make any SHA1 ID
4298 # that we know about be a clickable link.
4299 proc appendwithlinks {text tags} {
4300 global ctext commitrow linknum curview
4302 set start [$ctext index "end - 1c"]
4303 $ctext insert end $text $tags
4304 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4305 foreach l $links {
4306 set s [lindex $l 0]
4307 set e [lindex $l 1]
4308 set linkid [string range $text $s $e]
4309 if {![info exists commitrow($curview,$linkid)]} continue
4310 incr e
4311 $ctext tag add link "$start + $s c" "$start + $e c"
4312 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4313 $ctext tag bind link$linknum <1> \
4314 [list selectline $commitrow($curview,$linkid) 1]
4315 incr linknum
4317 $ctext tag conf link -foreground blue -underline 1
4318 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4319 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4322 proc viewnextline {dir} {
4323 global canv linespc
4325 $canv delete hover
4326 set ymax [lindex [$canv cget -scrollregion] 3]
4327 set wnow [$canv yview]
4328 set wtop [expr {[lindex $wnow 0] * $ymax}]
4329 set newtop [expr {$wtop + $dir * $linespc}]
4330 if {$newtop < 0} {
4331 set newtop 0
4332 } elseif {$newtop > $ymax} {
4333 set newtop $ymax
4335 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4338 # add a list of tag or branch names at position pos
4339 # returns the number of names inserted
4340 proc appendrefs {pos ids var} {
4341 global ctext commitrow linknum curview $var maxrefs
4343 if {[catch {$ctext index $pos}]} {
4344 return 0
4346 $ctext conf -state normal
4347 $ctext delete $pos "$pos lineend"
4348 set tags {}
4349 foreach id $ids {
4350 foreach tag [set $var\($id\)] {
4351 lappend tags [list $tag $id]
4354 if {[llength $tags] > $maxrefs} {
4355 $ctext insert $pos "many ([llength $tags])"
4356 } else {
4357 set tags [lsort -index 0 -decreasing $tags]
4358 set sep {}
4359 foreach ti $tags {
4360 set id [lindex $ti 1]
4361 set lk link$linknum
4362 incr linknum
4363 $ctext tag delete $lk
4364 $ctext insert $pos $sep
4365 $ctext insert $pos [lindex $ti 0] $lk
4366 if {[info exists commitrow($curview,$id)]} {
4367 $ctext tag conf $lk -foreground blue
4368 $ctext tag bind $lk <1> \
4369 [list selectline $commitrow($curview,$id) 1]
4370 $ctext tag conf $lk -underline 1
4371 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4372 $ctext tag bind $lk <Leave> \
4373 { %W configure -cursor $curtextcursor }
4375 set sep ", "
4378 $ctext conf -state disabled
4379 return [llength $tags]
4382 # called when we have finished computing the nearby tags
4383 proc dispneartags {delay} {
4384 global selectedline currentid showneartags tagphase
4386 if {![info exists selectedline] || !$showneartags} return
4387 after cancel dispnexttag
4388 if {$delay} {
4389 after 200 dispnexttag
4390 set tagphase -1
4391 } else {
4392 after idle dispnexttag
4393 set tagphase 0
4397 proc dispnexttag {} {
4398 global selectedline currentid showneartags tagphase ctext
4400 if {![info exists selectedline] || !$showneartags} return
4401 switch -- $tagphase {
4403 set dtags [desctags $currentid]
4404 if {$dtags ne {}} {
4405 appendrefs precedes $dtags idtags
4409 set atags [anctags $currentid]
4410 if {$atags ne {}} {
4411 appendrefs follows $atags idtags
4415 set dheads [descheads $currentid]
4416 if {$dheads ne {}} {
4417 if {[appendrefs branch $dheads idheads] > 1
4418 && [$ctext get "branch -3c"] eq "h"} {
4419 # turn "Branch" into "Branches"
4420 $ctext conf -state normal
4421 $ctext insert "branch -2c" "es"
4422 $ctext conf -state disabled
4427 if {[incr tagphase] <= 2} {
4428 after idle dispnexttag
4432 proc selectline {l isnew} {
4433 global canv canv2 canv3 ctext commitinfo selectedline
4434 global displayorder linehtag linentag linedtag
4435 global canvy0 linespc parentlist children curview
4436 global currentid sha1entry
4437 global commentend idtags linknum
4438 global mergemax numcommits pending_select
4439 global cmitmode showneartags allcommits
4441 catch {unset pending_select}
4442 $canv delete hover
4443 normalline
4444 cancel_next_highlight
4445 if {$l < 0 || $l >= $numcommits} return
4446 set y [expr {$canvy0 + $l * $linespc}]
4447 set ymax [lindex [$canv cget -scrollregion] 3]
4448 set ytop [expr {$y - $linespc - 1}]
4449 set ybot [expr {$y + $linespc + 1}]
4450 set wnow [$canv yview]
4451 set wtop [expr {[lindex $wnow 0] * $ymax}]
4452 set wbot [expr {[lindex $wnow 1] * $ymax}]
4453 set wh [expr {$wbot - $wtop}]
4454 set newtop $wtop
4455 if {$ytop < $wtop} {
4456 if {$ybot < $wtop} {
4457 set newtop [expr {$y - $wh / 2.0}]
4458 } else {
4459 set newtop $ytop
4460 if {$newtop > $wtop - $linespc} {
4461 set newtop [expr {$wtop - $linespc}]
4464 } elseif {$ybot > $wbot} {
4465 if {$ytop > $wbot} {
4466 set newtop [expr {$y - $wh / 2.0}]
4467 } else {
4468 set newtop [expr {$ybot - $wh}]
4469 if {$newtop < $wtop + $linespc} {
4470 set newtop [expr {$wtop + $linespc}]
4474 if {$newtop != $wtop} {
4475 if {$newtop < 0} {
4476 set newtop 0
4478 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4479 drawvisible
4482 if {![info exists linehtag($l)]} return
4483 $canv delete secsel
4484 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4485 -tags secsel -fill [$canv cget -selectbackground]]
4486 $canv lower $t
4487 $canv2 delete secsel
4488 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4489 -tags secsel -fill [$canv2 cget -selectbackground]]
4490 $canv2 lower $t
4491 $canv3 delete secsel
4492 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4493 -tags secsel -fill [$canv3 cget -selectbackground]]
4494 $canv3 lower $t
4496 if {$isnew} {
4497 addtohistory [list selectline $l 0]
4500 set selectedline $l
4502 set id [lindex $displayorder $l]
4503 set currentid $id
4504 $sha1entry delete 0 end
4505 $sha1entry insert 0 $id
4506 $sha1entry selection from 0
4507 $sha1entry selection to end
4508 rhighlight_sel $id
4510 $ctext conf -state normal
4511 clear_ctext
4512 set linknum 0
4513 set info $commitinfo($id)
4514 set date [formatdate [lindex $info 2]]
4515 $ctext insert end "Author: [lindex $info 1] $date\n"
4516 set date [formatdate [lindex $info 4]]
4517 $ctext insert end "Committer: [lindex $info 3] $date\n"
4518 if {[info exists idtags($id)]} {
4519 $ctext insert end "Tags:"
4520 foreach tag $idtags($id) {
4521 $ctext insert end " $tag"
4523 $ctext insert end "\n"
4526 set headers {}
4527 set olds [lindex $parentlist $l]
4528 if {[llength $olds] > 1} {
4529 set np 0
4530 foreach p $olds {
4531 if {$np >= $mergemax} {
4532 set tag mmax
4533 } else {
4534 set tag m$np
4536 $ctext insert end "Parent: " $tag
4537 appendwithlinks [commit_descriptor $p] {}
4538 incr np
4540 } else {
4541 foreach p $olds {
4542 append headers "Parent: [commit_descriptor $p]"
4546 foreach c $children($curview,$id) {
4547 append headers "Child: [commit_descriptor $c]"
4550 # make anything that looks like a SHA1 ID be a clickable link
4551 appendwithlinks $headers {}
4552 if {$showneartags} {
4553 if {![info exists allcommits]} {
4554 getallcommits
4556 $ctext insert end "Branch: "
4557 $ctext mark set branch "end -1c"
4558 $ctext mark gravity branch left
4559 $ctext insert end "\nFollows: "
4560 $ctext mark set follows "end -1c"
4561 $ctext mark gravity follows left
4562 $ctext insert end "\nPrecedes: "
4563 $ctext mark set precedes "end -1c"
4564 $ctext mark gravity precedes left
4565 $ctext insert end "\n"
4566 dispneartags 1
4568 $ctext insert end "\n"
4569 set comment [lindex $info 5]
4570 if {[string first "\r" $comment] >= 0} {
4571 set comment [string map {"\r" "\n "} $comment]
4573 appendwithlinks $comment {comment}
4575 $ctext tag remove found 1.0 end
4576 $ctext conf -state disabled
4577 set commentend [$ctext index "end - 1c"]
4579 init_flist "Comments"
4580 if {$cmitmode eq "tree"} {
4581 gettree $id
4582 } elseif {[llength $olds] <= 1} {
4583 startdiff $id
4584 } else {
4585 mergediff $id $l
4589 proc selfirstline {} {
4590 unmarkmatches
4591 selectline 0 1
4594 proc sellastline {} {
4595 global numcommits
4596 unmarkmatches
4597 set l [expr {$numcommits - 1}]
4598 selectline $l 1
4601 proc selnextline {dir} {
4602 global selectedline
4603 if {![info exists selectedline]} return
4604 set l [expr {$selectedline + $dir}]
4605 unmarkmatches
4606 selectline $l 1
4609 proc selnextpage {dir} {
4610 global canv linespc selectedline numcommits
4612 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4613 if {$lpp < 1} {
4614 set lpp 1
4616 allcanvs yview scroll [expr {$dir * $lpp}] units
4617 drawvisible
4618 if {![info exists selectedline]} return
4619 set l [expr {$selectedline + $dir * $lpp}]
4620 if {$l < 0} {
4621 set l 0
4622 } elseif {$l >= $numcommits} {
4623 set l [expr $numcommits - 1]
4625 unmarkmatches
4626 selectline $l 1
4629 proc unselectline {} {
4630 global selectedline currentid
4632 catch {unset selectedline}
4633 catch {unset currentid}
4634 allcanvs delete secsel
4635 rhighlight_none
4636 cancel_next_highlight
4639 proc reselectline {} {
4640 global selectedline
4642 if {[info exists selectedline]} {
4643 selectline $selectedline 0
4647 proc addtohistory {cmd} {
4648 global history historyindex curview
4650 set elt [list $curview $cmd]
4651 if {$historyindex > 0
4652 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4653 return
4656 if {$historyindex < [llength $history]} {
4657 set history [lreplace $history $historyindex end $elt]
4658 } else {
4659 lappend history $elt
4661 incr historyindex
4662 if {$historyindex > 1} {
4663 .tf.bar.leftbut conf -state normal
4664 } else {
4665 .tf.bar.leftbut conf -state disabled
4667 .tf.bar.rightbut conf -state disabled
4670 proc godo {elt} {
4671 global curview
4673 set view [lindex $elt 0]
4674 set cmd [lindex $elt 1]
4675 if {$curview != $view} {
4676 showview $view
4678 eval $cmd
4681 proc goback {} {
4682 global history historyindex
4684 if {$historyindex > 1} {
4685 incr historyindex -1
4686 godo [lindex $history [expr {$historyindex - 1}]]
4687 .tf.bar.rightbut conf -state normal
4689 if {$historyindex <= 1} {
4690 .tf.bar.leftbut conf -state disabled
4694 proc goforw {} {
4695 global history historyindex
4697 if {$historyindex < [llength $history]} {
4698 set cmd [lindex $history $historyindex]
4699 incr historyindex
4700 godo $cmd
4701 .tf.bar.leftbut conf -state normal
4703 if {$historyindex >= [llength $history]} {
4704 .tf.bar.rightbut conf -state disabled
4708 proc gettree {id} {
4709 global treefilelist treeidlist diffids diffmergeid treepending
4710 global nullid nullid2
4712 set diffids $id
4713 catch {unset diffmergeid}
4714 if {![info exists treefilelist($id)]} {
4715 if {![info exists treepending]} {
4716 if {$id eq $nullid} {
4717 set cmd [list | git ls-files]
4718 } elseif {$id eq $nullid2} {
4719 set cmd [list | git ls-files --stage -t]
4720 } else {
4721 set cmd [list | git ls-tree -r $id]
4723 if {[catch {set gtf [open $cmd r]}]} {
4724 return
4726 set treepending $id
4727 set treefilelist($id) {}
4728 set treeidlist($id) {}
4729 fconfigure $gtf -blocking 0
4730 filerun $gtf [list gettreeline $gtf $id]
4732 } else {
4733 setfilelist $id
4737 proc gettreeline {gtf id} {
4738 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4740 set nl 0
4741 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4742 if {$diffids eq $nullid} {
4743 set fname $line
4744 } else {
4745 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4746 set i [string first "\t" $line]
4747 if {$i < 0} continue
4748 set sha1 [lindex $line 2]
4749 set fname [string range $line [expr {$i+1}] end]
4750 if {[string index $fname 0] eq "\""} {
4751 set fname [lindex $fname 0]
4753 lappend treeidlist($id) $sha1
4755 lappend treefilelist($id) $fname
4757 if {![eof $gtf]} {
4758 return [expr {$nl >= 1000? 2: 1}]
4760 close $gtf
4761 unset treepending
4762 if {$cmitmode ne "tree"} {
4763 if {![info exists diffmergeid]} {
4764 gettreediffs $diffids
4766 } elseif {$id ne $diffids} {
4767 gettree $diffids
4768 } else {
4769 setfilelist $id
4771 return 0
4774 proc showfile {f} {
4775 global treefilelist treeidlist diffids nullid nullid2
4776 global ctext commentend
4778 set i [lsearch -exact $treefilelist($diffids) $f]
4779 if {$i < 0} {
4780 puts "oops, $f not in list for id $diffids"
4781 return
4783 if {$diffids eq $nullid} {
4784 if {[catch {set bf [open $f r]} err]} {
4785 puts "oops, can't read $f: $err"
4786 return
4788 } else {
4789 set blob [lindex $treeidlist($diffids) $i]
4790 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4791 puts "oops, error reading blob $blob: $err"
4792 return
4795 fconfigure $bf -blocking 0
4796 filerun $bf [list getblobline $bf $diffids]
4797 $ctext config -state normal
4798 clear_ctext $commentend
4799 $ctext insert end "\n"
4800 $ctext insert end "$f\n" filesep
4801 $ctext config -state disabled
4802 $ctext yview $commentend
4805 proc getblobline {bf id} {
4806 global diffids cmitmode ctext
4808 if {$id ne $diffids || $cmitmode ne "tree"} {
4809 catch {close $bf}
4810 return 0
4812 $ctext config -state normal
4813 set nl 0
4814 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4815 $ctext insert end "$line\n"
4817 if {[eof $bf]} {
4818 # delete last newline
4819 $ctext delete "end - 2c" "end - 1c"
4820 close $bf
4821 return 0
4823 $ctext config -state disabled
4824 return [expr {$nl >= 1000? 2: 1}]
4827 proc mergediff {id l} {
4828 global diffmergeid diffopts mdifffd
4829 global diffids
4830 global parentlist
4832 set diffmergeid $id
4833 set diffids $id
4834 # this doesn't seem to actually affect anything...
4835 set env(GIT_DIFF_OPTS) $diffopts
4836 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4837 if {[catch {set mdf [open $cmd r]} err]} {
4838 error_popup "Error getting merge diffs: $err"
4839 return
4841 fconfigure $mdf -blocking 0
4842 set mdifffd($id) $mdf
4843 set np [llength [lindex $parentlist $l]]
4844 filerun $mdf [list getmergediffline $mdf $id $np]
4847 proc getmergediffline {mdf id np} {
4848 global diffmergeid ctext cflist mergemax
4849 global difffilestart mdifffd
4851 $ctext conf -state normal
4852 set nr 0
4853 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4854 if {![info exists diffmergeid] || $id != $diffmergeid
4855 || $mdf != $mdifffd($id)} {
4856 close $mdf
4857 return 0
4859 if {[regexp {^diff --cc (.*)} $line match fname]} {
4860 # start of a new file
4861 $ctext insert end "\n"
4862 set here [$ctext index "end - 1c"]
4863 lappend difffilestart $here
4864 add_flist [list $fname]
4865 set l [expr {(78 - [string length $fname]) / 2}]
4866 set pad [string range "----------------------------------------" 1 $l]
4867 $ctext insert end "$pad $fname $pad\n" filesep
4868 } elseif {[regexp {^@@} $line]} {
4869 $ctext insert end "$line\n" hunksep
4870 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4871 # do nothing
4872 } else {
4873 # parse the prefix - one ' ', '-' or '+' for each parent
4874 set spaces {}
4875 set minuses {}
4876 set pluses {}
4877 set isbad 0
4878 for {set j 0} {$j < $np} {incr j} {
4879 set c [string range $line $j $j]
4880 if {$c == " "} {
4881 lappend spaces $j
4882 } elseif {$c == "-"} {
4883 lappend minuses $j
4884 } elseif {$c == "+"} {
4885 lappend pluses $j
4886 } else {
4887 set isbad 1
4888 break
4891 set tags {}
4892 set num {}
4893 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4894 # line doesn't appear in result, parents in $minuses have the line
4895 set num [lindex $minuses 0]
4896 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4897 # line appears in result, parents in $pluses don't have the line
4898 lappend tags mresult
4899 set num [lindex $spaces 0]
4901 if {$num ne {}} {
4902 if {$num >= $mergemax} {
4903 set num "max"
4905 lappend tags m$num
4907 $ctext insert end "$line\n" $tags
4910 $ctext conf -state disabled
4911 if {[eof $mdf]} {
4912 close $mdf
4913 return 0
4915 return [expr {$nr >= 1000? 2: 1}]
4918 proc startdiff {ids} {
4919 global treediffs diffids treepending diffmergeid nullid nullid2
4921 set diffids $ids
4922 catch {unset diffmergeid}
4923 if {![info exists treediffs($ids)] ||
4924 [lsearch -exact $ids $nullid] >= 0 ||
4925 [lsearch -exact $ids $nullid2] >= 0} {
4926 if {![info exists treepending]} {
4927 gettreediffs $ids
4929 } else {
4930 addtocflist $ids
4934 proc addtocflist {ids} {
4935 global treediffs cflist
4936 add_flist $treediffs($ids)
4937 getblobdiffs $ids
4940 proc diffcmd {ids flags} {
4941 global nullid nullid2
4943 set i [lsearch -exact $ids $nullid]
4944 set j [lsearch -exact $ids $nullid2]
4945 if {$i >= 0} {
4946 if {[llength $ids] > 1 && $j < 0} {
4947 # comparing working directory with some specific revision
4948 set cmd [concat | git diff-index $flags]
4949 if {$i == 0} {
4950 lappend cmd -R [lindex $ids 1]
4951 } else {
4952 lappend cmd [lindex $ids 0]
4954 } else {
4955 # comparing working directory with index
4956 set cmd [concat | git diff-files $flags]
4957 if {$j == 1} {
4958 lappend cmd -R
4961 } elseif {$j >= 0} {
4962 set cmd [concat | git diff-index --cached $flags]
4963 if {[llength $ids] > 1} {
4964 # comparing index with specific revision
4965 if {$i == 0} {
4966 lappend cmd -R [lindex $ids 1]
4967 } else {
4968 lappend cmd [lindex $ids 0]
4970 } else {
4971 # comparing index with HEAD
4972 lappend cmd HEAD
4974 } else {
4975 set cmd [concat | git diff-tree -r $flags $ids]
4977 return $cmd
4980 proc gettreediffs {ids} {
4981 global treediff treepending
4983 set treepending $ids
4984 set treediff {}
4985 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4986 fconfigure $gdtf -blocking 0
4987 filerun $gdtf [list gettreediffline $gdtf $ids]
4990 proc gettreediffline {gdtf ids} {
4991 global treediff treediffs treepending diffids diffmergeid
4992 global cmitmode
4994 set nr 0
4995 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4996 set i [string first "\t" $line]
4997 if {$i >= 0} {
4998 set file [string range $line [expr {$i+1}] end]
4999 if {[string index $file 0] eq "\""} {
5000 set file [lindex $file 0]
5002 lappend treediff $file
5005 if {![eof $gdtf]} {
5006 return [expr {$nr >= 1000? 2: 1}]
5008 close $gdtf
5009 set treediffs($ids) $treediff
5010 unset treepending
5011 if {$cmitmode eq "tree"} {
5012 gettree $diffids
5013 } elseif {$ids != $diffids} {
5014 if {![info exists diffmergeid]} {
5015 gettreediffs $diffids
5017 } else {
5018 addtocflist $ids
5020 return 0
5023 proc getblobdiffs {ids} {
5024 global diffopts blobdifffd diffids env
5025 global diffinhdr treediffs
5027 set env(GIT_DIFF_OPTS) $diffopts
5028 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
5029 puts "error getting diffs: $err"
5030 return
5032 set diffinhdr 0
5033 fconfigure $bdf -blocking 0
5034 set blobdifffd($ids) $bdf
5035 filerun $bdf [list getblobdiffline $bdf $diffids]
5038 proc setinlist {var i val} {
5039 global $var
5041 while {[llength [set $var]] < $i} {
5042 lappend $var {}
5044 if {[llength [set $var]] == $i} {
5045 lappend $var $val
5046 } else {
5047 lset $var $i $val
5051 proc makediffhdr {fname ids} {
5052 global ctext curdiffstart treediffs
5054 set i [lsearch -exact $treediffs($ids) $fname]
5055 if {$i >= 0} {
5056 setinlist difffilestart $i $curdiffstart
5058 set l [expr {(78 - [string length $fname]) / 2}]
5059 set pad [string range "----------------------------------------" 1 $l]
5060 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5063 proc getblobdiffline {bdf ids} {
5064 global diffids blobdifffd ctext curdiffstart
5065 global diffnexthead diffnextnote difffilestart
5066 global diffinhdr treediffs
5068 set nr 0
5069 $ctext conf -state normal
5070 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5071 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5072 close $bdf
5073 return 0
5075 if {![string compare -length 11 "diff --git " $line]} {
5076 # trim off "diff --git "
5077 set line [string range $line 11 end]
5078 set diffinhdr 1
5079 # start of a new file
5080 $ctext insert end "\n"
5081 set curdiffstart [$ctext index "end - 1c"]
5082 $ctext insert end "\n" filesep
5083 # If the name hasn't changed the length will be odd,
5084 # the middle char will be a space, and the two bits either
5085 # side will be a/name and b/name, or "a/name" and "b/name".
5086 # If the name has changed we'll get "rename from" and
5087 # "rename to" lines following this, and we'll use them
5088 # to get the filenames.
5089 # This complexity is necessary because spaces in the filename(s)
5090 # don't get escaped.
5091 set l [string length $line]
5092 set i [expr {$l / 2}]
5093 if {!(($l & 1) && [string index $line $i] eq " " &&
5094 [string range $line 2 [expr {$i - 1}]] eq \
5095 [string range $line [expr {$i + 3}] end])} {
5096 continue
5098 # unescape if quoted and chop off the a/ from the front
5099 if {[string index $line 0] eq "\""} {
5100 set fname [string range [lindex $line 0] 2 end]
5101 } else {
5102 set fname [string range $line 2 [expr {$i - 1}]]
5104 makediffhdr $fname $ids
5106 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5107 $line match f1l f1c f2l f2c rest]} {
5108 $ctext insert end "$line\n" hunksep
5109 set diffinhdr 0
5111 } elseif {$diffinhdr} {
5112 if {![string compare -length 12 "rename from " $line]} {
5113 set fname [string range $line 12 end]
5114 if {[string index $fname 0] eq "\""} {
5115 set fname [lindex $fname 0]
5117 set i [lsearch -exact $treediffs($ids) $fname]
5118 if {$i >= 0} {
5119 setinlist difffilestart $i $curdiffstart
5121 } elseif {![string compare -length 10 $line "rename to "]} {
5122 set fname [string range $line 10 end]
5123 if {[string index $fname 0] eq "\""} {
5124 set fname [lindex $fname 0]
5126 makediffhdr $fname $ids
5127 } elseif {[string compare -length 3 $line "---"] == 0} {
5128 # do nothing
5129 continue
5130 } elseif {[string compare -length 3 $line "+++"] == 0} {
5131 set diffinhdr 0
5132 continue
5134 $ctext insert end "$line\n" filesep
5136 } else {
5137 set x [string range $line 0 0]
5138 if {$x == "-" || $x == "+"} {
5139 set tag [expr {$x == "+"}]
5140 $ctext insert end "$line\n" d$tag
5141 } elseif {$x == " "} {
5142 $ctext insert end "$line\n"
5143 } else {
5144 # "\ No newline at end of file",
5145 # or something else we don't recognize
5146 $ctext insert end "$line\n" hunksep
5150 $ctext conf -state disabled
5151 if {[eof $bdf]} {
5152 close $bdf
5153 return 0
5155 return [expr {$nr >= 1000? 2: 1}]
5158 proc changediffdisp {} {
5159 global ctext diffelide
5161 $ctext tag conf d0 -elide [lindex $diffelide 0]
5162 $ctext tag conf d1 -elide [lindex $diffelide 1]
5165 proc prevfile {} {
5166 global difffilestart ctext
5167 set prev [lindex $difffilestart 0]
5168 set here [$ctext index @0,0]
5169 foreach loc $difffilestart {
5170 if {[$ctext compare $loc >= $here]} {
5171 $ctext yview $prev
5172 return
5174 set prev $loc
5176 $ctext yview $prev
5179 proc nextfile {} {
5180 global difffilestart ctext
5181 set here [$ctext index @0,0]
5182 foreach loc $difffilestart {
5183 if {[$ctext compare $loc > $here]} {
5184 $ctext yview $loc
5185 return
5190 proc clear_ctext {{first 1.0}} {
5191 global ctext smarktop smarkbot
5193 set l [lindex [split $first .] 0]
5194 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5195 set smarktop $l
5197 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5198 set smarkbot $l
5200 $ctext delete $first end
5203 proc incrsearch {name ix op} {
5204 global ctext searchstring searchdirn
5206 $ctext tag remove found 1.0 end
5207 if {[catch {$ctext index anchor}]} {
5208 # no anchor set, use start of selection, or of visible area
5209 set sel [$ctext tag ranges sel]
5210 if {$sel ne {}} {
5211 $ctext mark set anchor [lindex $sel 0]
5212 } elseif {$searchdirn eq "-forwards"} {
5213 $ctext mark set anchor @0,0
5214 } else {
5215 $ctext mark set anchor @0,[winfo height $ctext]
5218 if {$searchstring ne {}} {
5219 set here [$ctext search $searchdirn -- $searchstring anchor]
5220 if {$here ne {}} {
5221 $ctext see $here
5223 searchmarkvisible 1
5227 proc dosearch {} {
5228 global sstring ctext searchstring searchdirn
5230 focus $sstring
5231 $sstring icursor end
5232 set searchdirn -forwards
5233 if {$searchstring ne {}} {
5234 set sel [$ctext tag ranges sel]
5235 if {$sel ne {}} {
5236 set start "[lindex $sel 0] + 1c"
5237 } elseif {[catch {set start [$ctext index anchor]}]} {
5238 set start "@0,0"
5240 set match [$ctext search -count mlen -- $searchstring $start]
5241 $ctext tag remove sel 1.0 end
5242 if {$match eq {}} {
5243 bell
5244 return
5246 $ctext see $match
5247 set mend "$match + $mlen c"
5248 $ctext tag add sel $match $mend
5249 $ctext mark unset anchor
5253 proc dosearchback {} {
5254 global sstring ctext searchstring searchdirn
5256 focus $sstring
5257 $sstring icursor end
5258 set searchdirn -backwards
5259 if {$searchstring ne {}} {
5260 set sel [$ctext tag ranges sel]
5261 if {$sel ne {}} {
5262 set start [lindex $sel 0]
5263 } elseif {[catch {set start [$ctext index anchor]}]} {
5264 set start @0,[winfo height $ctext]
5266 set match [$ctext search -backwards -count ml -- $searchstring $start]
5267 $ctext tag remove sel 1.0 end
5268 if {$match eq {}} {
5269 bell
5270 return
5272 $ctext see $match
5273 set mend "$match + $ml c"
5274 $ctext tag add sel $match $mend
5275 $ctext mark unset anchor
5279 proc searchmark {first last} {
5280 global ctext searchstring
5282 set mend $first.0
5283 while {1} {
5284 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5285 if {$match eq {}} break
5286 set mend "$match + $mlen c"
5287 $ctext tag add found $match $mend
5291 proc searchmarkvisible {doall} {
5292 global ctext smarktop smarkbot
5294 set topline [lindex [split [$ctext index @0,0] .] 0]
5295 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5296 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5297 # no overlap with previous
5298 searchmark $topline $botline
5299 set smarktop $topline
5300 set smarkbot $botline
5301 } else {
5302 if {$topline < $smarktop} {
5303 searchmark $topline [expr {$smarktop-1}]
5304 set smarktop $topline
5306 if {$botline > $smarkbot} {
5307 searchmark [expr {$smarkbot+1}] $botline
5308 set smarkbot $botline
5313 proc scrolltext {f0 f1} {
5314 global searchstring
5316 .bleft.sb set $f0 $f1
5317 if {$searchstring ne {}} {
5318 searchmarkvisible 0
5322 proc setcoords {} {
5323 global linespc charspc canvx0 canvy0 mainfont
5324 global xspc1 xspc2 lthickness
5326 set linespc [font metrics $mainfont -linespace]
5327 set charspc [font measure $mainfont "m"]
5328 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5329 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5330 set lthickness [expr {int($linespc / 9) + 1}]
5331 set xspc1(0) $linespc
5332 set xspc2 $linespc
5335 proc redisplay {} {
5336 global canv
5337 global selectedline
5339 set ymax [lindex [$canv cget -scrollregion] 3]
5340 if {$ymax eq {} || $ymax == 0} return
5341 set span [$canv yview]
5342 clear_display
5343 setcanvscroll
5344 allcanvs yview moveto [lindex $span 0]
5345 drawvisible
5346 if {[info exists selectedline]} {
5347 selectline $selectedline 0
5348 allcanvs yview moveto [lindex $span 0]
5352 proc incrfont {inc} {
5353 global mainfont textfont ctext canv phase cflist
5354 global charspc tabstop
5355 global stopped entries
5356 unmarkmatches
5357 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5358 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5359 setcoords
5360 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5361 $cflist conf -font $textfont
5362 $ctext tag conf filesep -font [concat $textfont bold]
5363 foreach e $entries {
5364 $e conf -font $mainfont
5366 if {$phase eq "getcommits"} {
5367 $canv itemconf textitems -font $mainfont
5369 redisplay
5372 proc clearsha1 {} {
5373 global sha1entry sha1string
5374 if {[string length $sha1string] == 40} {
5375 $sha1entry delete 0 end
5379 proc sha1change {n1 n2 op} {
5380 global sha1string currentid sha1but
5381 if {$sha1string == {}
5382 || ([info exists currentid] && $sha1string == $currentid)} {
5383 set state disabled
5384 } else {
5385 set state normal
5387 if {[$sha1but cget -state] == $state} return
5388 if {$state == "normal"} {
5389 $sha1but conf -state normal -relief raised -text "Goto: "
5390 } else {
5391 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5395 proc gotocommit {} {
5396 global sha1string currentid commitrow tagids headids
5397 global displayorder numcommits curview
5399 if {$sha1string == {}
5400 || ([info exists currentid] && $sha1string == $currentid)} return
5401 if {[info exists tagids($sha1string)]} {
5402 set id $tagids($sha1string)
5403 } elseif {[info exists headids($sha1string)]} {
5404 set id $headids($sha1string)
5405 } else {
5406 set id [string tolower $sha1string]
5407 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5408 set matches {}
5409 foreach i $displayorder {
5410 if {[string match $id* $i]} {
5411 lappend matches $i
5414 if {$matches ne {}} {
5415 if {[llength $matches] > 1} {
5416 error_popup "Short SHA1 id $id is ambiguous"
5417 return
5419 set id [lindex $matches 0]
5423 if {[info exists commitrow($curview,$id)]} {
5424 selectline $commitrow($curview,$id) 1
5425 return
5427 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5428 set type "SHA1 id"
5429 } else {
5430 set type "Tag/Head"
5432 error_popup "$type $sha1string is not known"
5435 proc lineenter {x y id} {
5436 global hoverx hovery hoverid hovertimer
5437 global commitinfo canv
5439 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5440 set hoverx $x
5441 set hovery $y
5442 set hoverid $id
5443 if {[info exists hovertimer]} {
5444 after cancel $hovertimer
5446 set hovertimer [after 500 linehover]
5447 $canv delete hover
5450 proc linemotion {x y id} {
5451 global hoverx hovery hoverid hovertimer
5453 if {[info exists hoverid] && $id == $hoverid} {
5454 set hoverx $x
5455 set hovery $y
5456 if {[info exists hovertimer]} {
5457 after cancel $hovertimer
5459 set hovertimer [after 500 linehover]
5463 proc lineleave {id} {
5464 global hoverid hovertimer canv
5466 if {[info exists hoverid] && $id == $hoverid} {
5467 $canv delete hover
5468 if {[info exists hovertimer]} {
5469 after cancel $hovertimer
5470 unset hovertimer
5472 unset hoverid
5476 proc linehover {} {
5477 global hoverx hovery hoverid hovertimer
5478 global canv linespc lthickness
5479 global commitinfo mainfont
5481 set text [lindex $commitinfo($hoverid) 0]
5482 set ymax [lindex [$canv cget -scrollregion] 3]
5483 if {$ymax == {}} return
5484 set yfrac [lindex [$canv yview] 0]
5485 set x [expr {$hoverx + 2 * $linespc}]
5486 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5487 set x0 [expr {$x - 2 * $lthickness}]
5488 set y0 [expr {$y - 2 * $lthickness}]
5489 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5490 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5491 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5492 -fill \#ffff80 -outline black -width 1 -tags hover]
5493 $canv raise $t
5494 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5495 -font $mainfont]
5496 $canv raise $t
5499 proc clickisonarrow {id y} {
5500 global lthickness
5502 set ranges [rowranges $id]
5503 set thresh [expr {2 * $lthickness + 6}]
5504 set n [expr {[llength $ranges] - 1}]
5505 for {set i 1} {$i < $n} {incr i} {
5506 set row [lindex $ranges $i]
5507 if {abs([yc $row] - $y) < $thresh} {
5508 return $i
5511 return {}
5514 proc arrowjump {id n y} {
5515 global canv
5517 # 1 <-> 2, 3 <-> 4, etc...
5518 set n [expr {(($n - 1) ^ 1) + 1}]
5519 set row [lindex [rowranges $id] $n]
5520 set yt [yc $row]
5521 set ymax [lindex [$canv cget -scrollregion] 3]
5522 if {$ymax eq {} || $ymax <= 0} return
5523 set view [$canv yview]
5524 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5525 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5526 if {$yfrac < 0} {
5527 set yfrac 0
5529 allcanvs yview moveto $yfrac
5532 proc lineclick {x y id isnew} {
5533 global ctext commitinfo children canv thickerline curview
5535 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5536 unmarkmatches
5537 unselectline
5538 normalline
5539 $canv delete hover
5540 # draw this line thicker than normal
5541 set thickerline $id
5542 drawlines $id
5543 if {$isnew} {
5544 set ymax [lindex [$canv cget -scrollregion] 3]
5545 if {$ymax eq {}} return
5546 set yfrac [lindex [$canv yview] 0]
5547 set y [expr {$y + $yfrac * $ymax}]
5549 set dirn [clickisonarrow $id $y]
5550 if {$dirn ne {}} {
5551 arrowjump $id $dirn $y
5552 return
5555 if {$isnew} {
5556 addtohistory [list lineclick $x $y $id 0]
5558 # fill the details pane with info about this line
5559 $ctext conf -state normal
5560 clear_ctext
5561 $ctext tag conf link -foreground blue -underline 1
5562 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5563 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5564 $ctext insert end "Parent:\t"
5565 $ctext insert end $id [list link link0]
5566 $ctext tag bind link0 <1> [list selbyid $id]
5567 set info $commitinfo($id)
5568 $ctext insert end "\n\t[lindex $info 0]\n"
5569 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5570 set date [formatdate [lindex $info 2]]
5571 $ctext insert end "\tDate:\t$date\n"
5572 set kids $children($curview,$id)
5573 if {$kids ne {}} {
5574 $ctext insert end "\nChildren:"
5575 set i 0
5576 foreach child $kids {
5577 incr i
5578 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5579 set info $commitinfo($child)
5580 $ctext insert end "\n\t"
5581 $ctext insert end $child [list link link$i]
5582 $ctext tag bind link$i <1> [list selbyid $child]
5583 $ctext insert end "\n\t[lindex $info 0]"
5584 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5585 set date [formatdate [lindex $info 2]]
5586 $ctext insert end "\n\tDate:\t$date\n"
5589 $ctext conf -state disabled
5590 init_flist {}
5593 proc normalline {} {
5594 global thickerline
5595 if {[info exists thickerline]} {
5596 set id $thickerline
5597 unset thickerline
5598 drawlines $id
5602 proc selbyid {id} {
5603 global commitrow curview
5604 if {[info exists commitrow($curview,$id)]} {
5605 selectline $commitrow($curview,$id) 1
5609 proc mstime {} {
5610 global startmstime
5611 if {![info exists startmstime]} {
5612 set startmstime [clock clicks -milliseconds]
5614 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5617 proc rowmenu {x y id} {
5618 global rowctxmenu commitrow selectedline rowmenuid curview
5619 global nullid nullid2 fakerowmenu mainhead
5621 set rowmenuid $id
5622 if {![info exists selectedline]
5623 || $commitrow($curview,$id) eq $selectedline} {
5624 set state disabled
5625 } else {
5626 set state normal
5628 if {$id ne $nullid && $id ne $nullid2} {
5629 set menu $rowctxmenu
5630 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5631 } else {
5632 set menu $fakerowmenu
5634 $menu entryconfigure "Diff this*" -state $state
5635 $menu entryconfigure "Diff selected*" -state $state
5636 $menu entryconfigure "Make patch" -state $state
5637 tk_popup $menu $x $y
5640 proc diffvssel {dirn} {
5641 global rowmenuid selectedline displayorder
5643 if {![info exists selectedline]} return
5644 if {$dirn} {
5645 set oldid [lindex $displayorder $selectedline]
5646 set newid $rowmenuid
5647 } else {
5648 set oldid $rowmenuid
5649 set newid [lindex $displayorder $selectedline]
5651 addtohistory [list doseldiff $oldid $newid]
5652 doseldiff $oldid $newid
5655 proc doseldiff {oldid newid} {
5656 global ctext
5657 global commitinfo
5659 $ctext conf -state normal
5660 clear_ctext
5661 init_flist "Top"
5662 $ctext insert end "From "
5663 $ctext tag conf link -foreground blue -underline 1
5664 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5665 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5666 $ctext tag bind link0 <1> [list selbyid $oldid]
5667 $ctext insert end $oldid [list link link0]
5668 $ctext insert end "\n "
5669 $ctext insert end [lindex $commitinfo($oldid) 0]
5670 $ctext insert end "\n\nTo "
5671 $ctext tag bind link1 <1> [list selbyid $newid]
5672 $ctext insert end $newid [list link link1]
5673 $ctext insert end "\n "
5674 $ctext insert end [lindex $commitinfo($newid) 0]
5675 $ctext insert end "\n"
5676 $ctext conf -state disabled
5677 $ctext tag remove found 1.0 end
5678 startdiff [list $oldid $newid]
5681 proc mkpatch {} {
5682 global rowmenuid currentid commitinfo patchtop patchnum
5684 if {![info exists currentid]} return
5685 set oldid $currentid
5686 set oldhead [lindex $commitinfo($oldid) 0]
5687 set newid $rowmenuid
5688 set newhead [lindex $commitinfo($newid) 0]
5689 set top .patch
5690 set patchtop $top
5691 catch {destroy $top}
5692 toplevel $top
5693 label $top.title -text "Generate patch"
5694 grid $top.title - -pady 10
5695 label $top.from -text "From:"
5696 entry $top.fromsha1 -width 40 -relief flat
5697 $top.fromsha1 insert 0 $oldid
5698 $top.fromsha1 conf -state readonly
5699 grid $top.from $top.fromsha1 -sticky w
5700 entry $top.fromhead -width 60 -relief flat
5701 $top.fromhead insert 0 $oldhead
5702 $top.fromhead conf -state readonly
5703 grid x $top.fromhead -sticky w
5704 label $top.to -text "To:"
5705 entry $top.tosha1 -width 40 -relief flat
5706 $top.tosha1 insert 0 $newid
5707 $top.tosha1 conf -state readonly
5708 grid $top.to $top.tosha1 -sticky w
5709 entry $top.tohead -width 60 -relief flat
5710 $top.tohead insert 0 $newhead
5711 $top.tohead conf -state readonly
5712 grid x $top.tohead -sticky w
5713 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5714 grid $top.rev x -pady 10
5715 label $top.flab -text "Output file:"
5716 entry $top.fname -width 60
5717 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5718 incr patchnum
5719 grid $top.flab $top.fname -sticky w
5720 frame $top.buts
5721 button $top.buts.gen -text "Generate" -command mkpatchgo
5722 button $top.buts.can -text "Cancel" -command mkpatchcan
5723 grid $top.buts.gen $top.buts.can
5724 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5725 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5726 grid $top.buts - -pady 10 -sticky ew
5727 focus $top.fname
5730 proc mkpatchrev {} {
5731 global patchtop
5733 set oldid [$patchtop.fromsha1 get]
5734 set oldhead [$patchtop.fromhead get]
5735 set newid [$patchtop.tosha1 get]
5736 set newhead [$patchtop.tohead get]
5737 foreach e [list fromsha1 fromhead tosha1 tohead] \
5738 v [list $newid $newhead $oldid $oldhead] {
5739 $patchtop.$e conf -state normal
5740 $patchtop.$e delete 0 end
5741 $patchtop.$e insert 0 $v
5742 $patchtop.$e conf -state readonly
5746 proc mkpatchgo {} {
5747 global patchtop nullid nullid2
5749 set oldid [$patchtop.fromsha1 get]
5750 set newid [$patchtop.tosha1 get]
5751 set fname [$patchtop.fname get]
5752 set cmd [diffcmd [list $oldid $newid] -p]
5753 lappend cmd >$fname &
5754 if {[catch {eval exec $cmd} err]} {
5755 error_popup "Error creating patch: $err"
5757 catch {destroy $patchtop}
5758 unset patchtop
5761 proc mkpatchcan {} {
5762 global patchtop
5764 catch {destroy $patchtop}
5765 unset patchtop
5768 proc mktag {} {
5769 global rowmenuid mktagtop commitinfo
5771 set top .maketag
5772 set mktagtop $top
5773 catch {destroy $top}
5774 toplevel $top
5775 label $top.title -text "Create tag"
5776 grid $top.title - -pady 10
5777 label $top.id -text "ID:"
5778 entry $top.sha1 -width 40 -relief flat
5779 $top.sha1 insert 0 $rowmenuid
5780 $top.sha1 conf -state readonly
5781 grid $top.id $top.sha1 -sticky w
5782 entry $top.head -width 60 -relief flat
5783 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5784 $top.head conf -state readonly
5785 grid x $top.head -sticky w
5786 label $top.tlab -text "Tag name:"
5787 entry $top.tag -width 60
5788 grid $top.tlab $top.tag -sticky w
5789 frame $top.buts
5790 button $top.buts.gen -text "Create" -command mktaggo
5791 button $top.buts.can -text "Cancel" -command mktagcan
5792 grid $top.buts.gen $top.buts.can
5793 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5794 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5795 grid $top.buts - -pady 10 -sticky ew
5796 focus $top.tag
5799 proc domktag {} {
5800 global mktagtop env tagids idtags
5802 set id [$mktagtop.sha1 get]
5803 set tag [$mktagtop.tag get]
5804 if {$tag == {}} {
5805 error_popup "No tag name specified"
5806 return
5808 if {[info exists tagids($tag)]} {
5809 error_popup "Tag \"$tag\" already exists"
5810 return
5812 if {[catch {
5813 set dir [gitdir]
5814 set fname [file join $dir "refs/tags" $tag]
5815 set f [open $fname w]
5816 puts $f $id
5817 close $f
5818 } err]} {
5819 error_popup "Error creating tag: $err"
5820 return
5823 set tagids($tag) $id
5824 lappend idtags($id) $tag
5825 redrawtags $id
5826 addedtag $id
5829 proc redrawtags {id} {
5830 global canv linehtag commitrow idpos selectedline curview
5831 global mainfont canvxmax iddrawn
5833 if {![info exists commitrow($curview,$id)]} return
5834 if {![info exists iddrawn($id)]} return
5835 drawcommits $commitrow($curview,$id)
5836 $canv delete tag.$id
5837 set xt [eval drawtags $id $idpos($id)]
5838 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5839 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5840 set xr [expr {$xt + [font measure $mainfont $text]}]
5841 if {$xr > $canvxmax} {
5842 set canvxmax $xr
5843 setcanvscroll
5845 if {[info exists selectedline]
5846 && $selectedline == $commitrow($curview,$id)} {
5847 selectline $selectedline 0
5851 proc mktagcan {} {
5852 global mktagtop
5854 catch {destroy $mktagtop}
5855 unset mktagtop
5858 proc mktaggo {} {
5859 domktag
5860 mktagcan
5863 proc writecommit {} {
5864 global rowmenuid wrcomtop commitinfo wrcomcmd
5866 set top .writecommit
5867 set wrcomtop $top
5868 catch {destroy $top}
5869 toplevel $top
5870 label $top.title -text "Write commit to file"
5871 grid $top.title - -pady 10
5872 label $top.id -text "ID:"
5873 entry $top.sha1 -width 40 -relief flat
5874 $top.sha1 insert 0 $rowmenuid
5875 $top.sha1 conf -state readonly
5876 grid $top.id $top.sha1 -sticky w
5877 entry $top.head -width 60 -relief flat
5878 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5879 $top.head conf -state readonly
5880 grid x $top.head -sticky w
5881 label $top.clab -text "Command:"
5882 entry $top.cmd -width 60 -textvariable wrcomcmd
5883 grid $top.clab $top.cmd -sticky w -pady 10
5884 label $top.flab -text "Output file:"
5885 entry $top.fname -width 60
5886 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5887 grid $top.flab $top.fname -sticky w
5888 frame $top.buts
5889 button $top.buts.gen -text "Write" -command wrcomgo
5890 button $top.buts.can -text "Cancel" -command wrcomcan
5891 grid $top.buts.gen $top.buts.can
5892 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5893 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5894 grid $top.buts - -pady 10 -sticky ew
5895 focus $top.fname
5898 proc wrcomgo {} {
5899 global wrcomtop
5901 set id [$wrcomtop.sha1 get]
5902 set cmd "echo $id | [$wrcomtop.cmd get]"
5903 set fname [$wrcomtop.fname get]
5904 if {[catch {exec sh -c $cmd >$fname &} err]} {
5905 error_popup "Error writing commit: $err"
5907 catch {destroy $wrcomtop}
5908 unset wrcomtop
5911 proc wrcomcan {} {
5912 global wrcomtop
5914 catch {destroy $wrcomtop}
5915 unset wrcomtop
5918 proc mkbranch {} {
5919 global rowmenuid mkbrtop
5921 set top .makebranch
5922 catch {destroy $top}
5923 toplevel $top
5924 label $top.title -text "Create new branch"
5925 grid $top.title - -pady 10
5926 label $top.id -text "ID:"
5927 entry $top.sha1 -width 40 -relief flat
5928 $top.sha1 insert 0 $rowmenuid
5929 $top.sha1 conf -state readonly
5930 grid $top.id $top.sha1 -sticky w
5931 label $top.nlab -text "Name:"
5932 entry $top.name -width 40
5933 grid $top.nlab $top.name -sticky w
5934 frame $top.buts
5935 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5936 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5937 grid $top.buts.go $top.buts.can
5938 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5939 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5940 grid $top.buts - -pady 10 -sticky ew
5941 focus $top.name
5944 proc mkbrgo {top} {
5945 global headids idheads
5947 set name [$top.name get]
5948 set id [$top.sha1 get]
5949 if {$name eq {}} {
5950 error_popup "Please specify a name for the new branch"
5951 return
5953 catch {destroy $top}
5954 nowbusy newbranch
5955 update
5956 if {[catch {
5957 exec git branch $name $id
5958 } err]} {
5959 notbusy newbranch
5960 error_popup $err
5961 } else {
5962 set headids($name) $id
5963 lappend idheads($id) $name
5964 addedhead $id $name
5965 notbusy newbranch
5966 redrawtags $id
5967 dispneartags 0
5971 proc cherrypick {} {
5972 global rowmenuid curview commitrow
5973 global mainhead
5975 set oldhead [exec git rev-parse HEAD]
5976 set dheads [descheads $rowmenuid]
5977 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5978 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5979 included in branch $mainhead -- really re-apply it?"]
5980 if {!$ok} return
5982 nowbusy cherrypick
5983 update
5984 # Unfortunately git-cherry-pick writes stuff to stderr even when
5985 # no error occurs, and exec takes that as an indication of error...
5986 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5987 notbusy cherrypick
5988 error_popup $err
5989 return
5991 set newhead [exec git rev-parse HEAD]
5992 if {$newhead eq $oldhead} {
5993 notbusy cherrypick
5994 error_popup "No changes committed"
5995 return
5997 addnewchild $newhead $oldhead
5998 if {[info exists commitrow($curview,$oldhead)]} {
5999 insertrow $commitrow($curview,$oldhead) $newhead
6000 if {$mainhead ne {}} {
6001 movehead $newhead $mainhead
6002 movedhead $newhead $mainhead
6004 redrawtags $oldhead
6005 redrawtags $newhead
6007 notbusy cherrypick
6010 proc resethead {} {
6011 global mainheadid mainhead rowmenuid confirm_ok resettype
6012 global showlocalchanges
6014 set confirm_ok 0
6015 set w ".confirmreset"
6016 toplevel $w
6017 wm transient $w .
6018 wm title $w "Confirm reset"
6019 message $w.m -text \
6020 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6021 -justify center -aspect 1000
6022 pack $w.m -side top -fill x -padx 20 -pady 20
6023 frame $w.f -relief sunken -border 2
6024 message $w.f.rt -text "Reset type:" -aspect 1000
6025 grid $w.f.rt -sticky w
6026 set resettype mixed
6027 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6028 -text "Soft: Leave working tree and index untouched"
6029 grid $w.f.soft -sticky w
6030 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6031 -text "Mixed: Leave working tree untouched, reset index"
6032 grid $w.f.mixed -sticky w
6033 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6034 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6035 grid $w.f.hard -sticky w
6036 pack $w.f -side top -fill x
6037 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6038 pack $w.ok -side left -fill x -padx 20 -pady 20
6039 button $w.cancel -text Cancel -command "destroy $w"
6040 pack $w.cancel -side right -fill x -padx 20 -pady 20
6041 bind $w <Visibility> "grab $w; focus $w"
6042 tkwait window $w
6043 if {!$confirm_ok} return
6044 if {[catch {set fd [open \
6045 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6046 error_popup $err
6047 } else {
6048 dohidelocalchanges
6049 set w ".resetprogress"
6050 filerun $fd [list readresetstat $fd $w]
6051 toplevel $w
6052 wm transient $w
6053 wm title $w "Reset progress"
6054 message $w.m -text "Reset in progress, please wait..." \
6055 -justify center -aspect 1000
6056 pack $w.m -side top -fill x -padx 20 -pady 5
6057 canvas $w.c -width 150 -height 20 -bg white
6058 $w.c create rect 0 0 0 20 -fill green -tags rect
6059 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6060 nowbusy reset
6064 proc readresetstat {fd w} {
6065 global mainhead mainheadid showlocalchanges
6067 if {[gets $fd line] >= 0} {
6068 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6069 set x [expr {($m * 150) / $n}]
6070 $w.c coords rect 0 0 $x 20
6072 return 1
6074 destroy $w
6075 notbusy reset
6076 if {[catch {close $fd} err]} {
6077 error_popup $err
6079 set oldhead $mainheadid
6080 set newhead [exec git rev-parse HEAD]
6081 if {$newhead ne $oldhead} {
6082 movehead $newhead $mainhead
6083 movedhead $newhead $mainhead
6084 set mainheadid $newhead
6085 redrawtags $oldhead
6086 redrawtags $newhead
6088 if {$showlocalchanges} {
6089 doshowlocalchanges
6091 return 0
6094 # context menu for a head
6095 proc headmenu {x y id head} {
6096 global headmenuid headmenuhead headctxmenu mainhead
6098 set headmenuid $id
6099 set headmenuhead $head
6100 set state normal
6101 if {$head eq $mainhead} {
6102 set state disabled
6104 $headctxmenu entryconfigure 0 -state $state
6105 $headctxmenu entryconfigure 1 -state $state
6106 tk_popup $headctxmenu $x $y
6109 proc cobranch {} {
6110 global headmenuid headmenuhead mainhead headids
6111 global showlocalchanges mainheadid
6113 # check the tree is clean first??
6114 set oldmainhead $mainhead
6115 nowbusy checkout
6116 update
6117 dohidelocalchanges
6118 if {[catch {
6119 exec git checkout -q $headmenuhead
6120 } err]} {
6121 notbusy checkout
6122 error_popup $err
6123 } else {
6124 notbusy checkout
6125 set mainhead $headmenuhead
6126 set mainheadid $headmenuid
6127 if {[info exists headids($oldmainhead)]} {
6128 redrawtags $headids($oldmainhead)
6130 redrawtags $headmenuid
6132 if {$showlocalchanges} {
6133 dodiffindex
6137 proc rmbranch {} {
6138 global headmenuid headmenuhead mainhead
6139 global headids idheads
6141 set head $headmenuhead
6142 set id $headmenuid
6143 # this check shouldn't be needed any more...
6144 if {$head eq $mainhead} {
6145 error_popup "Cannot delete the currently checked-out branch"
6146 return
6148 set dheads [descheads $id]
6149 if {$dheads eq $headids($head)} {
6150 # the stuff on this branch isn't on any other branch
6151 if {![confirm_popup "The commits on branch $head aren't on any other\
6152 branch.\nReally delete branch $head?"]} return
6154 nowbusy rmbranch
6155 update
6156 if {[catch {exec git branch -D $head} err]} {
6157 notbusy rmbranch
6158 error_popup $err
6159 return
6161 removehead $id $head
6162 removedhead $id $head
6163 redrawtags $id
6164 notbusy rmbranch
6165 dispneartags 0
6168 # Stuff for finding nearby tags
6169 proc getallcommits {} {
6170 global allcommits allids nbmp nextarc seeds
6172 set allids {}
6173 set nbmp 0
6174 set nextarc 0
6175 set allcommits 0
6176 set seeds {}
6177 regetallcommits
6180 # Called when the graph might have changed
6181 proc regetallcommits {} {
6182 global allcommits seeds
6184 set cmd [concat | git rev-list --all --parents]
6185 foreach id $seeds {
6186 lappend cmd "^$id"
6188 set fd [open $cmd r]
6189 fconfigure $fd -blocking 0
6190 incr allcommits
6191 nowbusy allcommits
6192 filerun $fd [list getallclines $fd]
6195 # Since most commits have 1 parent and 1 child, we group strings of
6196 # such commits into "arcs" joining branch/merge points (BMPs), which
6197 # are commits that either don't have 1 parent or don't have 1 child.
6199 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6200 # arcout(id) - outgoing arcs for BMP
6201 # arcids(a) - list of IDs on arc including end but not start
6202 # arcstart(a) - BMP ID at start of arc
6203 # arcend(a) - BMP ID at end of arc
6204 # growing(a) - arc a is still growing
6205 # arctags(a) - IDs out of arcids (excluding end) that have tags
6206 # archeads(a) - IDs out of arcids (excluding end) that have heads
6207 # The start of an arc is at the descendent end, so "incoming" means
6208 # coming from descendents, and "outgoing" means going towards ancestors.
6210 proc getallclines {fd} {
6211 global allids allparents allchildren idtags idheads nextarc nbmp
6212 global arcnos arcids arctags arcout arcend arcstart archeads growing
6213 global seeds allcommits
6215 set nid 0
6216 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6217 set id [lindex $line 0]
6218 if {[info exists allparents($id)]} {
6219 # seen it already
6220 continue
6222 lappend allids $id
6223 set olds [lrange $line 1 end]
6224 set allparents($id) $olds
6225 if {![info exists allchildren($id)]} {
6226 set allchildren($id) {}
6227 set arcnos($id) {}
6228 lappend seeds $id
6229 } else {
6230 set a $arcnos($id)
6231 if {[llength $olds] == 1 && [llength $a] == 1} {
6232 lappend arcids($a) $id
6233 if {[info exists idtags($id)]} {
6234 lappend arctags($a) $id
6236 if {[info exists idheads($id)]} {
6237 lappend archeads($a) $id
6239 if {[info exists allparents($olds)]} {
6240 # seen parent already
6241 if {![info exists arcout($olds)]} {
6242 splitarc $olds
6244 lappend arcids($a) $olds
6245 set arcend($a) $olds
6246 unset growing($a)
6248 lappend allchildren($olds) $id
6249 lappend arcnos($olds) $a
6250 continue
6253 incr nbmp
6254 foreach a $arcnos($id) {
6255 lappend arcids($a) $id
6256 set arcend($a) $id
6257 unset growing($a)
6260 set ao {}
6261 foreach p $olds {
6262 lappend allchildren($p) $id
6263 set a [incr nextarc]
6264 set arcstart($a) $id
6265 set archeads($a) {}
6266 set arctags($a) {}
6267 set archeads($a) {}
6268 set arcids($a) {}
6269 lappend ao $a
6270 set growing($a) 1
6271 if {[info exists allparents($p)]} {
6272 # seen it already, may need to make a new branch
6273 if {![info exists arcout($p)]} {
6274 splitarc $p
6276 lappend arcids($a) $p
6277 set arcend($a) $p
6278 unset growing($a)
6280 lappend arcnos($p) $a
6282 set arcout($id) $ao
6284 if {$nid > 0} {
6285 global cached_dheads cached_dtags cached_atags
6286 catch {unset cached_dheads}
6287 catch {unset cached_dtags}
6288 catch {unset cached_atags}
6290 if {![eof $fd]} {
6291 return [expr {$nid >= 1000? 2: 1}]
6293 close $fd
6294 if {[incr allcommits -1] == 0} {
6295 notbusy allcommits
6297 dispneartags 0
6298 return 0
6301 proc recalcarc {a} {
6302 global arctags archeads arcids idtags idheads
6304 set at {}
6305 set ah {}
6306 foreach id [lrange $arcids($a) 0 end-1] {
6307 if {[info exists idtags($id)]} {
6308 lappend at $id
6310 if {[info exists idheads($id)]} {
6311 lappend ah $id
6314 set arctags($a) $at
6315 set archeads($a) $ah
6318 proc splitarc {p} {
6319 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6320 global arcstart arcend arcout allparents growing
6322 set a $arcnos($p)
6323 if {[llength $a] != 1} {
6324 puts "oops splitarc called but [llength $a] arcs already"
6325 return
6327 set a [lindex $a 0]
6328 set i [lsearch -exact $arcids($a) $p]
6329 if {$i < 0} {
6330 puts "oops splitarc $p not in arc $a"
6331 return
6333 set na [incr nextarc]
6334 if {[info exists arcend($a)]} {
6335 set arcend($na) $arcend($a)
6336 } else {
6337 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6338 set j [lsearch -exact $arcnos($l) $a]
6339 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6341 set tail [lrange $arcids($a) [expr {$i+1}] end]
6342 set arcids($a) [lrange $arcids($a) 0 $i]
6343 set arcend($a) $p
6344 set arcstart($na) $p
6345 set arcout($p) $na
6346 set arcids($na) $tail
6347 if {[info exists growing($a)]} {
6348 set growing($na) 1
6349 unset growing($a)
6351 incr nbmp
6353 foreach id $tail {
6354 if {[llength $arcnos($id)] == 1} {
6355 set arcnos($id) $na
6356 } else {
6357 set j [lsearch -exact $arcnos($id) $a]
6358 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6362 # reconstruct tags and heads lists
6363 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6364 recalcarc $a
6365 recalcarc $na
6366 } else {
6367 set arctags($na) {}
6368 set archeads($na) {}
6372 # Update things for a new commit added that is a child of one
6373 # existing commit. Used when cherry-picking.
6374 proc addnewchild {id p} {
6375 global allids allparents allchildren idtags nextarc nbmp
6376 global arcnos arcids arctags arcout arcend arcstart archeads growing
6377 global seeds
6379 lappend allids $id
6380 set allparents($id) [list $p]
6381 set allchildren($id) {}
6382 set arcnos($id) {}
6383 lappend seeds $id
6384 incr nbmp
6385 lappend allchildren($p) $id
6386 set a [incr nextarc]
6387 set arcstart($a) $id
6388 set archeads($a) {}
6389 set arctags($a) {}
6390 set arcids($a) [list $p]
6391 set arcend($a) $p
6392 if {![info exists arcout($p)]} {
6393 splitarc $p
6395 lappend arcnos($p) $a
6396 set arcout($id) [list $a]
6399 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6400 # or 0 if neither is true.
6401 proc anc_or_desc {a b} {
6402 global arcout arcstart arcend arcnos cached_isanc
6404 if {$arcnos($a) eq $arcnos($b)} {
6405 # Both are on the same arc(s); either both are the same BMP,
6406 # or if one is not a BMP, the other is also not a BMP or is
6407 # the BMP at end of the arc (and it only has 1 incoming arc).
6408 # Or both can be BMPs with no incoming arcs.
6409 if {$a eq $b || $arcnos($a) eq {}} {
6410 return 0
6412 # assert {[llength $arcnos($a)] == 1}
6413 set arc [lindex $arcnos($a) 0]
6414 set i [lsearch -exact $arcids($arc) $a]
6415 set j [lsearch -exact $arcids($arc) $b]
6416 if {$i < 0 || $i > $j} {
6417 return 1
6418 } else {
6419 return -1
6423 if {![info exists arcout($a)]} {
6424 set arc [lindex $arcnos($a) 0]
6425 if {[info exists arcend($arc)]} {
6426 set aend $arcend($arc)
6427 } else {
6428 set aend {}
6430 set a $arcstart($arc)
6431 } else {
6432 set aend $a
6434 if {![info exists arcout($b)]} {
6435 set arc [lindex $arcnos($b) 0]
6436 if {[info exists arcend($arc)]} {
6437 set bend $arcend($arc)
6438 } else {
6439 set bend {}
6441 set b $arcstart($arc)
6442 } else {
6443 set bend $b
6445 if {$a eq $bend} {
6446 return 1
6448 if {$b eq $aend} {
6449 return -1
6451 if {[info exists cached_isanc($a,$bend)]} {
6452 if {$cached_isanc($a,$bend)} {
6453 return 1
6456 if {[info exists cached_isanc($b,$aend)]} {
6457 if {$cached_isanc($b,$aend)} {
6458 return -1
6460 if {[info exists cached_isanc($a,$bend)]} {
6461 return 0
6465 set todo [list $a $b]
6466 set anc($a) a
6467 set anc($b) b
6468 for {set i 0} {$i < [llength $todo]} {incr i} {
6469 set x [lindex $todo $i]
6470 if {$anc($x) eq {}} {
6471 continue
6473 foreach arc $arcnos($x) {
6474 set xd $arcstart($arc)
6475 if {$xd eq $bend} {
6476 set cached_isanc($a,$bend) 1
6477 set cached_isanc($b,$aend) 0
6478 return 1
6479 } elseif {$xd eq $aend} {
6480 set cached_isanc($b,$aend) 1
6481 set cached_isanc($a,$bend) 0
6482 return -1
6484 if {![info exists anc($xd)]} {
6485 set anc($xd) $anc($x)
6486 lappend todo $xd
6487 } elseif {$anc($xd) ne $anc($x)} {
6488 set anc($xd) {}
6492 set cached_isanc($a,$bend) 0
6493 set cached_isanc($b,$aend) 0
6494 return 0
6497 # This identifies whether $desc has an ancestor that is
6498 # a growing tip of the graph and which is not an ancestor of $anc
6499 # and returns 0 if so and 1 if not.
6500 # If we subsequently discover a tag on such a growing tip, and that
6501 # turns out to be a descendent of $anc (which it could, since we
6502 # don't necessarily see children before parents), then $desc
6503 # isn't a good choice to display as a descendent tag of
6504 # $anc (since it is the descendent of another tag which is
6505 # a descendent of $anc). Similarly, $anc isn't a good choice to
6506 # display as a ancestor tag of $desc.
6508 proc is_certain {desc anc} {
6509 global arcnos arcout arcstart arcend growing problems
6511 set certain {}
6512 if {[llength $arcnos($anc)] == 1} {
6513 # tags on the same arc are certain
6514 if {$arcnos($desc) eq $arcnos($anc)} {
6515 return 1
6517 if {![info exists arcout($anc)]} {
6518 # if $anc is partway along an arc, use the start of the arc instead
6519 set a [lindex $arcnos($anc) 0]
6520 set anc $arcstart($a)
6523 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6524 set x $desc
6525 } else {
6526 set a [lindex $arcnos($desc) 0]
6527 set x $arcend($a)
6529 if {$x == $anc} {
6530 return 1
6532 set anclist [list $x]
6533 set dl($x) 1
6534 set nnh 1
6535 set ngrowanc 0
6536 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6537 set x [lindex $anclist $i]
6538 if {$dl($x)} {
6539 incr nnh -1
6541 set done($x) 1
6542 foreach a $arcout($x) {
6543 if {[info exists growing($a)]} {
6544 if {![info exists growanc($x)] && $dl($x)} {
6545 set growanc($x) 1
6546 incr ngrowanc
6548 } else {
6549 set y $arcend($a)
6550 if {[info exists dl($y)]} {
6551 if {$dl($y)} {
6552 if {!$dl($x)} {
6553 set dl($y) 0
6554 if {![info exists done($y)]} {
6555 incr nnh -1
6557 if {[info exists growanc($x)]} {
6558 incr ngrowanc -1
6560 set xl [list $y]
6561 for {set k 0} {$k < [llength $xl]} {incr k} {
6562 set z [lindex $xl $k]
6563 foreach c $arcout($z) {
6564 if {[info exists arcend($c)]} {
6565 set v $arcend($c)
6566 if {[info exists dl($v)] && $dl($v)} {
6567 set dl($v) 0
6568 if {![info exists done($v)]} {
6569 incr nnh -1
6571 if {[info exists growanc($v)]} {
6572 incr ngrowanc -1
6574 lappend xl $v
6581 } elseif {$y eq $anc || !$dl($x)} {
6582 set dl($y) 0
6583 lappend anclist $y
6584 } else {
6585 set dl($y) 1
6586 lappend anclist $y
6587 incr nnh
6592 foreach x [array names growanc] {
6593 if {$dl($x)} {
6594 return 0
6596 return 0
6598 return 1
6601 proc validate_arctags {a} {
6602 global arctags idtags
6604 set i -1
6605 set na $arctags($a)
6606 foreach id $arctags($a) {
6607 incr i
6608 if {![info exists idtags($id)]} {
6609 set na [lreplace $na $i $i]
6610 incr i -1
6613 set arctags($a) $na
6616 proc validate_archeads {a} {
6617 global archeads idheads
6619 set i -1
6620 set na $archeads($a)
6621 foreach id $archeads($a) {
6622 incr i
6623 if {![info exists idheads($id)]} {
6624 set na [lreplace $na $i $i]
6625 incr i -1
6628 set archeads($a) $na
6631 # Return the list of IDs that have tags that are descendents of id,
6632 # ignoring IDs that are descendents of IDs already reported.
6633 proc desctags {id} {
6634 global arcnos arcstart arcids arctags idtags allparents
6635 global growing cached_dtags
6637 if {![info exists allparents($id)]} {
6638 return {}
6640 set t1 [clock clicks -milliseconds]
6641 set argid $id
6642 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6643 # part-way along an arc; check that arc first
6644 set a [lindex $arcnos($id) 0]
6645 if {$arctags($a) ne {}} {
6646 validate_arctags $a
6647 set i [lsearch -exact $arcids($a) $id]
6648 set tid {}
6649 foreach t $arctags($a) {
6650 set j [lsearch -exact $arcids($a) $t]
6651 if {$j >= $i} break
6652 set tid $t
6654 if {$tid ne {}} {
6655 return $tid
6658 set id $arcstart($a)
6659 if {[info exists idtags($id)]} {
6660 return $id
6663 if {[info exists cached_dtags($id)]} {
6664 return $cached_dtags($id)
6667 set origid $id
6668 set todo [list $id]
6669 set queued($id) 1
6670 set nc 1
6671 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6672 set id [lindex $todo $i]
6673 set done($id) 1
6674 set ta [info exists hastaggedancestor($id)]
6675 if {!$ta} {
6676 incr nc -1
6678 # ignore tags on starting node
6679 if {!$ta && $i > 0} {
6680 if {[info exists idtags($id)]} {
6681 set tagloc($id) $id
6682 set ta 1
6683 } elseif {[info exists cached_dtags($id)]} {
6684 set tagloc($id) $cached_dtags($id)
6685 set ta 1
6688 foreach a $arcnos($id) {
6689 set d $arcstart($a)
6690 if {!$ta && $arctags($a) ne {}} {
6691 validate_arctags $a
6692 if {$arctags($a) ne {}} {
6693 lappend tagloc($id) [lindex $arctags($a) end]
6696 if {$ta || $arctags($a) ne {}} {
6697 set tomark [list $d]
6698 for {set j 0} {$j < [llength $tomark]} {incr j} {
6699 set dd [lindex $tomark $j]
6700 if {![info exists hastaggedancestor($dd)]} {
6701 if {[info exists done($dd)]} {
6702 foreach b $arcnos($dd) {
6703 lappend tomark $arcstart($b)
6705 if {[info exists tagloc($dd)]} {
6706 unset tagloc($dd)
6708 } elseif {[info exists queued($dd)]} {
6709 incr nc -1
6711 set hastaggedancestor($dd) 1
6715 if {![info exists queued($d)]} {
6716 lappend todo $d
6717 set queued($d) 1
6718 if {![info exists hastaggedancestor($d)]} {
6719 incr nc
6724 set tags {}
6725 foreach id [array names tagloc] {
6726 if {![info exists hastaggedancestor($id)]} {
6727 foreach t $tagloc($id) {
6728 if {[lsearch -exact $tags $t] < 0} {
6729 lappend tags $t
6734 set t2 [clock clicks -milliseconds]
6735 set loopix $i
6737 # remove tags that are descendents of other tags
6738 for {set i 0} {$i < [llength $tags]} {incr i} {
6739 set a [lindex $tags $i]
6740 for {set j 0} {$j < $i} {incr j} {
6741 set b [lindex $tags $j]
6742 set r [anc_or_desc $a $b]
6743 if {$r == 1} {
6744 set tags [lreplace $tags $j $j]
6745 incr j -1
6746 incr i -1
6747 } elseif {$r == -1} {
6748 set tags [lreplace $tags $i $i]
6749 incr i -1
6750 break
6755 if {[array names growing] ne {}} {
6756 # graph isn't finished, need to check if any tag could get
6757 # eclipsed by another tag coming later. Simply ignore any
6758 # tags that could later get eclipsed.
6759 set ctags {}
6760 foreach t $tags {
6761 if {[is_certain $t $origid]} {
6762 lappend ctags $t
6765 if {$tags eq $ctags} {
6766 set cached_dtags($origid) $tags
6767 } else {
6768 set tags $ctags
6770 } else {
6771 set cached_dtags($origid) $tags
6773 set t3 [clock clicks -milliseconds]
6774 if {0 && $t3 - $t1 >= 100} {
6775 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6776 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6778 return $tags
6781 proc anctags {id} {
6782 global arcnos arcids arcout arcend arctags idtags allparents
6783 global growing cached_atags
6785 if {![info exists allparents($id)]} {
6786 return {}
6788 set t1 [clock clicks -milliseconds]
6789 set argid $id
6790 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6791 # part-way along an arc; check that arc first
6792 set a [lindex $arcnos($id) 0]
6793 if {$arctags($a) ne {}} {
6794 validate_arctags $a
6795 set i [lsearch -exact $arcids($a) $id]
6796 foreach t $arctags($a) {
6797 set j [lsearch -exact $arcids($a) $t]
6798 if {$j > $i} {
6799 return $t
6803 if {![info exists arcend($a)]} {
6804 return {}
6806 set id $arcend($a)
6807 if {[info exists idtags($id)]} {
6808 return $id
6811 if {[info exists cached_atags($id)]} {
6812 return $cached_atags($id)
6815 set origid $id
6816 set todo [list $id]
6817 set queued($id) 1
6818 set taglist {}
6819 set nc 1
6820 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6821 set id [lindex $todo $i]
6822 set done($id) 1
6823 set td [info exists hastaggeddescendent($id)]
6824 if {!$td} {
6825 incr nc -1
6827 # ignore tags on starting node
6828 if {!$td && $i > 0} {
6829 if {[info exists idtags($id)]} {
6830 set tagloc($id) $id
6831 set td 1
6832 } elseif {[info exists cached_atags($id)]} {
6833 set tagloc($id) $cached_atags($id)
6834 set td 1
6837 foreach a $arcout($id) {
6838 if {!$td && $arctags($a) ne {}} {
6839 validate_arctags $a
6840 if {$arctags($a) ne {}} {
6841 lappend tagloc($id) [lindex $arctags($a) 0]
6844 if {![info exists arcend($a)]} continue
6845 set d $arcend($a)
6846 if {$td || $arctags($a) ne {}} {
6847 set tomark [list $d]
6848 for {set j 0} {$j < [llength $tomark]} {incr j} {
6849 set dd [lindex $tomark $j]
6850 if {![info exists hastaggeddescendent($dd)]} {
6851 if {[info exists done($dd)]} {
6852 foreach b $arcout($dd) {
6853 if {[info exists arcend($b)]} {
6854 lappend tomark $arcend($b)
6857 if {[info exists tagloc($dd)]} {
6858 unset tagloc($dd)
6860 } elseif {[info exists queued($dd)]} {
6861 incr nc -1
6863 set hastaggeddescendent($dd) 1
6867 if {![info exists queued($d)]} {
6868 lappend todo $d
6869 set queued($d) 1
6870 if {![info exists hastaggeddescendent($d)]} {
6871 incr nc
6876 set t2 [clock clicks -milliseconds]
6877 set loopix $i
6878 set tags {}
6879 foreach id [array names tagloc] {
6880 if {![info exists hastaggeddescendent($id)]} {
6881 foreach t $tagloc($id) {
6882 if {[lsearch -exact $tags $t] < 0} {
6883 lappend tags $t
6889 # remove tags that are ancestors of other tags
6890 for {set i 0} {$i < [llength $tags]} {incr i} {
6891 set a [lindex $tags $i]
6892 for {set j 0} {$j < $i} {incr j} {
6893 set b [lindex $tags $j]
6894 set r [anc_or_desc $a $b]
6895 if {$r == -1} {
6896 set tags [lreplace $tags $j $j]
6897 incr j -1
6898 incr i -1
6899 } elseif {$r == 1} {
6900 set tags [lreplace $tags $i $i]
6901 incr i -1
6902 break
6907 if {[array names growing] ne {}} {
6908 # graph isn't finished, need to check if any tag could get
6909 # eclipsed by another tag coming later. Simply ignore any
6910 # tags that could later get eclipsed.
6911 set ctags {}
6912 foreach t $tags {
6913 if {[is_certain $origid $t]} {
6914 lappend ctags $t
6917 if {$tags eq $ctags} {
6918 set cached_atags($origid) $tags
6919 } else {
6920 set tags $ctags
6922 } else {
6923 set cached_atags($origid) $tags
6925 set t3 [clock clicks -milliseconds]
6926 if {0 && $t3 - $t1 >= 100} {
6927 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6928 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6930 return $tags
6933 # Return the list of IDs that have heads that are descendents of id,
6934 # including id itself if it has a head.
6935 proc descheads {id} {
6936 global arcnos arcstart arcids archeads idheads cached_dheads
6937 global allparents
6939 if {![info exists allparents($id)]} {
6940 return {}
6942 set aret {}
6943 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6944 # part-way along an arc; check it first
6945 set a [lindex $arcnos($id) 0]
6946 if {$archeads($a) ne {}} {
6947 validate_archeads $a
6948 set i [lsearch -exact $arcids($a) $id]
6949 foreach t $archeads($a) {
6950 set j [lsearch -exact $arcids($a) $t]
6951 if {$j > $i} break
6952 lappend aret $t
6955 set id $arcstart($a)
6957 set origid $id
6958 set todo [list $id]
6959 set seen($id) 1
6960 set ret {}
6961 for {set i 0} {$i < [llength $todo]} {incr i} {
6962 set id [lindex $todo $i]
6963 if {[info exists cached_dheads($id)]} {
6964 set ret [concat $ret $cached_dheads($id)]
6965 } else {
6966 if {[info exists idheads($id)]} {
6967 lappend ret $id
6969 foreach a $arcnos($id) {
6970 if {$archeads($a) ne {}} {
6971 validate_archeads $a
6972 if {$archeads($a) ne {}} {
6973 set ret [concat $ret $archeads($a)]
6976 set d $arcstart($a)
6977 if {![info exists seen($d)]} {
6978 lappend todo $d
6979 set seen($d) 1
6984 set ret [lsort -unique $ret]
6985 set cached_dheads($origid) $ret
6986 return [concat $ret $aret]
6989 proc addedtag {id} {
6990 global arcnos arcout cached_dtags cached_atags
6992 if {![info exists arcnos($id)]} return
6993 if {![info exists arcout($id)]} {
6994 recalcarc [lindex $arcnos($id) 0]
6996 catch {unset cached_dtags}
6997 catch {unset cached_atags}
7000 proc addedhead {hid head} {
7001 global arcnos arcout cached_dheads
7003 if {![info exists arcnos($hid)]} return
7004 if {![info exists arcout($hid)]} {
7005 recalcarc [lindex $arcnos($hid) 0]
7007 catch {unset cached_dheads}
7010 proc removedhead {hid head} {
7011 global cached_dheads
7013 catch {unset cached_dheads}
7016 proc movedhead {hid head} {
7017 global arcnos arcout cached_dheads
7019 if {![info exists arcnos($hid)]} return
7020 if {![info exists arcout($hid)]} {
7021 recalcarc [lindex $arcnos($hid) 0]
7023 catch {unset cached_dheads}
7026 proc changedrefs {} {
7027 global cached_dheads cached_dtags cached_atags
7028 global arctags archeads arcnos arcout idheads idtags
7030 foreach id [concat [array names idheads] [array names idtags]] {
7031 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7032 set a [lindex $arcnos($id) 0]
7033 if {![info exists donearc($a)]} {
7034 recalcarc $a
7035 set donearc($a) 1
7039 catch {unset cached_dtags}
7040 catch {unset cached_atags}
7041 catch {unset cached_dheads}
7044 proc rereadrefs {} {
7045 global idtags idheads idotherrefs mainhead
7047 set refids [concat [array names idtags] \
7048 [array names idheads] [array names idotherrefs]]
7049 foreach id $refids {
7050 if {![info exists ref($id)]} {
7051 set ref($id) [listrefs $id]
7054 set oldmainhead $mainhead
7055 readrefs
7056 changedrefs
7057 set refids [lsort -unique [concat $refids [array names idtags] \
7058 [array names idheads] [array names idotherrefs]]]
7059 foreach id $refids {
7060 set v [listrefs $id]
7061 if {![info exists ref($id)] || $ref($id) != $v ||
7062 ($id eq $oldmainhead && $id ne $mainhead) ||
7063 ($id eq $mainhead && $id ne $oldmainhead)} {
7064 redrawtags $id
7069 proc listrefs {id} {
7070 global idtags idheads idotherrefs
7072 set x {}
7073 if {[info exists idtags($id)]} {
7074 set x $idtags($id)
7076 set y {}
7077 if {[info exists idheads($id)]} {
7078 set y $idheads($id)
7080 set z {}
7081 if {[info exists idotherrefs($id)]} {
7082 set z $idotherrefs($id)
7084 return [list $x $y $z]
7087 proc showtag {tag isnew} {
7088 global ctext tagcontents tagids linknum tagobjid
7090 if {$isnew} {
7091 addtohistory [list showtag $tag 0]
7093 $ctext conf -state normal
7094 clear_ctext
7095 set linknum 0
7096 if {![info exists tagcontents($tag)]} {
7097 catch {
7098 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7101 if {[info exists tagcontents($tag)]} {
7102 set text $tagcontents($tag)
7103 } else {
7104 set text "Tag: $tag\nId: $tagids($tag)"
7106 appendwithlinks $text {}
7107 $ctext conf -state disabled
7108 init_flist {}
7111 proc doquit {} {
7112 global stopped
7113 set stopped 100
7114 savestuff .
7115 destroy .
7118 proc doprefs {} {
7119 global maxwidth maxgraphpct diffopts
7120 global oldprefs prefstop showneartags showlocalchanges
7121 global bgcolor fgcolor ctext diffcolors selectbgcolor
7122 global uifont tabstop
7124 set top .gitkprefs
7125 set prefstop $top
7126 if {[winfo exists $top]} {
7127 raise $top
7128 return
7130 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7131 set oldprefs($v) [set $v]
7133 toplevel $top
7134 wm title $top "Gitk preferences"
7135 label $top.ldisp -text "Commit list display options"
7136 $top.ldisp configure -font $uifont
7137 grid $top.ldisp - -sticky w -pady 10
7138 label $top.spacer -text " "
7139 label $top.maxwidthl -text "Maximum graph width (lines)" \
7140 -font optionfont
7141 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7142 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7143 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7144 -font optionfont
7145 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7146 grid x $top.maxpctl $top.maxpct -sticky w
7147 frame $top.showlocal
7148 label $top.showlocal.l -text "Show local changes" -font optionfont
7149 checkbutton $top.showlocal.b -variable showlocalchanges
7150 pack $top.showlocal.b $top.showlocal.l -side left
7151 grid x $top.showlocal -sticky w
7153 label $top.ddisp -text "Diff display options"
7154 $top.ddisp configure -font $uifont
7155 grid $top.ddisp - -sticky w -pady 10
7156 label $top.diffoptl -text "Options for diff program" \
7157 -font optionfont
7158 entry $top.diffopt -width 20 -textvariable diffopts
7159 grid x $top.diffoptl $top.diffopt -sticky w
7160 frame $top.ntag
7161 label $top.ntag.l -text "Display nearby tags" -font optionfont
7162 checkbutton $top.ntag.b -variable showneartags
7163 pack $top.ntag.b $top.ntag.l -side left
7164 grid x $top.ntag -sticky w
7165 label $top.tabstopl -text "tabstop" -font optionfont
7166 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7167 grid x $top.tabstopl $top.tabstop -sticky w
7169 label $top.cdisp -text "Colors: press to choose"
7170 $top.cdisp configure -font $uifont
7171 grid $top.cdisp - -sticky w -pady 10
7172 label $top.bg -padx 40 -relief sunk -background $bgcolor
7173 button $top.bgbut -text "Background" -font optionfont \
7174 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7175 grid x $top.bgbut $top.bg -sticky w
7176 label $top.fg -padx 40 -relief sunk -background $fgcolor
7177 button $top.fgbut -text "Foreground" -font optionfont \
7178 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7179 grid x $top.fgbut $top.fg -sticky w
7180 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7181 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7182 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7183 [list $ctext tag conf d0 -foreground]]
7184 grid x $top.diffoldbut $top.diffold -sticky w
7185 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7186 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7187 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7188 [list $ctext tag conf d1 -foreground]]
7189 grid x $top.diffnewbut $top.diffnew -sticky w
7190 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7191 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7192 -command [list choosecolor diffcolors 2 $top.hunksep \
7193 "diff hunk header" \
7194 [list $ctext tag conf hunksep -foreground]]
7195 grid x $top.hunksepbut $top.hunksep -sticky w
7196 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7197 button $top.selbgbut -text "Select bg" -font optionfont \
7198 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7199 grid x $top.selbgbut $top.selbgsep -sticky w
7201 frame $top.buts
7202 button $top.buts.ok -text "OK" -command prefsok -default active
7203 $top.buts.ok configure -font $uifont
7204 button $top.buts.can -text "Cancel" -command prefscan -default normal
7205 $top.buts.can configure -font $uifont
7206 grid $top.buts.ok $top.buts.can
7207 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7208 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7209 grid $top.buts - - -pady 10 -sticky ew
7210 bind $top <Visibility> "focus $top.buts.ok"
7213 proc choosecolor {v vi w x cmd} {
7214 global $v
7216 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7217 -title "Gitk: choose color for $x"]
7218 if {$c eq {}} return
7219 $w conf -background $c
7220 lset $v $vi $c
7221 eval $cmd $c
7224 proc setselbg {c} {
7225 global bglist cflist
7226 foreach w $bglist {
7227 $w configure -selectbackground $c
7229 $cflist tag configure highlight \
7230 -background [$cflist cget -selectbackground]
7231 allcanvs itemconf secsel -fill $c
7234 proc setbg {c} {
7235 global bglist
7237 foreach w $bglist {
7238 $w conf -background $c
7242 proc setfg {c} {
7243 global fglist canv
7245 foreach w $fglist {
7246 $w conf -foreground $c
7248 allcanvs itemconf text -fill $c
7249 $canv itemconf circle -outline $c
7252 proc prefscan {} {
7253 global maxwidth maxgraphpct diffopts
7254 global oldprefs prefstop showneartags showlocalchanges
7256 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7257 set $v $oldprefs($v)
7259 catch {destroy $prefstop}
7260 unset prefstop
7263 proc prefsok {} {
7264 global maxwidth maxgraphpct
7265 global oldprefs prefstop showneartags showlocalchanges
7266 global charspc ctext tabstop
7268 catch {destroy $prefstop}
7269 unset prefstop
7270 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7271 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7272 if {$showlocalchanges} {
7273 doshowlocalchanges
7274 } else {
7275 dohidelocalchanges
7278 if {$maxwidth != $oldprefs(maxwidth)
7279 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7280 redisplay
7281 } elseif {$showneartags != $oldprefs(showneartags)} {
7282 reselectline
7286 proc formatdate {d} {
7287 if {$d ne {}} {
7288 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7290 return $d
7293 # This list of encoding names and aliases is distilled from
7294 # http://www.iana.org/assignments/character-sets.
7295 # Not all of them are supported by Tcl.
7296 set encoding_aliases {
7297 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7298 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7299 { ISO-10646-UTF-1 csISO10646UTF1 }
7300 { ISO_646.basic:1983 ref csISO646basic1983 }
7301 { INVARIANT csINVARIANT }
7302 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7303 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7304 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7305 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7306 { NATS-DANO iso-ir-9-1 csNATSDANO }
7307 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7308 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7309 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7310 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7311 { ISO-2022-KR csISO2022KR }
7312 { EUC-KR csEUCKR }
7313 { ISO-2022-JP csISO2022JP }
7314 { ISO-2022-JP-2 csISO2022JP2 }
7315 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7316 csISO13JISC6220jp }
7317 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7318 { IT iso-ir-15 ISO646-IT csISO15Italian }
7319 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7320 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7321 { greek7-old iso-ir-18 csISO18Greek7Old }
7322 { latin-greek iso-ir-19 csISO19LatinGreek }
7323 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7324 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7325 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7326 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7327 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7328 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7329 { INIS iso-ir-49 csISO49INIS }
7330 { INIS-8 iso-ir-50 csISO50INIS8 }
7331 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7332 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7333 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7334 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7335 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7336 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7337 csISO60Norwegian1 }
7338 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7339 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7340 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7341 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7342 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7343 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7344 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7345 { greek7 iso-ir-88 csISO88Greek7 }
7346 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7347 { iso-ir-90 csISO90 }
7348 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7349 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7350 csISO92JISC62991984b }
7351 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7352 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7353 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7354 csISO95JIS62291984handadd }
7355 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7356 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7357 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7358 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7359 CP819 csISOLatin1 }
7360 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7361 { T.61-7bit iso-ir-102 csISO102T617bit }
7362 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7363 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7364 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7365 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7366 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7367 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7368 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7369 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7370 arabic csISOLatinArabic }
7371 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7372 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7373 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7374 greek greek8 csISOLatinGreek }
7375 { T.101-G2 iso-ir-128 csISO128T101G2 }
7376 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7377 csISOLatinHebrew }
7378 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7379 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7380 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7381 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7382 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7383 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7384 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7385 csISOLatinCyrillic }
7386 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7387 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7388 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7389 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7390 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7391 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7392 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7393 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7394 { ISO_10367-box iso-ir-155 csISO10367Box }
7395 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7396 { latin-lap lap iso-ir-158 csISO158Lap }
7397 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7398 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7399 { us-dk csUSDK }
7400 { dk-us csDKUS }
7401 { JIS_X0201 X0201 csHalfWidthKatakana }
7402 { KSC5636 ISO646-KR csKSC5636 }
7403 { ISO-10646-UCS-2 csUnicode }
7404 { ISO-10646-UCS-4 csUCS4 }
7405 { DEC-MCS dec csDECMCS }
7406 { hp-roman8 roman8 r8 csHPRoman8 }
7407 { macintosh mac csMacintosh }
7408 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7409 csIBM037 }
7410 { IBM038 EBCDIC-INT cp038 csIBM038 }
7411 { IBM273 CP273 csIBM273 }
7412 { IBM274 EBCDIC-BE CP274 csIBM274 }
7413 { IBM275 EBCDIC-BR cp275 csIBM275 }
7414 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7415 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7416 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7417 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7418 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7419 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7420 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7421 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7422 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7423 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7424 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7425 { IBM437 cp437 437 csPC8CodePage437 }
7426 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7427 { IBM775 cp775 csPC775Baltic }
7428 { IBM850 cp850 850 csPC850Multilingual }
7429 { IBM851 cp851 851 csIBM851 }
7430 { IBM852 cp852 852 csPCp852 }
7431 { IBM855 cp855 855 csIBM855 }
7432 { IBM857 cp857 857 csIBM857 }
7433 { IBM860 cp860 860 csIBM860 }
7434 { IBM861 cp861 861 cp-is csIBM861 }
7435 { IBM862 cp862 862 csPC862LatinHebrew }
7436 { IBM863 cp863 863 csIBM863 }
7437 { IBM864 cp864 csIBM864 }
7438 { IBM865 cp865 865 csIBM865 }
7439 { IBM866 cp866 866 csIBM866 }
7440 { IBM868 CP868 cp-ar csIBM868 }
7441 { IBM869 cp869 869 cp-gr csIBM869 }
7442 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7443 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7444 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7445 { IBM891 cp891 csIBM891 }
7446 { IBM903 cp903 csIBM903 }
7447 { IBM904 cp904 904 csIBBM904 }
7448 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7449 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7450 { IBM1026 CP1026 csIBM1026 }
7451 { EBCDIC-AT-DE csIBMEBCDICATDE }
7452 { EBCDIC-AT-DE-A csEBCDICATDEA }
7453 { EBCDIC-CA-FR csEBCDICCAFR }
7454 { EBCDIC-DK-NO csEBCDICDKNO }
7455 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7456 { EBCDIC-FI-SE csEBCDICFISE }
7457 { EBCDIC-FI-SE-A csEBCDICFISEA }
7458 { EBCDIC-FR csEBCDICFR }
7459 { EBCDIC-IT csEBCDICIT }
7460 { EBCDIC-PT csEBCDICPT }
7461 { EBCDIC-ES csEBCDICES }
7462 { EBCDIC-ES-A csEBCDICESA }
7463 { EBCDIC-ES-S csEBCDICESS }
7464 { EBCDIC-UK csEBCDICUK }
7465 { EBCDIC-US csEBCDICUS }
7466 { UNKNOWN-8BIT csUnknown8BiT }
7467 { MNEMONIC csMnemonic }
7468 { MNEM csMnem }
7469 { VISCII csVISCII }
7470 { VIQR csVIQR }
7471 { KOI8-R csKOI8R }
7472 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7473 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7474 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7475 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7476 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7477 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7478 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7479 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7480 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7481 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7482 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7483 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7484 { IBM1047 IBM-1047 }
7485 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7486 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7487 { UNICODE-1-1 csUnicode11 }
7488 { CESU-8 csCESU-8 }
7489 { BOCU-1 csBOCU-1 }
7490 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7491 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7492 l8 }
7493 { ISO-8859-15 ISO_8859-15 Latin-9 }
7494 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7495 { GBK CP936 MS936 windows-936 }
7496 { JIS_Encoding csJISEncoding }
7497 { Shift_JIS MS_Kanji csShiftJIS }
7498 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7499 EUC-JP }
7500 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7501 { ISO-10646-UCS-Basic csUnicodeASCII }
7502 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7503 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7504 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7505 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7506 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7507 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7508 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7509 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7510 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7511 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7512 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7513 { Ventura-US csVenturaUS }
7514 { Ventura-International csVenturaInternational }
7515 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7516 { PC8-Turkish csPC8Turkish }
7517 { IBM-Symbols csIBMSymbols }
7518 { IBM-Thai csIBMThai }
7519 { HP-Legal csHPLegal }
7520 { HP-Pi-font csHPPiFont }
7521 { HP-Math8 csHPMath8 }
7522 { Adobe-Symbol-Encoding csHPPSMath }
7523 { HP-DeskTop csHPDesktop }
7524 { Ventura-Math csVenturaMath }
7525 { Microsoft-Publishing csMicrosoftPublishing }
7526 { Windows-31J csWindows31J }
7527 { GB2312 csGB2312 }
7528 { Big5 csBig5 }
7531 proc tcl_encoding {enc} {
7532 global encoding_aliases
7533 set names [encoding names]
7534 set lcnames [string tolower $names]
7535 set enc [string tolower $enc]
7536 set i [lsearch -exact $lcnames $enc]
7537 if {$i < 0} {
7538 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7539 if {[regsub {^iso[-_]} $enc iso encx]} {
7540 set i [lsearch -exact $lcnames $encx]
7543 if {$i < 0} {
7544 foreach l $encoding_aliases {
7545 set ll [string tolower $l]
7546 if {[lsearch -exact $ll $enc] < 0} continue
7547 # look through the aliases for one that tcl knows about
7548 foreach e $ll {
7549 set i [lsearch -exact $lcnames $e]
7550 if {$i < 0} {
7551 if {[regsub {^iso[-_]} $e iso ex]} {
7552 set i [lsearch -exact $lcnames $ex]
7555 if {$i >= 0} break
7557 break
7560 if {$i >= 0} {
7561 return [lindex $names $i]
7563 return {}
7566 # defaults...
7567 set datemode 0
7568 set diffopts "-U 5 -p"
7569 set wrcomcmd "git diff-tree --stdin -p --pretty"
7571 set gitencoding {}
7572 catch {
7573 set gitencoding [exec git config --get i18n.commitencoding]
7575 if {$gitencoding == ""} {
7576 set gitencoding "utf-8"
7578 set tclencoding [tcl_encoding $gitencoding]
7579 if {$tclencoding == {}} {
7580 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7583 set mainfont {Helvetica 9}
7584 set textfont {Courier 9}
7585 set uifont {Helvetica 9 bold}
7586 set tabstop 8
7587 set findmergefiles 0
7588 set maxgraphpct 50
7589 set maxwidth 16
7590 set revlistorder 0
7591 set fastdate 0
7592 set uparrowlen 7
7593 set downarrowlen 7
7594 set mingaplen 30
7595 set cmitmode "patch"
7596 set wrapcomment "none"
7597 set showneartags 1
7598 set maxrefs 20
7599 set maxlinelen 200
7600 set showlocalchanges 1
7602 set colors {green red blue magenta darkgrey brown orange}
7603 set bgcolor white
7604 set fgcolor black
7605 set diffcolors {red "#00a000" blue}
7606 set selectbgcolor gray85
7608 catch {source ~/.gitk}
7610 font create optionfont -family sans-serif -size -12
7612 # check that we can find a .git directory somewhere...
7613 set gitdir [gitdir]
7614 if {![file isdirectory $gitdir]} {
7615 show_error {} . "Cannot find the git directory \"$gitdir\"."
7616 exit 1
7619 set revtreeargs {}
7620 set cmdline_files {}
7621 set i 0
7622 foreach arg $argv {
7623 switch -- $arg {
7624 "" { }
7625 "-d" { set datemode 1 }
7626 "--" {
7627 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7628 break
7630 default {
7631 lappend revtreeargs $arg
7634 incr i
7637 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7638 # no -- on command line, but some arguments (other than -d)
7639 if {[catch {
7640 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7641 set cmdline_files [split $f "\n"]
7642 set n [llength $cmdline_files]
7643 set revtreeargs [lrange $revtreeargs 0 end-$n]
7644 # Unfortunately git rev-parse doesn't produce an error when
7645 # something is both a revision and a filename. To be consistent
7646 # with git log and git rev-list, check revtreeargs for filenames.
7647 foreach arg $revtreeargs {
7648 if {[file exists $arg]} {
7649 show_error {} . "Ambiguous argument '$arg': both revision\
7650 and filename"
7651 exit 1
7654 } err]} {
7655 # unfortunately we get both stdout and stderr in $err,
7656 # so look for "fatal:".
7657 set i [string first "fatal:" $err]
7658 if {$i > 0} {
7659 set err [string range $err [expr {$i + 6}] end]
7661 show_error {} . "Bad arguments to gitk:\n$err"
7662 exit 1
7666 set nullid "0000000000000000000000000000000000000000"
7667 set nullid2 "0000000000000000000000000000000000000001"
7670 set runq {}
7671 set history {}
7672 set historyindex 0
7673 set fh_serial 0
7674 set nhl_names {}
7675 set highlight_paths {}
7676 set searchdirn -forwards
7677 set boldrows {}
7678 set boldnamerows {}
7679 set diffelide {0 0}
7680 set markingmatches 0
7682 set optim_delay 16
7684 set nextviewnum 1
7685 set curview 0
7686 set selectedview 0
7687 set selectedhlview None
7688 set viewfiles(0) {}
7689 set viewperm(0) 0
7690 set viewargs(0) {}
7692 set cmdlineok 0
7693 set stopped 0
7694 set stuffsaved 0
7695 set patchnum 0
7696 set lookingforhead 0
7697 set localirow -1
7698 set localfrow -1
7699 set lserial 0
7700 setcoords
7701 makewindow
7702 # wait for the window to become visible
7703 tkwait visibility .
7704 wm title . "[file tail $argv0]: [file tail [pwd]]"
7705 readrefs
7707 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7708 # create a view for the files/dirs specified on the command line
7709 set curview 1
7710 set selectedview 1
7711 set nextviewnum 2
7712 set viewname(1) "Command line"
7713 set viewfiles(1) $cmdline_files
7714 set viewargs(1) $revtreeargs
7715 set viewperm(1) 0
7716 addviewmenu 1
7717 .bar.view entryconf Edit* -state normal
7718 .bar.view entryconf Delete* -state normal
7721 if {[info exists permviews]} {
7722 foreach v $permviews {
7723 set n $nextviewnum
7724 incr nextviewnum
7725 set viewname($n) [lindex $v 0]
7726 set viewfiles($n) [lindex $v 1]
7727 set viewargs($n) [lindex $v 2]
7728 set viewperm($n) 1
7729 addviewmenu $n
7732 getcommits