gitk: Get rid of idinlist array
[git/mingw.git] / gitk
blob7b0b4cfade0a6c225a8fd37555eb4a8e554be6ec
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc dorunq {} {
51 global isonrunq runq
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
76 if {$runq ne {}} {
77 after idle dorunq
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx vnextroot
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set vnextroot($view) 0
91 set order "--topo-order"
92 if {$datemode} {
93 set order "--date-order"
95 if {[catch {
96 set fd [open [concat | git log -z --pretty=raw $order --parents \
97 --boundary $viewargs($view) "--" $viewfiles($view)] r]
98 } err]} {
99 error_popup "Error executing git rev-list: $err"
100 exit 1
102 set commfd($view) $fd
103 set leftover($view) {}
104 set lookingforhead $showlocalchanges
105 fconfigure $fd -blocking 0 -translation lf -eofchar {}
106 if {$tclencoding != {}} {
107 fconfigure $fd -encoding $tclencoding
109 filerun $fd [list getcommitlines $fd $view]
110 nowbusy $view
113 proc stop_rev_list {} {
114 global commfd curview
116 if {![info exists commfd($curview)]} return
117 set fd $commfd($curview)
118 catch {
119 set pid [pid $fd]
120 exec kill $pid
122 catch {close $fd}
123 unset commfd($curview)
126 proc getcommits {} {
127 global phase canv mainfont curview
129 set phase getcommits
130 initlayout
131 start_rev_list $curview
132 show_status "Reading commits..."
135 # This makes a string representation of a positive integer which
136 # sorts as a string in numerical order
137 proc strrep {n} {
138 if {$n < 16} {
139 return [format "%x" $n]
140 } elseif {$n < 256} {
141 return [format "x%.2x" $n]
142 } elseif {$n < 65536} {
143 return [format "y%.4x" $n]
145 return [format "z%.8x" $n]
148 proc getcommitlines {fd view} {
149 global commitlisted
150 global leftover commfd
151 global displayorder commitidx commitrow commitdata
152 global parentlist children curview hlview
153 global vparentlist vdisporder vcmitlisted
154 global ordertok vnextroot idpending
156 set stuff [read $fd 500000]
157 # git log doesn't terminate the last commit with a null...
158 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
159 set stuff "\0"
161 if {$stuff == {}} {
162 if {![eof $fd]} {
163 return 1
165 # Check if we have seen any ids listed as parents that haven't
166 # appeared in the list
167 foreach vid [array names idpending "$view,*"] {
168 # should only get here if git log is buggy
169 set id [lindex [split $vid ","] 1]
170 set commitrow($vid) $commitidx($view)
171 incr commitidx($view)
172 if {$view == $curview} {
173 lappend parentlist {}
174 lappend displayorder $id
175 lappend commitlisted 0
176 } else {
177 lappend vparentlist($view) {}
178 lappend vdisporder($view) $id
179 lappend vcmitlisted($view) 0
182 global viewname
183 unset commfd($view)
184 notbusy $view
185 # set it blocking so we wait for the process to terminate
186 fconfigure $fd -blocking 1
187 if {[catch {close $fd} err]} {
188 set fv {}
189 if {$view != $curview} {
190 set fv " for the \"$viewname($view)\" view"
192 if {[string range $err 0 4] == "usage"} {
193 set err "Gitk: error reading commits$fv:\
194 bad arguments to git rev-list."
195 if {$viewname($view) eq "Command line"} {
196 append err \
197 " (Note: arguments to gitk are passed to git rev-list\
198 to allow selection of commits to be displayed.)"
200 } else {
201 set err "Error reading commits$fv: $err"
203 error_popup $err
205 if {$view == $curview} {
206 run chewcommits $view
208 return 0
210 set start 0
211 set gotsome 0
212 while 1 {
213 set i [string first "\0" $stuff $start]
214 if {$i < 0} {
215 append leftover($view) [string range $stuff $start end]
216 break
218 if {$start == 0} {
219 set cmit $leftover($view)
220 append cmit [string range $stuff 0 [expr {$i - 1}]]
221 set leftover($view) {}
222 } else {
223 set cmit [string range $stuff $start [expr {$i - 1}]]
225 set start [expr {$i + 1}]
226 set j [string first "\n" $cmit]
227 set ok 0
228 set listed 1
229 if {$j >= 0 && [string match "commit *" $cmit]} {
230 set ids [string range $cmit 7 [expr {$j - 1}]]
231 if {[string match {[-<>]*} $ids]} {
232 switch -- [string index $ids 0] {
233 "-" {set listed 0}
234 "<" {set listed 2}
235 ">" {set listed 3}
237 set ids [string range $ids 1 end]
239 set ok 1
240 foreach id $ids {
241 if {[string length $id] != 40} {
242 set ok 0
243 break
247 if {!$ok} {
248 set shortcmit $cmit
249 if {[string length $shortcmit] > 80} {
250 set shortcmit "[string range $shortcmit 0 80]..."
252 error_popup "Can't parse git log output: {$shortcmit}"
253 exit 1
255 set id [lindex $ids 0]
256 if {![info exists ordertok($view,$id)]} {
257 set otok "o[strrep $vnextroot($view)]"
258 incr vnextroot($view)
259 set ordertok($view,$id) $otok
260 } else {
261 set otok $ordertok($view,$id)
262 unset idpending($view,$id)
264 if {$listed} {
265 set olds [lrange $ids 1 end]
266 if {[llength $olds] == 1} {
267 set p [lindex $olds 0]
268 lappend children($view,$p) $id
269 if {![info exists ordertok($view,$p)]} {
270 set ordertok($view,$p) $ordertok($view,$id)
271 set idpending($view,$p) 1
273 } else {
274 set i 0
275 foreach p $olds {
276 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
277 lappend children($view,$p) $id
279 if {![info exists ordertok($view,$p)]} {
280 set ordertok($view,$p) "$otok[strrep $i]]"
281 set idpending($view,$p) 1
283 incr i
286 } else {
287 set olds {}
289 if {![info exists children($view,$id)]} {
290 set children($view,$id) {}
292 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
293 set commitrow($view,$id) $commitidx($view)
294 incr commitidx($view)
295 if {$view == $curview} {
296 lappend parentlist $olds
297 lappend displayorder $id
298 lappend commitlisted $listed
299 } else {
300 lappend vparentlist($view) $olds
301 lappend vdisporder($view) $id
302 lappend vcmitlisted($view) $listed
304 set gotsome 1
306 if {$gotsome} {
307 run chewcommits $view
309 return 2
312 proc chewcommits {view} {
313 global curview hlview commfd
314 global selectedline pending_select
316 set more 0
317 if {$view == $curview} {
318 set allread [expr {![info exists commfd($view)]}]
319 set tlimit [expr {[clock clicks -milliseconds] + 50}]
320 set more [layoutmore $tlimit $allread]
321 if {$allread && !$more} {
322 global displayorder commitidx phase
323 global numcommits startmsecs
325 if {[info exists pending_select]} {
326 set row [first_real_row]
327 selectline $row 1
329 if {$commitidx($curview) > 0} {
330 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
331 #puts "overall $ms ms for $numcommits commits"
332 } else {
333 show_status "No commits selected"
335 notbusy layout
336 set phase {}
339 if {[info exists hlview] && $view == $hlview} {
340 vhighlightmore
342 return $more
345 proc readcommit {id} {
346 if {[catch {set contents [exec git cat-file commit $id]}]} return
347 parsecommit $id $contents 0
350 proc updatecommits {} {
351 global viewdata curview phase displayorder ordertok idpending
352 global children commitrow selectedline thickerline showneartags
354 if {$phase ne {}} {
355 stop_rev_list
356 set phase {}
358 set n $curview
359 foreach id $displayorder {
360 catch {unset children($n,$id)}
361 catch {unset commitrow($n,$id)}
362 catch {unset ordertok($n,$id)}
364 foreach vid [array names idpending "$n,*"] {
365 unset idpending($vid)
367 set curview -1
368 catch {unset selectedline}
369 catch {unset thickerline}
370 catch {unset viewdata($n)}
371 readrefs
372 changedrefs
373 if {$showneartags} {
374 getallcommits
376 showview $n
379 proc parsecommit {id contents listed} {
380 global commitinfo cdate
382 set inhdr 1
383 set comment {}
384 set headline {}
385 set auname {}
386 set audate {}
387 set comname {}
388 set comdate {}
389 set hdrend [string first "\n\n" $contents]
390 if {$hdrend < 0} {
391 # should never happen...
392 set hdrend [string length $contents]
394 set header [string range $contents 0 [expr {$hdrend - 1}]]
395 set comment [string range $contents [expr {$hdrend + 2}] end]
396 foreach line [split $header "\n"] {
397 set tag [lindex $line 0]
398 if {$tag == "author"} {
399 set audate [lindex $line end-1]
400 set auname [lrange $line 1 end-2]
401 } elseif {$tag == "committer"} {
402 set comdate [lindex $line end-1]
403 set comname [lrange $line 1 end-2]
406 set headline {}
407 # take the first non-blank line of the comment as the headline
408 set headline [string trimleft $comment]
409 set i [string first "\n" $headline]
410 if {$i >= 0} {
411 set headline [string range $headline 0 $i]
413 set headline [string trimright $headline]
414 set i [string first "\r" $headline]
415 if {$i >= 0} {
416 set headline [string trimright [string range $headline 0 $i]]
418 if {!$listed} {
419 # git rev-list indents the comment by 4 spaces;
420 # if we got this via git cat-file, add the indentation
421 set newcomment {}
422 foreach line [split $comment "\n"] {
423 append newcomment " "
424 append newcomment $line
425 append newcomment "\n"
427 set comment $newcomment
429 if {$comdate != {}} {
430 set cdate($id) $comdate
432 set commitinfo($id) [list $headline $auname $audate \
433 $comname $comdate $comment]
436 proc getcommit {id} {
437 global commitdata commitinfo
439 if {[info exists commitdata($id)]} {
440 parsecommit $id $commitdata($id) 1
441 } else {
442 readcommit $id
443 if {![info exists commitinfo($id)]} {
444 set commitinfo($id) {"No commit information available"}
447 return 1
450 proc readrefs {} {
451 global tagids idtags headids idheads tagobjid
452 global otherrefids idotherrefs mainhead mainheadid
454 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
455 catch {unset $v}
457 set refd [open [list | git show-ref -d] r]
458 while {[gets $refd line] >= 0} {
459 if {[string index $line 40] ne " "} continue
460 set id [string range $line 0 39]
461 set ref [string range $line 41 end]
462 if {![string match "refs/*" $ref]} continue
463 set name [string range $ref 5 end]
464 if {[string match "remotes/*" $name]} {
465 if {![string match "*/HEAD" $name]} {
466 set headids($name) $id
467 lappend idheads($id) $name
469 } elseif {[string match "heads/*" $name]} {
470 set name [string range $name 6 end]
471 set headids($name) $id
472 lappend idheads($id) $name
473 } elseif {[string match "tags/*" $name]} {
474 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
475 # which is what we want since the former is the commit ID
476 set name [string range $name 5 end]
477 if {[string match "*^{}" $name]} {
478 set name [string range $name 0 end-3]
479 } else {
480 set tagobjid($name) $id
482 set tagids($name) $id
483 lappend idtags($id) $name
484 } else {
485 set otherrefids($name) $id
486 lappend idotherrefs($id) $name
489 catch {close $refd}
490 set mainhead {}
491 set mainheadid {}
492 catch {
493 set thehead [exec git symbolic-ref HEAD]
494 if {[string match "refs/heads/*" $thehead]} {
495 set mainhead [string range $thehead 11 end]
496 if {[info exists headids($mainhead)]} {
497 set mainheadid $headids($mainhead)
503 # skip over fake commits
504 proc first_real_row {} {
505 global nullid nullid2 displayorder numcommits
507 for {set row 0} {$row < $numcommits} {incr row} {
508 set id [lindex $displayorder $row]
509 if {$id ne $nullid && $id ne $nullid2} {
510 break
513 return $row
516 # update things for a head moved to a child of its previous location
517 proc movehead {id name} {
518 global headids idheads
520 removehead $headids($name) $name
521 set headids($name) $id
522 lappend idheads($id) $name
525 # update things when a head has been removed
526 proc removehead {id name} {
527 global headids idheads
529 if {$idheads($id) eq $name} {
530 unset idheads($id)
531 } else {
532 set i [lsearch -exact $idheads($id) $name]
533 if {$i >= 0} {
534 set idheads($id) [lreplace $idheads($id) $i $i]
537 unset headids($name)
540 proc show_error {w top msg} {
541 message $w.m -text $msg -justify center -aspect 400
542 pack $w.m -side top -fill x -padx 20 -pady 20
543 button $w.ok -text OK -command "destroy $top"
544 pack $w.ok -side bottom -fill x
545 bind $top <Visibility> "grab $top; focus $top"
546 bind $top <Key-Return> "destroy $top"
547 tkwait window $top
550 proc error_popup msg {
551 set w .error
552 toplevel $w
553 wm transient $w .
554 show_error $w $w $msg
557 proc confirm_popup msg {
558 global confirm_ok
559 set confirm_ok 0
560 set w .confirm
561 toplevel $w
562 wm transient $w .
563 message $w.m -text $msg -justify center -aspect 400
564 pack $w.m -side top -fill x -padx 20 -pady 20
565 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
566 pack $w.ok -side left -fill x
567 button $w.cancel -text Cancel -command "destroy $w"
568 pack $w.cancel -side right -fill x
569 bind $w <Visibility> "grab $w; focus $w"
570 tkwait window $w
571 return $confirm_ok
574 proc makewindow {} {
575 global canv canv2 canv3 linespc charspc ctext cflist
576 global textfont mainfont uifont tabstop
577 global findtype findtypemenu findloc findstring fstring geometry
578 global entries sha1entry sha1string sha1but
579 global diffcontextstring diffcontext
580 global maincursor textcursor curtextcursor
581 global rowctxmenu fakerowmenu mergemax wrapcomment
582 global highlight_files gdttype
583 global searchstring sstring
584 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
585 global headctxmenu
587 menu .bar
588 .bar add cascade -label "File" -menu .bar.file
589 .bar configure -font $uifont
590 menu .bar.file
591 .bar.file add command -label "Update" -command updatecommits
592 .bar.file add command -label "Reread references" -command rereadrefs
593 .bar.file add command -label "List references" -command showrefs
594 .bar.file add command -label "Quit" -command doquit
595 .bar.file configure -font $uifont
596 menu .bar.edit
597 .bar add cascade -label "Edit" -menu .bar.edit
598 .bar.edit add command -label "Preferences" -command doprefs
599 .bar.edit configure -font $uifont
601 menu .bar.view -font $uifont
602 .bar add cascade -label "View" -menu .bar.view
603 .bar.view add command -label "New view..." -command {newview 0}
604 .bar.view add command -label "Edit view..." -command editview \
605 -state disabled
606 .bar.view add command -label "Delete view" -command delview -state disabled
607 .bar.view add separator
608 .bar.view add radiobutton -label "All files" -command {showview 0} \
609 -variable selectedview -value 0
611 menu .bar.help
612 .bar add cascade -label "Help" -menu .bar.help
613 .bar.help add command -label "About gitk" -command about
614 .bar.help add command -label "Key bindings" -command keys
615 .bar.help configure -font $uifont
616 . configure -menu .bar
618 # the gui has upper and lower half, parts of a paned window.
619 panedwindow .ctop -orient vertical
621 # possibly use assumed geometry
622 if {![info exists geometry(pwsash0)]} {
623 set geometry(topheight) [expr {15 * $linespc}]
624 set geometry(topwidth) [expr {80 * $charspc}]
625 set geometry(botheight) [expr {15 * $linespc}]
626 set geometry(botwidth) [expr {50 * $charspc}]
627 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
628 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
631 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
632 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
633 frame .tf.histframe
634 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
636 # create three canvases
637 set cscroll .tf.histframe.csb
638 set canv .tf.histframe.pwclist.canv
639 canvas $canv \
640 -selectbackground $selectbgcolor \
641 -background $bgcolor -bd 0 \
642 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
643 .tf.histframe.pwclist add $canv
644 set canv2 .tf.histframe.pwclist.canv2
645 canvas $canv2 \
646 -selectbackground $selectbgcolor \
647 -background $bgcolor -bd 0 -yscrollincr $linespc
648 .tf.histframe.pwclist add $canv2
649 set canv3 .tf.histframe.pwclist.canv3
650 canvas $canv3 \
651 -selectbackground $selectbgcolor \
652 -background $bgcolor -bd 0 -yscrollincr $linespc
653 .tf.histframe.pwclist add $canv3
654 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
655 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
657 # a scroll bar to rule them
658 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
659 pack $cscroll -side right -fill y
660 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
661 lappend bglist $canv $canv2 $canv3
662 pack .tf.histframe.pwclist -fill both -expand 1 -side left
664 # we have two button bars at bottom of top frame. Bar 1
665 frame .tf.bar
666 frame .tf.lbar -height 15
668 set sha1entry .tf.bar.sha1
669 set entries $sha1entry
670 set sha1but .tf.bar.sha1label
671 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
672 -command gotocommit -width 8 -font $uifont
673 $sha1but conf -disabledforeground [$sha1but cget -foreground]
674 pack .tf.bar.sha1label -side left
675 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
676 trace add variable sha1string write sha1change
677 pack $sha1entry -side left -pady 2
679 image create bitmap bm-left -data {
680 #define left_width 16
681 #define left_height 16
682 static unsigned char left_bits[] = {
683 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
684 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
685 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
687 image create bitmap bm-right -data {
688 #define right_width 16
689 #define right_height 16
690 static unsigned char right_bits[] = {
691 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
692 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
693 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
695 button .tf.bar.leftbut -image bm-left -command goback \
696 -state disabled -width 26
697 pack .tf.bar.leftbut -side left -fill y
698 button .tf.bar.rightbut -image bm-right -command goforw \
699 -state disabled -width 26
700 pack .tf.bar.rightbut -side left -fill y
702 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
703 pack .tf.bar.findbut -side left
704 set findstring {}
705 set fstring .tf.bar.findstring
706 lappend entries $fstring
707 entry $fstring -width 30 -font $textfont -textvariable findstring
708 trace add variable findstring write find_change
709 pack $fstring -side left -expand 1 -fill x -in .tf.bar
710 set findtype Exact
711 set findtypemenu [tk_optionMenu .tf.bar.findtype \
712 findtype Exact IgnCase Regexp]
713 trace add variable findtype write find_change
714 .tf.bar.findtype configure -font $uifont
715 .tf.bar.findtype.menu configure -font $uifont
716 set findloc "All fields"
717 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
718 Comments Author Committer
719 trace add variable findloc write find_change
720 .tf.bar.findloc configure -font $uifont
721 .tf.bar.findloc.menu configure -font $uifont
722 pack .tf.bar.findloc -side right
723 pack .tf.bar.findtype -side right
725 # build up the bottom bar of upper window
726 label .tf.lbar.flabel -text "Highlight: Commits " \
727 -font $uifont
728 pack .tf.lbar.flabel -side left -fill y
729 set gdttype "touching paths:"
730 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
731 "adding/removing string:"]
732 trace add variable gdttype write hfiles_change
733 $gm conf -font $uifont
734 .tf.lbar.gdttype conf -font $uifont
735 pack .tf.lbar.gdttype -side left -fill y
736 entry .tf.lbar.fent -width 25 -font $textfont \
737 -textvariable highlight_files
738 trace add variable highlight_files write hfiles_change
739 lappend entries .tf.lbar.fent
740 pack .tf.lbar.fent -side left -fill x -expand 1
741 label .tf.lbar.vlabel -text " OR in view" -font $uifont
742 pack .tf.lbar.vlabel -side left -fill y
743 global viewhlmenu selectedhlview
744 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
745 $viewhlmenu entryconf None -command delvhighlight
746 $viewhlmenu conf -font $uifont
747 .tf.lbar.vhl conf -font $uifont
748 pack .tf.lbar.vhl -side left -fill y
749 label .tf.lbar.rlabel -text " OR " -font $uifont
750 pack .tf.lbar.rlabel -side left -fill y
751 global highlight_related
752 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
753 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
754 $m conf -font $uifont
755 .tf.lbar.relm conf -font $uifont
756 trace add variable highlight_related write vrel_change
757 pack .tf.lbar.relm -side left -fill y
759 # Finish putting the upper half of the viewer together
760 pack .tf.lbar -in .tf -side bottom -fill x
761 pack .tf.bar -in .tf -side bottom -fill x
762 pack .tf.histframe -fill both -side top -expand 1
763 .ctop add .tf
764 .ctop paneconfigure .tf -height $geometry(topheight)
765 .ctop paneconfigure .tf -width $geometry(topwidth)
767 # now build up the bottom
768 panedwindow .pwbottom -orient horizontal
770 # lower left, a text box over search bar, scroll bar to the right
771 # if we know window height, then that will set the lower text height, otherwise
772 # we set lower text height which will drive window height
773 if {[info exists geometry(main)]} {
774 frame .bleft -width $geometry(botwidth)
775 } else {
776 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
778 frame .bleft.top
779 frame .bleft.mid
781 button .bleft.top.search -text "Search" -command dosearch \
782 -font $uifont
783 pack .bleft.top.search -side left -padx 5
784 set sstring .bleft.top.sstring
785 entry $sstring -width 20 -font $textfont -textvariable searchstring
786 lappend entries $sstring
787 trace add variable searchstring write incrsearch
788 pack $sstring -side left -expand 1 -fill x
789 radiobutton .bleft.mid.diff -text "Diff" \
790 -command changediffdisp -variable diffelide -value {0 0}
791 radiobutton .bleft.mid.old -text "Old version" \
792 -command changediffdisp -variable diffelide -value {0 1}
793 radiobutton .bleft.mid.new -text "New version" \
794 -command changediffdisp -variable diffelide -value {1 0}
795 label .bleft.mid.labeldiffcontext -text " Lines of context: " \
796 -font $uifont
797 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
798 spinbox .bleft.mid.diffcontext -width 5 -font $textfont \
799 -from 1 -increment 1 -to 10000000 \
800 -validate all -validatecommand "diffcontextvalidate %P" \
801 -textvariable diffcontextstring
802 .bleft.mid.diffcontext set $diffcontext
803 trace add variable diffcontextstring write diffcontextchange
804 lappend entries .bleft.mid.diffcontext
805 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
806 set ctext .bleft.ctext
807 text $ctext -background $bgcolor -foreground $fgcolor \
808 -tabs "[expr {$tabstop * $charspc}]" \
809 -state disabled -font $textfont \
810 -yscrollcommand scrolltext -wrap none
811 scrollbar .bleft.sb -command "$ctext yview"
812 pack .bleft.top -side top -fill x
813 pack .bleft.mid -side top -fill x
814 pack .bleft.sb -side right -fill y
815 pack $ctext -side left -fill both -expand 1
816 lappend bglist $ctext
817 lappend fglist $ctext
819 $ctext tag conf comment -wrap $wrapcomment
820 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
821 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
822 $ctext tag conf d0 -fore [lindex $diffcolors 0]
823 $ctext tag conf d1 -fore [lindex $diffcolors 1]
824 $ctext tag conf m0 -fore red
825 $ctext tag conf m1 -fore blue
826 $ctext tag conf m2 -fore green
827 $ctext tag conf m3 -fore purple
828 $ctext tag conf m4 -fore brown
829 $ctext tag conf m5 -fore "#009090"
830 $ctext tag conf m6 -fore magenta
831 $ctext tag conf m7 -fore "#808000"
832 $ctext tag conf m8 -fore "#009000"
833 $ctext tag conf m9 -fore "#ff0080"
834 $ctext tag conf m10 -fore cyan
835 $ctext tag conf m11 -fore "#b07070"
836 $ctext tag conf m12 -fore "#70b0f0"
837 $ctext tag conf m13 -fore "#70f0b0"
838 $ctext tag conf m14 -fore "#f0b070"
839 $ctext tag conf m15 -fore "#ff70b0"
840 $ctext tag conf mmax -fore darkgrey
841 set mergemax 16
842 $ctext tag conf mresult -font [concat $textfont bold]
843 $ctext tag conf msep -font [concat $textfont bold]
844 $ctext tag conf found -back yellow
846 .pwbottom add .bleft
847 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
849 # lower right
850 frame .bright
851 frame .bright.mode
852 radiobutton .bright.mode.patch -text "Patch" \
853 -command reselectline -variable cmitmode -value "patch"
854 .bright.mode.patch configure -font $uifont
855 radiobutton .bright.mode.tree -text "Tree" \
856 -command reselectline -variable cmitmode -value "tree"
857 .bright.mode.tree configure -font $uifont
858 grid .bright.mode.patch .bright.mode.tree -sticky ew
859 pack .bright.mode -side top -fill x
860 set cflist .bright.cfiles
861 set indent [font measure $mainfont "nn"]
862 text $cflist \
863 -selectbackground $selectbgcolor \
864 -background $bgcolor -foreground $fgcolor \
865 -font $mainfont \
866 -tabs [list $indent [expr {2 * $indent}]] \
867 -yscrollcommand ".bright.sb set" \
868 -cursor [. cget -cursor] \
869 -spacing1 1 -spacing3 1
870 lappend bglist $cflist
871 lappend fglist $cflist
872 scrollbar .bright.sb -command "$cflist yview"
873 pack .bright.sb -side right -fill y
874 pack $cflist -side left -fill both -expand 1
875 $cflist tag configure highlight \
876 -background [$cflist cget -selectbackground]
877 $cflist tag configure bold -font [concat $mainfont bold]
879 .pwbottom add .bright
880 .ctop add .pwbottom
882 # restore window position if known
883 if {[info exists geometry(main)]} {
884 wm geometry . "$geometry(main)"
887 if {[tk windowingsystem] eq {aqua}} {
888 set M1B M1
889 } else {
890 set M1B Control
893 bind .pwbottom <Configure> {resizecdetpanes %W %w}
894 pack .ctop -fill both -expand 1
895 bindall <1> {selcanvline %W %x %y}
896 #bindall <B1-Motion> {selcanvline %W %x %y}
897 if {[tk windowingsystem] == "win32"} {
898 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
899 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
900 } else {
901 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
902 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
904 bindall <2> "canvscan mark %W %x %y"
905 bindall <B2-Motion> "canvscan dragto %W %x %y"
906 bindkey <Home> selfirstline
907 bindkey <End> sellastline
908 bind . <Key-Up> "selnextline -1"
909 bind . <Key-Down> "selnextline 1"
910 bind . <Shift-Key-Up> "next_highlight -1"
911 bind . <Shift-Key-Down> "next_highlight 1"
912 bindkey <Key-Right> "goforw"
913 bindkey <Key-Left> "goback"
914 bind . <Key-Prior> "selnextpage -1"
915 bind . <Key-Next> "selnextpage 1"
916 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
917 bind . <$M1B-End> "allcanvs yview moveto 1.0"
918 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
919 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
920 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
921 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
922 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
923 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
924 bindkey <Key-space> "$ctext yview scroll 1 pages"
925 bindkey p "selnextline -1"
926 bindkey n "selnextline 1"
927 bindkey z "goback"
928 bindkey x "goforw"
929 bindkey i "selnextline -1"
930 bindkey k "selnextline 1"
931 bindkey j "goback"
932 bindkey l "goforw"
933 bindkey b "$ctext yview scroll -1 pages"
934 bindkey d "$ctext yview scroll 18 units"
935 bindkey u "$ctext yview scroll -18 units"
936 bindkey / {findnext 1}
937 bindkey <Key-Return> {findnext 0}
938 bindkey ? findprev
939 bindkey f nextfile
940 bindkey <F5> updatecommits
941 bind . <$M1B-q> doquit
942 bind . <$M1B-f> dofind
943 bind . <$M1B-g> {findnext 0}
944 bind . <$M1B-r> dosearchback
945 bind . <$M1B-s> dosearch
946 bind . <$M1B-equal> {incrfont 1}
947 bind . <$M1B-KP_Add> {incrfont 1}
948 bind . <$M1B-minus> {incrfont -1}
949 bind . <$M1B-KP_Subtract> {incrfont -1}
950 wm protocol . WM_DELETE_WINDOW doquit
951 bind . <Button-1> "click %W"
952 bind $fstring <Key-Return> dofind
953 bind $sha1entry <Key-Return> gotocommit
954 bind $sha1entry <<PasteSelection>> clearsha1
955 bind $cflist <1> {sel_flist %W %x %y; break}
956 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
957 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
958 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
960 set maincursor [. cget -cursor]
961 set textcursor [$ctext cget -cursor]
962 set curtextcursor $textcursor
964 set rowctxmenu .rowctxmenu
965 menu $rowctxmenu -tearoff 0
966 $rowctxmenu add command -label "Diff this -> selected" \
967 -command {diffvssel 0}
968 $rowctxmenu add command -label "Diff selected -> this" \
969 -command {diffvssel 1}
970 $rowctxmenu add command -label "Make patch" -command mkpatch
971 $rowctxmenu add command -label "Create tag" -command mktag
972 $rowctxmenu add command -label "Write commit to file" -command writecommit
973 $rowctxmenu add command -label "Create new branch" -command mkbranch
974 $rowctxmenu add command -label "Cherry-pick this commit" \
975 -command cherrypick
976 $rowctxmenu add command -label "Reset HEAD branch to here" \
977 -command resethead
979 set fakerowmenu .fakerowmenu
980 menu $fakerowmenu -tearoff 0
981 $fakerowmenu add command -label "Diff this -> selected" \
982 -command {diffvssel 0}
983 $fakerowmenu add command -label "Diff selected -> this" \
984 -command {diffvssel 1}
985 $fakerowmenu add command -label "Make patch" -command mkpatch
986 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
987 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
988 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
990 set headctxmenu .headctxmenu
991 menu $headctxmenu -tearoff 0
992 $headctxmenu add command -label "Check out this branch" \
993 -command cobranch
994 $headctxmenu add command -label "Remove this branch" \
995 -command rmbranch
997 global flist_menu
998 set flist_menu .flistctxmenu
999 menu $flist_menu -tearoff 0
1000 $flist_menu add command -label "Highlight this too" \
1001 -command {flist_hl 0}
1002 $flist_menu add command -label "Highlight this only" \
1003 -command {flist_hl 1}
1006 # Windows sends all mouse wheel events to the current focused window, not
1007 # the one where the mouse hovers, so bind those events here and redirect
1008 # to the correct window
1009 proc windows_mousewheel_redirector {W X Y D} {
1010 global canv canv2 canv3
1011 set w [winfo containing -displayof $W $X $Y]
1012 if {$w ne ""} {
1013 set u [expr {$D < 0 ? 5 : -5}]
1014 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1015 allcanvs yview scroll $u units
1016 } else {
1017 catch {
1018 $w yview scroll $u units
1024 # mouse-2 makes all windows scan vertically, but only the one
1025 # the cursor is in scans horizontally
1026 proc canvscan {op w x y} {
1027 global canv canv2 canv3
1028 foreach c [list $canv $canv2 $canv3] {
1029 if {$c == $w} {
1030 $c scan $op $x $y
1031 } else {
1032 $c scan $op 0 $y
1037 proc scrollcanv {cscroll f0 f1} {
1038 $cscroll set $f0 $f1
1039 drawfrac $f0 $f1
1040 flushhighlights
1043 # when we make a key binding for the toplevel, make sure
1044 # it doesn't get triggered when that key is pressed in the
1045 # find string entry widget.
1046 proc bindkey {ev script} {
1047 global entries
1048 bind . $ev $script
1049 set escript [bind Entry $ev]
1050 if {$escript == {}} {
1051 set escript [bind Entry <Key>]
1053 foreach e $entries {
1054 bind $e $ev "$escript; break"
1058 # set the focus back to the toplevel for any click outside
1059 # the entry widgets
1060 proc click {w} {
1061 global ctext entries
1062 foreach e [concat $entries $ctext] {
1063 if {$w == $e} return
1065 focus .
1068 proc savestuff {w} {
1069 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
1070 global stuffsaved findmergefiles maxgraphpct
1071 global maxwidth showneartags showlocalchanges
1072 global viewname viewfiles viewargs viewperm nextviewnum
1073 global cmitmode wrapcomment datetimeformat
1074 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1076 if {$stuffsaved} return
1077 if {![winfo viewable .]} return
1078 catch {
1079 set f [open "~/.gitk-new" w]
1080 puts $f [list set mainfont $mainfont]
1081 puts $f [list set textfont $textfont]
1082 puts $f [list set uifont $uifont]
1083 puts $f [list set tabstop $tabstop]
1084 puts $f [list set findmergefiles $findmergefiles]
1085 puts $f [list set maxgraphpct $maxgraphpct]
1086 puts $f [list set maxwidth $maxwidth]
1087 puts $f [list set cmitmode $cmitmode]
1088 puts $f [list set wrapcomment $wrapcomment]
1089 puts $f [list set showneartags $showneartags]
1090 puts $f [list set showlocalchanges $showlocalchanges]
1091 puts $f [list set datetimeformat $datetimeformat]
1092 puts $f [list set bgcolor $bgcolor]
1093 puts $f [list set fgcolor $fgcolor]
1094 puts $f [list set colors $colors]
1095 puts $f [list set diffcolors $diffcolors]
1096 puts $f [list set diffcontext $diffcontext]
1097 puts $f [list set selectbgcolor $selectbgcolor]
1099 puts $f "set geometry(main) [wm geometry .]"
1100 puts $f "set geometry(topwidth) [winfo width .tf]"
1101 puts $f "set geometry(topheight) [winfo height .tf]"
1102 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1103 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1104 puts $f "set geometry(botwidth) [winfo width .bleft]"
1105 puts $f "set geometry(botheight) [winfo height .bleft]"
1107 puts -nonewline $f "set permviews {"
1108 for {set v 0} {$v < $nextviewnum} {incr v} {
1109 if {$viewperm($v)} {
1110 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1113 puts $f "}"
1114 close $f
1115 file rename -force "~/.gitk-new" "~/.gitk"
1117 set stuffsaved 1
1120 proc resizeclistpanes {win w} {
1121 global oldwidth
1122 if {[info exists oldwidth($win)]} {
1123 set s0 [$win sash coord 0]
1124 set s1 [$win sash coord 1]
1125 if {$w < 60} {
1126 set sash0 [expr {int($w/2 - 2)}]
1127 set sash1 [expr {int($w*5/6 - 2)}]
1128 } else {
1129 set factor [expr {1.0 * $w / $oldwidth($win)}]
1130 set sash0 [expr {int($factor * [lindex $s0 0])}]
1131 set sash1 [expr {int($factor * [lindex $s1 0])}]
1132 if {$sash0 < 30} {
1133 set sash0 30
1135 if {$sash1 < $sash0 + 20} {
1136 set sash1 [expr {$sash0 + 20}]
1138 if {$sash1 > $w - 10} {
1139 set sash1 [expr {$w - 10}]
1140 if {$sash0 > $sash1 - 20} {
1141 set sash0 [expr {$sash1 - 20}]
1145 $win sash place 0 $sash0 [lindex $s0 1]
1146 $win sash place 1 $sash1 [lindex $s1 1]
1148 set oldwidth($win) $w
1151 proc resizecdetpanes {win w} {
1152 global oldwidth
1153 if {[info exists oldwidth($win)]} {
1154 set s0 [$win sash coord 0]
1155 if {$w < 60} {
1156 set sash0 [expr {int($w*3/4 - 2)}]
1157 } else {
1158 set factor [expr {1.0 * $w / $oldwidth($win)}]
1159 set sash0 [expr {int($factor * [lindex $s0 0])}]
1160 if {$sash0 < 45} {
1161 set sash0 45
1163 if {$sash0 > $w - 15} {
1164 set sash0 [expr {$w - 15}]
1167 $win sash place 0 $sash0 [lindex $s0 1]
1169 set oldwidth($win) $w
1172 proc allcanvs args {
1173 global canv canv2 canv3
1174 eval $canv $args
1175 eval $canv2 $args
1176 eval $canv3 $args
1179 proc bindall {event action} {
1180 global canv canv2 canv3
1181 bind $canv $event $action
1182 bind $canv2 $event $action
1183 bind $canv3 $event $action
1186 proc about {} {
1187 global uifont
1188 set w .about
1189 if {[winfo exists $w]} {
1190 raise $w
1191 return
1193 toplevel $w
1194 wm title $w "About gitk"
1195 message $w.m -text {
1196 Gitk - a commit viewer for git
1198 Copyright © 2005-2006 Paul Mackerras
1200 Use and redistribute under the terms of the GNU General Public License} \
1201 -justify center -aspect 400 -border 2 -bg white -relief groove
1202 pack $w.m -side top -fill x -padx 2 -pady 2
1203 $w.m configure -font $uifont
1204 button $w.ok -text Close -command "destroy $w" -default active
1205 pack $w.ok -side bottom
1206 $w.ok configure -font $uifont
1207 bind $w <Visibility> "focus $w.ok"
1208 bind $w <Key-Escape> "destroy $w"
1209 bind $w <Key-Return> "destroy $w"
1212 proc keys {} {
1213 global uifont
1214 set w .keys
1215 if {[winfo exists $w]} {
1216 raise $w
1217 return
1219 if {[tk windowingsystem] eq {aqua}} {
1220 set M1T Cmd
1221 } else {
1222 set M1T Ctrl
1224 toplevel $w
1225 wm title $w "Gitk key bindings"
1226 message $w.m -text "
1227 Gitk key bindings:
1229 <$M1T-Q> Quit
1230 <Home> Move to first commit
1231 <End> Move to last commit
1232 <Up>, p, i Move up one commit
1233 <Down>, n, k Move down one commit
1234 <Left>, z, j Go back in history list
1235 <Right>, x, l Go forward in history list
1236 <PageUp> Move up one page in commit list
1237 <PageDown> Move down one page in commit list
1238 <$M1T-Home> Scroll to top of commit list
1239 <$M1T-End> Scroll to bottom of commit list
1240 <$M1T-Up> Scroll commit list up one line
1241 <$M1T-Down> Scroll commit list down one line
1242 <$M1T-PageUp> Scroll commit list up one page
1243 <$M1T-PageDown> Scroll commit list down one page
1244 <Shift-Up> Move to previous highlighted line
1245 <Shift-Down> Move to next highlighted line
1246 <Delete>, b Scroll diff view up one page
1247 <Backspace> Scroll diff view up one page
1248 <Space> Scroll diff view down one page
1249 u Scroll diff view up 18 lines
1250 d Scroll diff view down 18 lines
1251 <$M1T-F> Find
1252 <$M1T-G> Move to next find hit
1253 <Return> Move to next find hit
1254 / Move to next find hit, or redo find
1255 ? Move to previous find hit
1256 f Scroll diff view to next file
1257 <$M1T-S> Search for next hit in diff view
1258 <$M1T-R> Search for previous hit in diff view
1259 <$M1T-KP+> Increase font size
1260 <$M1T-plus> Increase font size
1261 <$M1T-KP-> Decrease font size
1262 <$M1T-minus> Decrease font size
1263 <F5> Update
1265 -justify left -bg white -border 2 -relief groove
1266 pack $w.m -side top -fill both -padx 2 -pady 2
1267 $w.m configure -font $uifont
1268 button $w.ok -text Close -command "destroy $w" -default active
1269 pack $w.ok -side bottom
1270 $w.ok configure -font $uifont
1271 bind $w <Visibility> "focus $w.ok"
1272 bind $w <Key-Escape> "destroy $w"
1273 bind $w <Key-Return> "destroy $w"
1276 # Procedures for manipulating the file list window at the
1277 # bottom right of the overall window.
1279 proc treeview {w l openlevs} {
1280 global treecontents treediropen treeheight treeparent treeindex
1282 set ix 0
1283 set treeindex() 0
1284 set lev 0
1285 set prefix {}
1286 set prefixend -1
1287 set prefendstack {}
1288 set htstack {}
1289 set ht 0
1290 set treecontents() {}
1291 $w conf -state normal
1292 foreach f $l {
1293 while {[string range $f 0 $prefixend] ne $prefix} {
1294 if {$lev <= $openlevs} {
1295 $w mark set e:$treeindex($prefix) "end -1c"
1296 $w mark gravity e:$treeindex($prefix) left
1298 set treeheight($prefix) $ht
1299 incr ht [lindex $htstack end]
1300 set htstack [lreplace $htstack end end]
1301 set prefixend [lindex $prefendstack end]
1302 set prefendstack [lreplace $prefendstack end end]
1303 set prefix [string range $prefix 0 $prefixend]
1304 incr lev -1
1306 set tail [string range $f [expr {$prefixend+1}] end]
1307 while {[set slash [string first "/" $tail]] >= 0} {
1308 lappend htstack $ht
1309 set ht 0
1310 lappend prefendstack $prefixend
1311 incr prefixend [expr {$slash + 1}]
1312 set d [string range $tail 0 $slash]
1313 lappend treecontents($prefix) $d
1314 set oldprefix $prefix
1315 append prefix $d
1316 set treecontents($prefix) {}
1317 set treeindex($prefix) [incr ix]
1318 set treeparent($prefix) $oldprefix
1319 set tail [string range $tail [expr {$slash+1}] end]
1320 if {$lev <= $openlevs} {
1321 set ht 1
1322 set treediropen($prefix) [expr {$lev < $openlevs}]
1323 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1324 $w mark set d:$ix "end -1c"
1325 $w mark gravity d:$ix left
1326 set str "\n"
1327 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1328 $w insert end $str
1329 $w image create end -align center -image $bm -padx 1 \
1330 -name a:$ix
1331 $w insert end $d [highlight_tag $prefix]
1332 $w mark set s:$ix "end -1c"
1333 $w mark gravity s:$ix left
1335 incr lev
1337 if {$tail ne {}} {
1338 if {$lev <= $openlevs} {
1339 incr ht
1340 set str "\n"
1341 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1342 $w insert end $str
1343 $w insert end $tail [highlight_tag $f]
1345 lappend treecontents($prefix) $tail
1348 while {$htstack ne {}} {
1349 set treeheight($prefix) $ht
1350 incr ht [lindex $htstack end]
1351 set htstack [lreplace $htstack end end]
1352 set prefixend [lindex $prefendstack end]
1353 set prefendstack [lreplace $prefendstack end end]
1354 set prefix [string range $prefix 0 $prefixend]
1356 $w conf -state disabled
1359 proc linetoelt {l} {
1360 global treeheight treecontents
1362 set y 2
1363 set prefix {}
1364 while {1} {
1365 foreach e $treecontents($prefix) {
1366 if {$y == $l} {
1367 return "$prefix$e"
1369 set n 1
1370 if {[string index $e end] eq "/"} {
1371 set n $treeheight($prefix$e)
1372 if {$y + $n > $l} {
1373 append prefix $e
1374 incr y
1375 break
1378 incr y $n
1383 proc highlight_tree {y prefix} {
1384 global treeheight treecontents cflist
1386 foreach e $treecontents($prefix) {
1387 set path $prefix$e
1388 if {[highlight_tag $path] ne {}} {
1389 $cflist tag add bold $y.0 "$y.0 lineend"
1391 incr y
1392 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1393 set y [highlight_tree $y $path]
1396 return $y
1399 proc treeclosedir {w dir} {
1400 global treediropen treeheight treeparent treeindex
1402 set ix $treeindex($dir)
1403 $w conf -state normal
1404 $w delete s:$ix e:$ix
1405 set treediropen($dir) 0
1406 $w image configure a:$ix -image tri-rt
1407 $w conf -state disabled
1408 set n [expr {1 - $treeheight($dir)}]
1409 while {$dir ne {}} {
1410 incr treeheight($dir) $n
1411 set dir $treeparent($dir)
1415 proc treeopendir {w dir} {
1416 global treediropen treeheight treeparent treecontents treeindex
1418 set ix $treeindex($dir)
1419 $w conf -state normal
1420 $w image configure a:$ix -image tri-dn
1421 $w mark set e:$ix s:$ix
1422 $w mark gravity e:$ix right
1423 set lev 0
1424 set str "\n"
1425 set n [llength $treecontents($dir)]
1426 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1427 incr lev
1428 append str "\t"
1429 incr treeheight($x) $n
1431 foreach e $treecontents($dir) {
1432 set de $dir$e
1433 if {[string index $e end] eq "/"} {
1434 set iy $treeindex($de)
1435 $w mark set d:$iy e:$ix
1436 $w mark gravity d:$iy left
1437 $w insert e:$ix $str
1438 set treediropen($de) 0
1439 $w image create e:$ix -align center -image tri-rt -padx 1 \
1440 -name a:$iy
1441 $w insert e:$ix $e [highlight_tag $de]
1442 $w mark set s:$iy e:$ix
1443 $w mark gravity s:$iy left
1444 set treeheight($de) 1
1445 } else {
1446 $w insert e:$ix $str
1447 $w insert e:$ix $e [highlight_tag $de]
1450 $w mark gravity e:$ix left
1451 $w conf -state disabled
1452 set treediropen($dir) 1
1453 set top [lindex [split [$w index @0,0] .] 0]
1454 set ht [$w cget -height]
1455 set l [lindex [split [$w index s:$ix] .] 0]
1456 if {$l < $top} {
1457 $w yview $l.0
1458 } elseif {$l + $n + 1 > $top + $ht} {
1459 set top [expr {$l + $n + 2 - $ht}]
1460 if {$l < $top} {
1461 set top $l
1463 $w yview $top.0
1467 proc treeclick {w x y} {
1468 global treediropen cmitmode ctext cflist cflist_top
1470 if {$cmitmode ne "tree"} return
1471 if {![info exists cflist_top]} return
1472 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1473 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1474 $cflist tag add highlight $l.0 "$l.0 lineend"
1475 set cflist_top $l
1476 if {$l == 1} {
1477 $ctext yview 1.0
1478 return
1480 set e [linetoelt $l]
1481 if {[string index $e end] ne "/"} {
1482 showfile $e
1483 } elseif {$treediropen($e)} {
1484 treeclosedir $w $e
1485 } else {
1486 treeopendir $w $e
1490 proc setfilelist {id} {
1491 global treefilelist cflist
1493 treeview $cflist $treefilelist($id) 0
1496 image create bitmap tri-rt -background black -foreground blue -data {
1497 #define tri-rt_width 13
1498 #define tri-rt_height 13
1499 static unsigned char tri-rt_bits[] = {
1500 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1501 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1502 0x00, 0x00};
1503 } -maskdata {
1504 #define tri-rt-mask_width 13
1505 #define tri-rt-mask_height 13
1506 static unsigned char tri-rt-mask_bits[] = {
1507 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1508 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1509 0x08, 0x00};
1511 image create bitmap tri-dn -background black -foreground blue -data {
1512 #define tri-dn_width 13
1513 #define tri-dn_height 13
1514 static unsigned char tri-dn_bits[] = {
1515 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1516 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1517 0x00, 0x00};
1518 } -maskdata {
1519 #define tri-dn-mask_width 13
1520 #define tri-dn-mask_height 13
1521 static unsigned char tri-dn-mask_bits[] = {
1522 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1523 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1524 0x00, 0x00};
1527 image create bitmap reficon-T -background black -foreground yellow -data {
1528 #define tagicon_width 13
1529 #define tagicon_height 9
1530 static unsigned char tagicon_bits[] = {
1531 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1532 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1533 } -maskdata {
1534 #define tagicon-mask_width 13
1535 #define tagicon-mask_height 9
1536 static unsigned char tagicon-mask_bits[] = {
1537 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1538 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1540 set rectdata {
1541 #define headicon_width 13
1542 #define headicon_height 9
1543 static unsigned char headicon_bits[] = {
1544 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1545 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1547 set rectmask {
1548 #define headicon-mask_width 13
1549 #define headicon-mask_height 9
1550 static unsigned char headicon-mask_bits[] = {
1551 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1552 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1554 image create bitmap reficon-H -background black -foreground green \
1555 -data $rectdata -maskdata $rectmask
1556 image create bitmap reficon-o -background black -foreground "#ddddff" \
1557 -data $rectdata -maskdata $rectmask
1559 proc init_flist {first} {
1560 global cflist cflist_top selectedline difffilestart
1562 $cflist conf -state normal
1563 $cflist delete 0.0 end
1564 if {$first ne {}} {
1565 $cflist insert end $first
1566 set cflist_top 1
1567 $cflist tag add highlight 1.0 "1.0 lineend"
1568 } else {
1569 catch {unset cflist_top}
1571 $cflist conf -state disabled
1572 set difffilestart {}
1575 proc highlight_tag {f} {
1576 global highlight_paths
1578 foreach p $highlight_paths {
1579 if {[string match $p $f]} {
1580 return "bold"
1583 return {}
1586 proc highlight_filelist {} {
1587 global cmitmode cflist
1589 $cflist conf -state normal
1590 if {$cmitmode ne "tree"} {
1591 set end [lindex [split [$cflist index end] .] 0]
1592 for {set l 2} {$l < $end} {incr l} {
1593 set line [$cflist get $l.0 "$l.0 lineend"]
1594 if {[highlight_tag $line] ne {}} {
1595 $cflist tag add bold $l.0 "$l.0 lineend"
1598 } else {
1599 highlight_tree 2 {}
1601 $cflist conf -state disabled
1604 proc unhighlight_filelist {} {
1605 global cflist
1607 $cflist conf -state normal
1608 $cflist tag remove bold 1.0 end
1609 $cflist conf -state disabled
1612 proc add_flist {fl} {
1613 global cflist
1615 $cflist conf -state normal
1616 foreach f $fl {
1617 $cflist insert end "\n"
1618 $cflist insert end $f [highlight_tag $f]
1620 $cflist conf -state disabled
1623 proc sel_flist {w x y} {
1624 global ctext difffilestart cflist cflist_top cmitmode
1626 if {$cmitmode eq "tree"} return
1627 if {![info exists cflist_top]} return
1628 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1629 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1630 $cflist tag add highlight $l.0 "$l.0 lineend"
1631 set cflist_top $l
1632 if {$l == 1} {
1633 $ctext yview 1.0
1634 } else {
1635 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1639 proc pop_flist_menu {w X Y x y} {
1640 global ctext cflist cmitmode flist_menu flist_menu_file
1641 global treediffs diffids
1643 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1644 if {$l <= 1} return
1645 if {$cmitmode eq "tree"} {
1646 set e [linetoelt $l]
1647 if {[string index $e end] eq "/"} return
1648 } else {
1649 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1651 set flist_menu_file $e
1652 tk_popup $flist_menu $X $Y
1655 proc flist_hl {only} {
1656 global flist_menu_file highlight_files
1658 set x [shellquote $flist_menu_file]
1659 if {$only || $highlight_files eq {}} {
1660 set highlight_files $x
1661 } else {
1662 append highlight_files " " $x
1666 # Functions for adding and removing shell-type quoting
1668 proc shellquote {str} {
1669 if {![string match "*\['\"\\ \t]*" $str]} {
1670 return $str
1672 if {![string match "*\['\"\\]*" $str]} {
1673 return "\"$str\""
1675 if {![string match "*'*" $str]} {
1676 return "'$str'"
1678 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1681 proc shellarglist {l} {
1682 set str {}
1683 foreach a $l {
1684 if {$str ne {}} {
1685 append str " "
1687 append str [shellquote $a]
1689 return $str
1692 proc shelldequote {str} {
1693 set ret {}
1694 set used -1
1695 while {1} {
1696 incr used
1697 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1698 append ret [string range $str $used end]
1699 set used [string length $str]
1700 break
1702 set first [lindex $first 0]
1703 set ch [string index $str $first]
1704 if {$first > $used} {
1705 append ret [string range $str $used [expr {$first - 1}]]
1706 set used $first
1708 if {$ch eq " " || $ch eq "\t"} break
1709 incr used
1710 if {$ch eq "'"} {
1711 set first [string first "'" $str $used]
1712 if {$first < 0} {
1713 error "unmatched single-quote"
1715 append ret [string range $str $used [expr {$first - 1}]]
1716 set used $first
1717 continue
1719 if {$ch eq "\\"} {
1720 if {$used >= [string length $str]} {
1721 error "trailing backslash"
1723 append ret [string index $str $used]
1724 continue
1726 # here ch == "\""
1727 while {1} {
1728 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1729 error "unmatched double-quote"
1731 set first [lindex $first 0]
1732 set ch [string index $str $first]
1733 if {$first > $used} {
1734 append ret [string range $str $used [expr {$first - 1}]]
1735 set used $first
1737 if {$ch eq "\""} break
1738 incr used
1739 append ret [string index $str $used]
1740 incr used
1743 return [list $used $ret]
1746 proc shellsplit {str} {
1747 set l {}
1748 while {1} {
1749 set str [string trimleft $str]
1750 if {$str eq {}} break
1751 set dq [shelldequote $str]
1752 set n [lindex $dq 0]
1753 set word [lindex $dq 1]
1754 set str [string range $str $n end]
1755 lappend l $word
1757 return $l
1760 # Code to implement multiple views
1762 proc newview {ishighlight} {
1763 global nextviewnum newviewname newviewperm uifont newishighlight
1764 global newviewargs revtreeargs
1766 set newishighlight $ishighlight
1767 set top .gitkview
1768 if {[winfo exists $top]} {
1769 raise $top
1770 return
1772 set newviewname($nextviewnum) "View $nextviewnum"
1773 set newviewperm($nextviewnum) 0
1774 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1775 vieweditor $top $nextviewnum "Gitk view definition"
1778 proc editview {} {
1779 global curview
1780 global viewname viewperm newviewname newviewperm
1781 global viewargs newviewargs
1783 set top .gitkvedit-$curview
1784 if {[winfo exists $top]} {
1785 raise $top
1786 return
1788 set newviewname($curview) $viewname($curview)
1789 set newviewperm($curview) $viewperm($curview)
1790 set newviewargs($curview) [shellarglist $viewargs($curview)]
1791 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1794 proc vieweditor {top n title} {
1795 global newviewname newviewperm viewfiles
1796 global uifont
1798 toplevel $top
1799 wm title $top $title
1800 label $top.nl -text "Name" -font $uifont
1801 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1802 grid $top.nl $top.name -sticky w -pady 5
1803 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1804 -font $uifont
1805 grid $top.perm - -pady 5 -sticky w
1806 message $top.al -aspect 1000 -font $uifont \
1807 -text "Commits to include (arguments to git rev-list):"
1808 grid $top.al - -sticky w -pady 5
1809 entry $top.args -width 50 -textvariable newviewargs($n) \
1810 -background white -font $uifont
1811 grid $top.args - -sticky ew -padx 5
1812 message $top.l -aspect 1000 -font $uifont \
1813 -text "Enter files and directories to include, one per line:"
1814 grid $top.l - -sticky w
1815 text $top.t -width 40 -height 10 -background white -font $uifont
1816 if {[info exists viewfiles($n)]} {
1817 foreach f $viewfiles($n) {
1818 $top.t insert end $f
1819 $top.t insert end "\n"
1821 $top.t delete {end - 1c} end
1822 $top.t mark set insert 0.0
1824 grid $top.t - -sticky ew -padx 5
1825 frame $top.buts
1826 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1827 -font $uifont
1828 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1829 -font $uifont
1830 grid $top.buts.ok $top.buts.can
1831 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1832 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1833 grid $top.buts - -pady 10 -sticky ew
1834 focus $top.t
1837 proc doviewmenu {m first cmd op argv} {
1838 set nmenu [$m index end]
1839 for {set i $first} {$i <= $nmenu} {incr i} {
1840 if {[$m entrycget $i -command] eq $cmd} {
1841 eval $m $op $i $argv
1842 break
1847 proc allviewmenus {n op args} {
1848 global viewhlmenu
1850 doviewmenu .bar.view 5 [list showview $n] $op $args
1851 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1854 proc newviewok {top n} {
1855 global nextviewnum newviewperm newviewname newishighlight
1856 global viewname viewfiles viewperm selectedview curview
1857 global viewargs newviewargs viewhlmenu
1859 if {[catch {
1860 set newargs [shellsplit $newviewargs($n)]
1861 } err]} {
1862 error_popup "Error in commit selection arguments: $err"
1863 wm raise $top
1864 focus $top
1865 return
1867 set files {}
1868 foreach f [split [$top.t get 0.0 end] "\n"] {
1869 set ft [string trim $f]
1870 if {$ft ne {}} {
1871 lappend files $ft
1874 if {![info exists viewfiles($n)]} {
1875 # creating a new view
1876 incr nextviewnum
1877 set viewname($n) $newviewname($n)
1878 set viewperm($n) $newviewperm($n)
1879 set viewfiles($n) $files
1880 set viewargs($n) $newargs
1881 addviewmenu $n
1882 if {!$newishighlight} {
1883 run showview $n
1884 } else {
1885 run addvhighlight $n
1887 } else {
1888 # editing an existing view
1889 set viewperm($n) $newviewperm($n)
1890 if {$newviewname($n) ne $viewname($n)} {
1891 set viewname($n) $newviewname($n)
1892 doviewmenu .bar.view 5 [list showview $n] \
1893 entryconf [list -label $viewname($n)]
1894 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1895 entryconf [list -label $viewname($n) -value $viewname($n)]
1897 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1898 set viewfiles($n) $files
1899 set viewargs($n) $newargs
1900 if {$curview == $n} {
1901 run updatecommits
1905 catch {destroy $top}
1908 proc delview {} {
1909 global curview viewdata viewperm hlview selectedhlview
1911 if {$curview == 0} return
1912 if {[info exists hlview] && $hlview == $curview} {
1913 set selectedhlview None
1914 unset hlview
1916 allviewmenus $curview delete
1917 set viewdata($curview) {}
1918 set viewperm($curview) 0
1919 showview 0
1922 proc addviewmenu {n} {
1923 global viewname viewhlmenu
1925 .bar.view add radiobutton -label $viewname($n) \
1926 -command [list showview $n] -variable selectedview -value $n
1927 $viewhlmenu add radiobutton -label $viewname($n) \
1928 -command [list addvhighlight $n] -variable selectedhlview
1931 proc flatten {var} {
1932 global $var
1934 set ret {}
1935 foreach i [array names $var] {
1936 lappend ret $i [set $var\($i\)]
1938 return $ret
1941 proc unflatten {var l} {
1942 global $var
1944 catch {unset $var}
1945 foreach {i v} $l {
1946 set $var\($i\) $v
1950 proc showview {n} {
1951 global curview viewdata viewfiles
1952 global displayorder parentlist rowidlist
1953 global colormap rowtextx commitrow nextcolor canvxmax
1954 global numcommits commitlisted rowchk
1955 global selectedline currentid canv canvy0
1956 global treediffs
1957 global pending_select phase
1958 global commitidx rowlaidout rowoptim
1959 global commfd
1960 global selectedview selectfirst
1961 global vparentlist vdisporder vcmitlisted
1962 global hlview selectedhlview
1964 if {$n == $curview} return
1965 set selid {}
1966 if {[info exists selectedline]} {
1967 set selid $currentid
1968 set y [yc $selectedline]
1969 set ymax [lindex [$canv cget -scrollregion] 3]
1970 set span [$canv yview]
1971 set ytop [expr {[lindex $span 0] * $ymax}]
1972 set ybot [expr {[lindex $span 1] * $ymax}]
1973 if {$ytop < $y && $y < $ybot} {
1974 set yscreen [expr {$y - $ytop}]
1975 } else {
1976 set yscreen [expr {($ybot - $ytop) / 2}]
1978 } elseif {[info exists pending_select]} {
1979 set selid $pending_select
1980 unset pending_select
1982 unselectline
1983 normalline
1984 if {$curview >= 0} {
1985 set vparentlist($curview) $parentlist
1986 set vdisporder($curview) $displayorder
1987 set vcmitlisted($curview) $commitlisted
1988 if {$phase ne {}} {
1989 set viewdata($curview) \
1990 [list $phase $rowidlist $rowlaidout $rowoptim $numcommits]
1991 } elseif {![info exists viewdata($curview)]
1992 || [lindex $viewdata($curview) 0] ne {}} {
1993 set viewdata($curview) \
1994 [list {} $rowidlist]
1997 catch {unset treediffs}
1998 clear_display
1999 if {[info exists hlview] && $hlview == $n} {
2000 unset hlview
2001 set selectedhlview None
2004 set curview $n
2005 set selectedview $n
2006 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2007 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2009 if {![info exists viewdata($n)]} {
2010 if {$selid ne {}} {
2011 set pending_select $selid
2013 getcommits
2014 return
2017 set v $viewdata($n)
2018 set phase [lindex $v 0]
2019 set displayorder $vdisporder($n)
2020 set parentlist $vparentlist($n)
2021 set commitlisted $vcmitlisted($n)
2022 set rowidlist [lindex $v 1]
2023 if {$phase eq {}} {
2024 set numcommits [llength $displayorder]
2025 } else {
2026 set rowlaidout [lindex $v 2]
2027 set rowoptim [lindex $v 3]
2028 set numcommits [lindex $v 4]
2029 catch {unset rowchk}
2032 catch {unset colormap}
2033 catch {unset rowtextx}
2034 set nextcolor 0
2035 set canvxmax [$canv cget -width]
2036 set curview $n
2037 set row 0
2038 setcanvscroll
2039 set yf 0
2040 set row {}
2041 set selectfirst 0
2042 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2043 set row $commitrow($n,$selid)
2044 # try to get the selected row in the same position on the screen
2045 set ymax [lindex [$canv cget -scrollregion] 3]
2046 set ytop [expr {[yc $row] - $yscreen}]
2047 if {$ytop < 0} {
2048 set ytop 0
2050 set yf [expr {$ytop * 1.0 / $ymax}]
2052 allcanvs yview moveto $yf
2053 drawvisible
2054 if {$row ne {}} {
2055 selectline $row 0
2056 } elseif {$selid ne {}} {
2057 set pending_select $selid
2058 } else {
2059 set row [first_real_row]
2060 if {$row < $numcommits} {
2061 selectline $row 0
2062 } else {
2063 set selectfirst 1
2066 if {$phase ne {}} {
2067 if {$phase eq "getcommits"} {
2068 show_status "Reading commits..."
2070 run chewcommits $n
2071 } elseif {$numcommits == 0} {
2072 show_status "No commits selected"
2074 run refill_reflist
2077 # Stuff relating to the highlighting facility
2079 proc ishighlighted {row} {
2080 global vhighlights fhighlights nhighlights rhighlights
2082 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2083 return $nhighlights($row)
2085 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2086 return $vhighlights($row)
2088 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2089 return $fhighlights($row)
2091 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2092 return $rhighlights($row)
2094 return 0
2097 proc bolden {row font} {
2098 global canv linehtag selectedline boldrows
2100 lappend boldrows $row
2101 $canv itemconf $linehtag($row) -font $font
2102 if {[info exists selectedline] && $row == $selectedline} {
2103 $canv delete secsel
2104 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2105 -outline {{}} -tags secsel \
2106 -fill [$canv cget -selectbackground]]
2107 $canv lower $t
2111 proc bolden_name {row font} {
2112 global canv2 linentag selectedline boldnamerows
2114 lappend boldnamerows $row
2115 $canv2 itemconf $linentag($row) -font $font
2116 if {[info exists selectedline] && $row == $selectedline} {
2117 $canv2 delete secsel
2118 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2119 -outline {{}} -tags secsel \
2120 -fill [$canv2 cget -selectbackground]]
2121 $canv2 lower $t
2125 proc unbolden {} {
2126 global mainfont boldrows
2128 set stillbold {}
2129 foreach row $boldrows {
2130 if {![ishighlighted $row]} {
2131 bolden $row $mainfont
2132 } else {
2133 lappend stillbold $row
2136 set boldrows $stillbold
2139 proc addvhighlight {n} {
2140 global hlview curview viewdata vhl_done vhighlights commitidx
2142 if {[info exists hlview]} {
2143 delvhighlight
2145 set hlview $n
2146 if {$n != $curview && ![info exists viewdata($n)]} {
2147 set viewdata($n) [list getcommits {{}} 0 0 0]
2148 set vparentlist($n) {}
2149 set vdisporder($n) {}
2150 set vcmitlisted($n) {}
2151 start_rev_list $n
2153 set vhl_done $commitidx($hlview)
2154 if {$vhl_done > 0} {
2155 drawvisible
2159 proc delvhighlight {} {
2160 global hlview vhighlights
2162 if {![info exists hlview]} return
2163 unset hlview
2164 catch {unset vhighlights}
2165 unbolden
2168 proc vhighlightmore {} {
2169 global hlview vhl_done commitidx vhighlights
2170 global displayorder vdisporder curview mainfont
2172 set font [concat $mainfont bold]
2173 set max $commitidx($hlview)
2174 if {$hlview == $curview} {
2175 set disp $displayorder
2176 } else {
2177 set disp $vdisporder($hlview)
2179 set vr [visiblerows]
2180 set r0 [lindex $vr 0]
2181 set r1 [lindex $vr 1]
2182 for {set i $vhl_done} {$i < $max} {incr i} {
2183 set id [lindex $disp $i]
2184 if {[info exists commitrow($curview,$id)]} {
2185 set row $commitrow($curview,$id)
2186 if {$r0 <= $row && $row <= $r1} {
2187 if {![highlighted $row]} {
2188 bolden $row $font
2190 set vhighlights($row) 1
2194 set vhl_done $max
2197 proc askvhighlight {row id} {
2198 global hlview vhighlights commitrow iddrawn mainfont
2200 if {[info exists commitrow($hlview,$id)]} {
2201 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2202 bolden $row [concat $mainfont bold]
2204 set vhighlights($row) 1
2205 } else {
2206 set vhighlights($row) 0
2210 proc hfiles_change {name ix op} {
2211 global highlight_files filehighlight fhighlights fh_serial
2212 global mainfont highlight_paths
2214 if {[info exists filehighlight]} {
2215 # delete previous highlights
2216 catch {close $filehighlight}
2217 unset filehighlight
2218 catch {unset fhighlights}
2219 unbolden
2220 unhighlight_filelist
2222 set highlight_paths {}
2223 after cancel do_file_hl $fh_serial
2224 incr fh_serial
2225 if {$highlight_files ne {}} {
2226 after 300 do_file_hl $fh_serial
2230 proc makepatterns {l} {
2231 set ret {}
2232 foreach e $l {
2233 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2234 if {[string index $ee end] eq "/"} {
2235 lappend ret "$ee*"
2236 } else {
2237 lappend ret $ee
2238 lappend ret "$ee/*"
2241 return $ret
2244 proc do_file_hl {serial} {
2245 global highlight_files filehighlight highlight_paths gdttype fhl_list
2247 if {$gdttype eq "touching paths:"} {
2248 if {[catch {set paths [shellsplit $highlight_files]}]} return
2249 set highlight_paths [makepatterns $paths]
2250 highlight_filelist
2251 set gdtargs [concat -- $paths]
2252 } else {
2253 set gdtargs [list "-S$highlight_files"]
2255 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2256 set filehighlight [open $cmd r+]
2257 fconfigure $filehighlight -blocking 0
2258 filerun $filehighlight readfhighlight
2259 set fhl_list {}
2260 drawvisible
2261 flushhighlights
2264 proc flushhighlights {} {
2265 global filehighlight fhl_list
2267 if {[info exists filehighlight]} {
2268 lappend fhl_list {}
2269 puts $filehighlight ""
2270 flush $filehighlight
2274 proc askfilehighlight {row id} {
2275 global filehighlight fhighlights fhl_list
2277 lappend fhl_list $id
2278 set fhighlights($row) -1
2279 puts $filehighlight $id
2282 proc readfhighlight {} {
2283 global filehighlight fhighlights commitrow curview mainfont iddrawn
2284 global fhl_list
2286 if {![info exists filehighlight]} {
2287 return 0
2289 set nr 0
2290 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2291 set line [string trim $line]
2292 set i [lsearch -exact $fhl_list $line]
2293 if {$i < 0} continue
2294 for {set j 0} {$j < $i} {incr j} {
2295 set id [lindex $fhl_list $j]
2296 if {[info exists commitrow($curview,$id)]} {
2297 set fhighlights($commitrow($curview,$id)) 0
2300 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2301 if {$line eq {}} continue
2302 if {![info exists commitrow($curview,$line)]} continue
2303 set row $commitrow($curview,$line)
2304 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2305 bolden $row [concat $mainfont bold]
2307 set fhighlights($row) 1
2309 if {[eof $filehighlight]} {
2310 # strange...
2311 puts "oops, git diff-tree died"
2312 catch {close $filehighlight}
2313 unset filehighlight
2314 return 0
2316 next_hlcont
2317 return 1
2320 proc find_change {name ix op} {
2321 global nhighlights mainfont boldnamerows
2322 global findstring findpattern findtype
2324 # delete previous highlights, if any
2325 foreach row $boldnamerows {
2326 bolden_name $row $mainfont
2328 set boldnamerows {}
2329 catch {unset nhighlights}
2330 unbolden
2331 unmarkmatches
2332 if {$findtype ne "Regexp"} {
2333 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2334 $findstring]
2335 set findpattern "*$e*"
2337 drawvisible
2340 proc doesmatch {f} {
2341 global findtype findstring findpattern
2343 if {$findtype eq "Regexp"} {
2344 return [regexp $findstring $f]
2345 } elseif {$findtype eq "IgnCase"} {
2346 return [string match -nocase $findpattern $f]
2347 } else {
2348 return [string match $findpattern $f]
2352 proc askfindhighlight {row id} {
2353 global nhighlights commitinfo iddrawn mainfont
2354 global findloc
2355 global markingmatches
2357 if {![info exists commitinfo($id)]} {
2358 getcommit $id
2360 set info $commitinfo($id)
2361 set isbold 0
2362 set fldtypes {Headline Author Date Committer CDate Comments}
2363 foreach f $info ty $fldtypes {
2364 if {($findloc eq "All fields" || $findloc eq $ty) &&
2365 [doesmatch $f]} {
2366 if {$ty eq "Author"} {
2367 set isbold 2
2368 break
2370 set isbold 1
2373 if {$isbold && [info exists iddrawn($id)]} {
2374 set f [concat $mainfont bold]
2375 if {![ishighlighted $row]} {
2376 bolden $row $f
2377 if {$isbold > 1} {
2378 bolden_name $row $f
2381 if {$markingmatches} {
2382 markrowmatches $row $id
2385 set nhighlights($row) $isbold
2388 proc markrowmatches {row id} {
2389 global canv canv2 linehtag linentag commitinfo findloc
2391 set headline [lindex $commitinfo($id) 0]
2392 set author [lindex $commitinfo($id) 1]
2393 $canv delete match$row
2394 $canv2 delete match$row
2395 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2396 set m [findmatches $headline]
2397 if {$m ne {}} {
2398 markmatches $canv $row $headline $linehtag($row) $m \
2399 [$canv itemcget $linehtag($row) -font] $row
2402 if {$findloc eq "All fields" || $findloc eq "Author"} {
2403 set m [findmatches $author]
2404 if {$m ne {}} {
2405 markmatches $canv2 $row $author $linentag($row) $m \
2406 [$canv2 itemcget $linentag($row) -font] $row
2411 proc vrel_change {name ix op} {
2412 global highlight_related
2414 rhighlight_none
2415 if {$highlight_related ne "None"} {
2416 run drawvisible
2420 # prepare for testing whether commits are descendents or ancestors of a
2421 proc rhighlight_sel {a} {
2422 global descendent desc_todo ancestor anc_todo
2423 global highlight_related rhighlights
2425 catch {unset descendent}
2426 set desc_todo [list $a]
2427 catch {unset ancestor}
2428 set anc_todo [list $a]
2429 if {$highlight_related ne "None"} {
2430 rhighlight_none
2431 run drawvisible
2435 proc rhighlight_none {} {
2436 global rhighlights
2438 catch {unset rhighlights}
2439 unbolden
2442 proc is_descendent {a} {
2443 global curview children commitrow descendent desc_todo
2445 set v $curview
2446 set la $commitrow($v,$a)
2447 set todo $desc_todo
2448 set leftover {}
2449 set done 0
2450 for {set i 0} {$i < [llength $todo]} {incr i} {
2451 set do [lindex $todo $i]
2452 if {$commitrow($v,$do) < $la} {
2453 lappend leftover $do
2454 continue
2456 foreach nk $children($v,$do) {
2457 if {![info exists descendent($nk)]} {
2458 set descendent($nk) 1
2459 lappend todo $nk
2460 if {$nk eq $a} {
2461 set done 1
2465 if {$done} {
2466 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2467 return
2470 set descendent($a) 0
2471 set desc_todo $leftover
2474 proc is_ancestor {a} {
2475 global curview parentlist commitrow ancestor anc_todo
2477 set v $curview
2478 set la $commitrow($v,$a)
2479 set todo $anc_todo
2480 set leftover {}
2481 set done 0
2482 for {set i 0} {$i < [llength $todo]} {incr i} {
2483 set do [lindex $todo $i]
2484 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2485 lappend leftover $do
2486 continue
2488 foreach np [lindex $parentlist $commitrow($v,$do)] {
2489 if {![info exists ancestor($np)]} {
2490 set ancestor($np) 1
2491 lappend todo $np
2492 if {$np eq $a} {
2493 set done 1
2497 if {$done} {
2498 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2499 return
2502 set ancestor($a) 0
2503 set anc_todo $leftover
2506 proc askrelhighlight {row id} {
2507 global descendent highlight_related iddrawn mainfont rhighlights
2508 global selectedline ancestor
2510 if {![info exists selectedline]} return
2511 set isbold 0
2512 if {$highlight_related eq "Descendent" ||
2513 $highlight_related eq "Not descendent"} {
2514 if {![info exists descendent($id)]} {
2515 is_descendent $id
2517 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2518 set isbold 1
2520 } elseif {$highlight_related eq "Ancestor" ||
2521 $highlight_related eq "Not ancestor"} {
2522 if {![info exists ancestor($id)]} {
2523 is_ancestor $id
2525 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2526 set isbold 1
2529 if {[info exists iddrawn($id)]} {
2530 if {$isbold && ![ishighlighted $row]} {
2531 bolden $row [concat $mainfont bold]
2534 set rhighlights($row) $isbold
2537 proc next_hlcont {} {
2538 global fhl_row fhl_dirn displayorder numcommits
2539 global vhighlights fhighlights nhighlights rhighlights
2540 global hlview filehighlight findstring highlight_related
2542 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2543 set row $fhl_row
2544 while {1} {
2545 if {$row < 0 || $row >= $numcommits} {
2546 bell
2547 set fhl_dirn 0
2548 return
2550 set id [lindex $displayorder $row]
2551 if {[info exists hlview]} {
2552 if {![info exists vhighlights($row)]} {
2553 askvhighlight $row $id
2555 if {$vhighlights($row) > 0} break
2557 if {$findstring ne {}} {
2558 if {![info exists nhighlights($row)]} {
2559 askfindhighlight $row $id
2561 if {$nhighlights($row) > 0} break
2563 if {$highlight_related ne "None"} {
2564 if {![info exists rhighlights($row)]} {
2565 askrelhighlight $row $id
2567 if {$rhighlights($row) > 0} break
2569 if {[info exists filehighlight]} {
2570 if {![info exists fhighlights($row)]} {
2571 # ask for a few more while we're at it...
2572 set r $row
2573 for {set n 0} {$n < 100} {incr n} {
2574 if {![info exists fhighlights($r)]} {
2575 askfilehighlight $r [lindex $displayorder $r]
2577 incr r $fhl_dirn
2578 if {$r < 0 || $r >= $numcommits} break
2580 flushhighlights
2582 if {$fhighlights($row) < 0} {
2583 set fhl_row $row
2584 return
2586 if {$fhighlights($row) > 0} break
2588 incr row $fhl_dirn
2590 set fhl_dirn 0
2591 selectline $row 1
2594 proc next_highlight {dirn} {
2595 global selectedline fhl_row fhl_dirn
2596 global hlview filehighlight findstring highlight_related
2598 if {![info exists selectedline]} return
2599 if {!([info exists hlview] || $findstring ne {} ||
2600 $highlight_related ne "None" || [info exists filehighlight])} return
2601 set fhl_row [expr {$selectedline + $dirn}]
2602 set fhl_dirn $dirn
2603 next_hlcont
2606 proc cancel_next_highlight {} {
2607 global fhl_dirn
2609 set fhl_dirn 0
2612 # Graph layout functions
2614 proc shortids {ids} {
2615 set res {}
2616 foreach id $ids {
2617 if {[llength $id] > 1} {
2618 lappend res [shortids $id]
2619 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2620 lappend res [string range $id 0 7]
2621 } else {
2622 lappend res $id
2625 return $res
2628 proc incrange {l x o} {
2629 set n [llength $l]
2630 while {$x < $n} {
2631 set e [lindex $l $x]
2632 if {$e ne {}} {
2633 lset l $x [expr {$e + $o}]
2635 incr x
2637 return $l
2640 proc ntimes {n o} {
2641 set ret {}
2642 for {} {$n > 0} {incr n -1} {
2643 lappend ret $o
2645 return $ret
2648 proc usedinrange {id l1 l2} {
2649 global children commitrow curview
2651 if {[info exists commitrow($curview,$id)]} {
2652 set r $commitrow($curview,$id)
2653 if {$l1 <= $r && $r <= $l2} {
2654 return [expr {$r - $l1 + 1}]
2657 set kids $children($curview,$id)
2658 foreach c $kids {
2659 if {[info exists commitrow($curview,$c)]} {
2660 set r $commitrow($curview,$c)
2661 if {$l1 <= $r && $r <= $l2} {
2662 return [expr {$r - $l1 + 1}]
2666 return 0
2669 # Work out where id should go in idlist so that order-token
2670 # values increase from left to right
2671 proc idcol {idlist id {i 0}} {
2672 global ordertok curview
2674 set t $ordertok($curview,$id)
2675 if {$i >= [llength $idlist] ||
2676 $t < $ordertok($curview,[lindex $idlist $i])} {
2677 if {$i > [llength $idlist]} {
2678 set i [llength $idlist]
2680 while {[incr i -1] >= 0 &&
2681 $t < $ordertok($curview,[lindex $idlist $i])} {}
2682 incr i
2683 } else {
2684 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2685 while {[incr i] < [llength $idlist] &&
2686 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2689 return $i
2692 proc makeuparrow {oid y x} {
2693 global rowidlist uparrowlen displayorder
2695 for {set i 0} {$i < $uparrowlen && $y > 1} {incr i} {
2696 incr y -1
2697 set idl [lindex $rowidlist $y]
2698 set x [idcol $idl $oid $x]
2699 lset rowidlist $y [linsert $idl $x $oid]
2703 proc initlayout {} {
2704 global rowidlist displayorder commitlisted
2705 global rowlaidout rowoptim
2706 global rowchk
2707 global numcommits canvxmax canv
2708 global nextcolor
2709 global parentlist
2710 global colormap rowtextx
2711 global selectfirst
2713 set numcommits 0
2714 set displayorder {}
2715 set commitlisted {}
2716 set parentlist {}
2717 set nextcolor 0
2718 set rowidlist {{}}
2719 catch {unset rowchk}
2720 set rowlaidout 0
2721 set rowoptim 0
2722 set canvxmax [$canv cget -width]
2723 catch {unset colormap}
2724 catch {unset rowtextx}
2725 set selectfirst 1
2728 proc setcanvscroll {} {
2729 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2731 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2732 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2733 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2734 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2737 proc visiblerows {} {
2738 global canv numcommits linespc
2740 set ymax [lindex [$canv cget -scrollregion] 3]
2741 if {$ymax eq {} || $ymax == 0} return
2742 set f [$canv yview]
2743 set y0 [expr {int([lindex $f 0] * $ymax)}]
2744 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2745 if {$r0 < 0} {
2746 set r0 0
2748 set y1 [expr {int([lindex $f 1] * $ymax)}]
2749 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2750 if {$r1 >= $numcommits} {
2751 set r1 [expr {$numcommits - 1}]
2753 return [list $r0 $r1]
2756 proc layoutmore {tmax allread} {
2757 global rowlaidout rowoptim commitidx numcommits optim_delay
2758 global uparrowlen curview rowidlist
2760 set showlast 0
2761 set showdelay $optim_delay
2762 set optdelay [expr {$uparrowlen + 1}]
2763 while {1} {
2764 if {$rowoptim - $showdelay > $numcommits} {
2765 showstuff [expr {$rowoptim - $showdelay}] $showlast
2766 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2767 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2768 if {$nr > 100} {
2769 set nr 100
2771 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2772 incr rowoptim $nr
2773 } elseif {$commitidx($curview) > $rowlaidout} {
2774 set nr [expr {$commitidx($curview) - $rowlaidout}]
2775 # may need to increase this threshold if uparrowlen or
2776 # mingaplen are increased...
2777 if {$nr > 200} {
2778 set nr 200
2780 set row $rowlaidout
2781 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2782 if {$rowlaidout == $row} {
2783 return 0
2785 } elseif {$allread} {
2786 set optdelay 0
2787 set nrows $commitidx($curview)
2788 if {[lindex $rowidlist $nrows] ne {}} {
2789 layouttail
2790 set rowlaidout $commitidx($curview)
2791 } elseif {$rowoptim == $nrows} {
2792 set showdelay 0
2793 set showlast 1
2794 if {$numcommits == $nrows} {
2795 return 0
2798 } else {
2799 return 0
2801 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2802 return 1
2807 proc showstuff {canshow last} {
2808 global numcommits commitrow pending_select selectedline curview
2809 global lookingforhead mainheadid displayorder selectfirst
2810 global lastscrollset commitinterest
2812 if {$numcommits == 0} {
2813 global phase
2814 set phase "incrdraw"
2815 allcanvs delete all
2817 for {set l $numcommits} {$l < $canshow} {incr l} {
2818 set id [lindex $displayorder $l]
2819 if {[info exists commitinterest($id)]} {
2820 foreach script $commitinterest($id) {
2821 eval [string map [list "%I" $id] $script]
2823 unset commitinterest($id)
2826 set r0 $numcommits
2827 set prev $numcommits
2828 set numcommits $canshow
2829 set t [clock clicks -milliseconds]
2830 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2831 set lastscrollset $t
2832 setcanvscroll
2834 set rows [visiblerows]
2835 set r1 [lindex $rows 1]
2836 if {$r1 >= $canshow} {
2837 set r1 [expr {$canshow - 1}]
2839 if {$r0 <= $r1} {
2840 drawcommits $r0 $r1
2842 if {[info exists pending_select] &&
2843 [info exists commitrow($curview,$pending_select)] &&
2844 $commitrow($curview,$pending_select) < $numcommits} {
2845 selectline $commitrow($curview,$pending_select) 1
2847 if {$selectfirst} {
2848 if {[info exists selectedline] || [info exists pending_select]} {
2849 set selectfirst 0
2850 } else {
2851 set l [first_real_row]
2852 selectline $l 1
2853 set selectfirst 0
2856 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2857 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2858 set lookingforhead 0
2859 dodiffindex
2863 proc doshowlocalchanges {} {
2864 global lookingforhead curview mainheadid phase commitrow
2866 if {[info exists commitrow($curview,$mainheadid)] &&
2867 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2868 dodiffindex
2869 } elseif {$phase ne {}} {
2870 set lookingforhead 1
2874 proc dohidelocalchanges {} {
2875 global lookingforhead localfrow localirow lserial
2877 set lookingforhead 0
2878 if {$localfrow >= 0} {
2879 removerow $localfrow
2880 set localfrow -1
2881 if {$localirow > 0} {
2882 incr localirow -1
2885 if {$localirow >= 0} {
2886 removerow $localirow
2887 set localirow -1
2889 incr lserial
2892 # spawn off a process to do git diff-index --cached HEAD
2893 proc dodiffindex {} {
2894 global localirow localfrow lserial
2896 incr lserial
2897 set localfrow -1
2898 set localirow -1
2899 set fd [open "|git diff-index --cached HEAD" r]
2900 fconfigure $fd -blocking 0
2901 filerun $fd [list readdiffindex $fd $lserial]
2904 proc readdiffindex {fd serial} {
2905 global localirow commitrow mainheadid nullid2 curview
2906 global commitinfo commitdata lserial
2908 set isdiff 1
2909 if {[gets $fd line] < 0} {
2910 if {![eof $fd]} {
2911 return 1
2913 set isdiff 0
2915 # we only need to see one line and we don't really care what it says...
2916 close $fd
2918 # now see if there are any local changes not checked in to the index
2919 if {$serial == $lserial} {
2920 set fd [open "|git diff-files" r]
2921 fconfigure $fd -blocking 0
2922 filerun $fd [list readdifffiles $fd $serial]
2925 if {$isdiff && $serial == $lserial && $localirow == -1} {
2926 # add the line for the changes in the index to the graph
2927 set localirow $commitrow($curview,$mainheadid)
2928 set hl "Local changes checked in to index but not committed"
2929 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2930 set commitdata($nullid2) "\n $hl\n"
2931 insertrow $localirow $nullid2
2933 return 0
2936 proc readdifffiles {fd serial} {
2937 global localirow localfrow commitrow mainheadid nullid curview
2938 global commitinfo commitdata lserial
2940 set isdiff 1
2941 if {[gets $fd line] < 0} {
2942 if {![eof $fd]} {
2943 return 1
2945 set isdiff 0
2947 # we only need to see one line and we don't really care what it says...
2948 close $fd
2950 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2951 # add the line for the local diff to the graph
2952 if {$localirow >= 0} {
2953 set localfrow $localirow
2954 incr localirow
2955 } else {
2956 set localfrow $commitrow($curview,$mainheadid)
2958 set hl "Local uncommitted changes, not checked in to index"
2959 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2960 set commitdata($nullid) "\n $hl\n"
2961 insertrow $localfrow $nullid
2963 return 0
2966 proc layoutrows {row endrow last} {
2967 global rowidlist displayorder
2968 global uparrowlen downarrowlen maxwidth mingaplen
2969 global children parentlist
2970 global commitidx curview
2971 global rowchk
2973 set idlist [lindex $rowidlist $row]
2974 while {$row < $endrow} {
2975 set id [lindex $displayorder $row]
2976 if {1} {
2977 if {!$last &&
2978 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2979 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2980 set i [lindex $idlist $x]
2981 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2982 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2983 [expr {$row + $uparrowlen + $mingaplen}]]
2984 if {$r == 0} {
2985 set idlist [lreplace $idlist $x $x]
2986 continue
2988 set rowchk($i) [expr {$row + $r}]
2991 lset rowidlist $row $idlist
2993 set oldolds {}
2994 set newolds {}
2995 foreach p [lindex $parentlist $row] {
2996 # is id the first child of this parent?
2997 if {$id eq [lindex $children($curview,$p) 0]} {
2998 lappend newolds $p
2999 } elseif {[lsearch -exact $idlist $p] < 0} {
3000 lappend oldolds $p
3003 set col [lsearch -exact $idlist $id]
3004 if {$col < 0} {
3005 set col [idcol $idlist $id]
3006 set idlist [linsert $idlist $col $id]
3007 lset rowidlist $row $idlist
3008 if {$children($curview,$id) ne {}} {
3009 makeuparrow $id $row $col
3012 incr row
3013 set idlist [lreplace $idlist $col $col]
3014 set x $col
3015 foreach i $newolds {
3016 set x [idcol $idlist $i $x]
3017 set idlist [linsert $idlist $x $i]
3019 foreach oid $oldolds {
3020 set x [idcol $idlist $oid $x]
3021 set idlist [linsert $idlist $x $oid]
3022 makeuparrow $oid $row $x
3024 lappend rowidlist $idlist
3026 return $row
3029 proc addextraid {id row} {
3030 global displayorder commitrow commitinfo
3031 global commitidx commitlisted
3032 global parentlist children curview
3034 incr commitidx($curview)
3035 lappend displayorder $id
3036 lappend commitlisted 0
3037 lappend parentlist {}
3038 set commitrow($curview,$id) $row
3039 readcommit $id
3040 if {![info exists commitinfo($id)]} {
3041 set commitinfo($id) {"No commit information available"}
3043 if {![info exists children($curview,$id)]} {
3044 set children($curview,$id) {}
3048 proc layouttail {} {
3049 global rowidlist commitidx curview
3051 set row $commitidx($curview)
3052 set idlist [lindex $rowidlist $row]
3053 while {$idlist ne {}} {
3054 set col [expr {[llength $idlist] - 1}]
3055 set id [lindex $idlist $col]
3056 addextraid $id $row
3057 incr row
3058 set idlist [lreplace $idlist $col $col]
3059 lappend rowidlist $idlist
3063 proc insert_pad {row col npad} {
3064 global rowidlist
3066 set pad [ntimes $npad {}]
3067 set idlist [lindex $rowidlist $row]
3068 set bef [lrange $idlist 0 [expr {$col - 1}]]
3069 set aft [lrange $idlist $col end]
3070 set i [lsearch -exact $aft {}]
3071 if {$i > 0} {
3072 set aft [lreplace $aft $i $i]
3074 lset rowidlist $row [concat $bef $pad $aft]
3077 proc optimize_rows {row col endrow} {
3078 global rowidlist displayorder curview children
3080 if {$row < 1} {
3081 set row 1
3083 set idlist [lindex $rowidlist [expr {$row - 1}]]
3084 if {$row >= 2} {
3085 set previdlist [lindex $rowidlist [expr {$row - 2}]]
3086 } else {
3087 set previdlist {}
3089 for {} {$row < $endrow} {incr row} {
3090 set pprevidlist $previdlist
3091 set previdlist $idlist
3092 set idlist [lindex $rowidlist $row]
3093 set haspad 0
3094 set y0 [expr {$row - 1}]
3095 set ym [expr {$row - 2}]
3096 set x0 -1
3097 set xm -1
3098 for {} {$col < [llength $idlist]} {incr col} {
3099 set id [lindex $idlist $col]
3100 if {[lindex $previdlist $col] eq $id} continue
3101 if {$id eq {}} {
3102 set haspad 1
3103 continue
3105 set x0 [lsearch -exact $previdlist $id]
3106 if {$x0 < 0} continue
3107 set z [expr {$x0 - $col}]
3108 set isarrow 0
3109 set z0 {}
3110 if {$ym >= 0} {
3111 set xm [lsearch -exact $pprevidlist $id]
3112 if {$xm >= 0} {
3113 set z0 [expr {$xm - $x0}]
3116 if {$z0 eq {}} {
3117 # if row y0 is the first child of $id then it's not an arrow
3118 if {[lindex $children($curview,$id) 0] ne
3119 [lindex $displayorder $y0]} {
3120 set isarrow 1
3123 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3124 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3125 set isarrow 1
3127 # Looking at lines from this row to the previous row,
3128 # make them go straight up if they end in an arrow on
3129 # the previous row; otherwise make them go straight up
3130 # or at 45 degrees.
3131 if {$z < -1 || ($z < 0 && $isarrow)} {
3132 # Line currently goes left too much;
3133 # insert pads in the previous row, then optimize it
3134 set npad [expr {-1 - $z + $isarrow}]
3135 insert_pad $y0 $x0 $npad
3136 if {$y0 > 0} {
3137 optimize_rows $y0 $x0 $row
3139 set previdlist [lindex $rowidlist $y0]
3140 set x0 [lsearch -exact $previdlist $id]
3141 set z [expr {$x0 - $col}]
3142 if {$z0 ne {}} {
3143 set pprevidlist [lindex $rowidlist $ym]
3144 set xm [lsearch -exact $pprevidlist $id]
3145 set z0 [expr {$xm - $x0}]
3147 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3148 # Line currently goes right too much;
3149 # insert pads in this line
3150 set npad [expr {$z - 1 + $isarrow}]
3151 insert_pad $row $col $npad
3152 set idlist [lindex $rowidlist $row]
3153 incr col $npad
3154 set z [expr {$x0 - $col}]
3155 set haspad 1
3157 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3158 # this line links to its first child on row $row-2
3159 set id [lindex $displayorder $ym]
3160 set xc [lsearch -exact $pprevidlist $id]
3161 if {$xc >= 0} {
3162 set z0 [expr {$xc - $x0}]
3165 # avoid lines jigging left then immediately right
3166 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3167 insert_pad $y0 $x0 1
3168 incr x0
3169 optimize_rows $y0 $x0 $row
3170 set previdlist [lindex $rowidlist $y0]
3171 set pprevidlist [lindex $rowidlist $ym]
3174 if {!$haspad} {
3175 # Find the first column that doesn't have a line going right
3176 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3177 set id [lindex $idlist $col]
3178 if {$id eq {}} break
3179 set x0 [lsearch -exact $previdlist $id]
3180 if {$x0 < 0} {
3181 # check if this is the link to the first child
3182 set kid [lindex $displayorder $y0]
3183 if {[lindex $children($curview,$id) 0] eq $kid} {
3184 # it is, work out offset to child
3185 set x0 [lsearch -exact $previdlist $kid]
3188 if {$x0 <= $col} break
3190 # Insert a pad at that column as long as it has a line and
3191 # isn't the last column
3192 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3193 set idlist [linsert $idlist $col {}]
3196 lset rowidlist $row $idlist
3197 set col 0
3201 proc xc {row col} {
3202 global canvx0 linespc
3203 return [expr {$canvx0 + $col * $linespc}]
3206 proc yc {row} {
3207 global canvy0 linespc
3208 return [expr {$canvy0 + $row * $linespc}]
3211 proc linewidth {id} {
3212 global thickerline lthickness
3214 set wid $lthickness
3215 if {[info exists thickerline] && $id eq $thickerline} {
3216 set wid [expr {2 * $lthickness}]
3218 return $wid
3221 proc rowranges {id} {
3222 global commitrow curview children uparrowlen downarrowlen
3223 global rowidlist
3225 set kids $children($curview,$id)
3226 if {$kids eq {}} {
3227 return {}
3229 set ret {}
3230 lappend kids $id
3231 foreach child $kids {
3232 if {![info exists commitrow($curview,$child)]} break
3233 set row $commitrow($curview,$child)
3234 if {![info exists prev]} {
3235 lappend ret [expr {$row + 1}]
3236 } else {
3237 if {$row <= $prevrow} {
3238 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3240 # see if the line extends the whole way from prevrow to row
3241 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3242 [lsearch -exact [lindex $rowidlist \
3243 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3244 # it doesn't, see where it ends
3245 set r [expr {$prevrow + $downarrowlen}]
3246 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3247 while {[incr r -1] > $prevrow &&
3248 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3249 } else {
3250 while {[incr r] <= $row &&
3251 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3252 incr r -1
3254 lappend ret $r
3255 # see where it starts up again
3256 set r [expr {$row - $uparrowlen}]
3257 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3258 while {[incr r] < $row &&
3259 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3260 } else {
3261 while {[incr r -1] >= $prevrow &&
3262 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3263 incr r
3265 lappend ret $r
3268 if {$child eq $id} {
3269 lappend ret $row
3271 set prev $id
3272 set prevrow $row
3274 return $ret
3277 proc drawlineseg {id row endrow arrowlow} {
3278 global rowidlist displayorder iddrawn linesegs
3279 global canv colormap linespc curview maxlinelen parentlist
3281 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3282 set le [expr {$row + 1}]
3283 set arrowhigh 1
3284 while {1} {
3285 set c [lsearch -exact [lindex $rowidlist $le] $id]
3286 if {$c < 0} {
3287 incr le -1
3288 break
3290 lappend cols $c
3291 set x [lindex $displayorder $le]
3292 if {$x eq $id} {
3293 set arrowhigh 0
3294 break
3296 if {[info exists iddrawn($x)] || $le == $endrow} {
3297 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3298 if {$c >= 0} {
3299 lappend cols $c
3300 set arrowhigh 0
3302 break
3304 incr le
3306 if {$le <= $row} {
3307 return $row
3310 set lines {}
3311 set i 0
3312 set joinhigh 0
3313 if {[info exists linesegs($id)]} {
3314 set lines $linesegs($id)
3315 foreach li $lines {
3316 set r0 [lindex $li 0]
3317 if {$r0 > $row} {
3318 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3319 set joinhigh 1
3321 break
3323 incr i
3326 set joinlow 0
3327 if {$i > 0} {
3328 set li [lindex $lines [expr {$i-1}]]
3329 set r1 [lindex $li 1]
3330 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3331 set joinlow 1
3335 set x [lindex $cols [expr {$le - $row}]]
3336 set xp [lindex $cols [expr {$le - 1 - $row}]]
3337 set dir [expr {$xp - $x}]
3338 if {$joinhigh} {
3339 set ith [lindex $lines $i 2]
3340 set coords [$canv coords $ith]
3341 set ah [$canv itemcget $ith -arrow]
3342 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3343 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3344 if {$x2 ne {} && $x - $x2 == $dir} {
3345 set coords [lrange $coords 0 end-2]
3347 } else {
3348 set coords [list [xc $le $x] [yc $le]]
3350 if {$joinlow} {
3351 set itl [lindex $lines [expr {$i-1}] 2]
3352 set al [$canv itemcget $itl -arrow]
3353 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3354 } elseif {$arrowlow} {
3355 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3356 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3357 set arrowlow 0
3360 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3361 for {set y $le} {[incr y -1] > $row} {} {
3362 set x $xp
3363 set xp [lindex $cols [expr {$y - 1 - $row}]]
3364 set ndir [expr {$xp - $x}]
3365 if {$dir != $ndir || $xp < 0} {
3366 lappend coords [xc $y $x] [yc $y]
3368 set dir $ndir
3370 if {!$joinlow} {
3371 if {$xp < 0} {
3372 # join parent line to first child
3373 set ch [lindex $displayorder $row]
3374 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3375 if {$xc < 0} {
3376 puts "oops: drawlineseg: child $ch not on row $row"
3377 } elseif {$xc != $x} {
3378 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3379 set d [expr {int(0.5 * $linespc)}]
3380 set x1 [xc $row $x]
3381 if {$xc < $x} {
3382 set x2 [expr {$x1 - $d}]
3383 } else {
3384 set x2 [expr {$x1 + $d}]
3386 set y2 [yc $row]
3387 set y1 [expr {$y2 + $d}]
3388 lappend coords $x1 $y1 $x2 $y2
3389 } elseif {$xc < $x - 1} {
3390 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3391 } elseif {$xc > $x + 1} {
3392 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3394 set x $xc
3396 lappend coords [xc $row $x] [yc $row]
3397 } else {
3398 set xn [xc $row $xp]
3399 set yn [yc $row]
3400 lappend coords $xn $yn
3402 if {!$joinhigh} {
3403 assigncolor $id
3404 set t [$canv create line $coords -width [linewidth $id] \
3405 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3406 $canv lower $t
3407 bindline $t $id
3408 set lines [linsert $lines $i [list $row $le $t]]
3409 } else {
3410 $canv coords $ith $coords
3411 if {$arrow ne $ah} {
3412 $canv itemconf $ith -arrow $arrow
3414 lset lines $i 0 $row
3416 } else {
3417 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3418 set ndir [expr {$xo - $xp}]
3419 set clow [$canv coords $itl]
3420 if {$dir == $ndir} {
3421 set clow [lrange $clow 2 end]
3423 set coords [concat $coords $clow]
3424 if {!$joinhigh} {
3425 lset lines [expr {$i-1}] 1 $le
3426 } else {
3427 # coalesce two pieces
3428 $canv delete $ith
3429 set b [lindex $lines [expr {$i-1}] 0]
3430 set e [lindex $lines $i 1]
3431 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3433 $canv coords $itl $coords
3434 if {$arrow ne $al} {
3435 $canv itemconf $itl -arrow $arrow
3439 set linesegs($id) $lines
3440 return $le
3443 proc drawparentlinks {id row} {
3444 global rowidlist canv colormap curview parentlist
3445 global idpos linespc
3447 set rowids [lindex $rowidlist $row]
3448 set col [lsearch -exact $rowids $id]
3449 if {$col < 0} return
3450 set olds [lindex $parentlist $row]
3451 set row2 [expr {$row + 1}]
3452 set x [xc $row $col]
3453 set y [yc $row]
3454 set y2 [yc $row2]
3455 set d [expr {int(0.5 * $linespc)}]
3456 set ymid [expr {$y + $d}]
3457 set ids [lindex $rowidlist $row2]
3458 # rmx = right-most X coord used
3459 set rmx 0
3460 foreach p $olds {
3461 set i [lsearch -exact $ids $p]
3462 if {$i < 0} {
3463 puts "oops, parent $p of $id not in list"
3464 continue
3466 set x2 [xc $row2 $i]
3467 if {$x2 > $rmx} {
3468 set rmx $x2
3470 set j [lsearch -exact $rowids $p]
3471 if {$j < 0} {
3472 # drawlineseg will do this one for us
3473 continue
3475 assigncolor $p
3476 # should handle duplicated parents here...
3477 set coords [list $x $y]
3478 if {$i != $col} {
3479 # if attaching to a vertical segment, draw a smaller
3480 # slant for visual distinctness
3481 if {$i == $j} {
3482 if {$i < $col} {
3483 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3484 } else {
3485 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3487 } elseif {$i < $col && $i < $j} {
3488 # segment slants towards us already
3489 lappend coords [xc $row $j] $y
3490 } else {
3491 if {$i < $col - 1} {
3492 lappend coords [expr {$x2 + $linespc}] $y
3493 } elseif {$i > $col + 1} {
3494 lappend coords [expr {$x2 - $linespc}] $y
3496 lappend coords $x2 $y2
3498 } else {
3499 lappend coords $x2 $y2
3501 set t [$canv create line $coords -width [linewidth $p] \
3502 -fill $colormap($p) -tags lines.$p]
3503 $canv lower $t
3504 bindline $t $p
3506 if {$rmx > [lindex $idpos($id) 1]} {
3507 lset idpos($id) 1 $rmx
3508 redrawtags $id
3512 proc drawlines {id} {
3513 global canv
3515 $canv itemconf lines.$id -width [linewidth $id]
3518 proc drawcmittext {id row col} {
3519 global linespc canv canv2 canv3 canvy0 fgcolor curview
3520 global commitlisted commitinfo rowidlist parentlist
3521 global rowtextx idpos idtags idheads idotherrefs
3522 global linehtag linentag linedtag
3523 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3525 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3526 set listed [lindex $commitlisted $row]
3527 if {$id eq $nullid} {
3528 set ofill red
3529 } elseif {$id eq $nullid2} {
3530 set ofill green
3531 } else {
3532 set ofill [expr {$listed != 0? "blue": "white"}]
3534 set x [xc $row $col]
3535 set y [yc $row]
3536 set orad [expr {$linespc / 3}]
3537 if {$listed <= 1} {
3538 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3539 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3540 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3541 } elseif {$listed == 2} {
3542 # triangle pointing left for left-side commits
3543 set t [$canv create polygon \
3544 [expr {$x - $orad}] $y \
3545 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3546 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3547 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3548 } else {
3549 # triangle pointing right for right-side commits
3550 set t [$canv create polygon \
3551 [expr {$x + $orad - 1}] $y \
3552 [expr {$x - $orad}] [expr {$y - $orad}] \
3553 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3554 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3556 $canv raise $t
3557 $canv bind $t <1> {selcanvline {} %x %y}
3558 set rmx [llength [lindex $rowidlist $row]]
3559 set olds [lindex $parentlist $row]
3560 if {$olds ne {}} {
3561 set nextids [lindex $rowidlist [expr {$row + 1}]]
3562 foreach p $olds {
3563 set i [lsearch -exact $nextids $p]
3564 if {$i > $rmx} {
3565 set rmx $i
3569 set xt [xc $row $rmx]
3570 set rowtextx($row) $xt
3571 set idpos($id) [list $x $xt $y]
3572 if {[info exists idtags($id)] || [info exists idheads($id)]
3573 || [info exists idotherrefs($id)]} {
3574 set xt [drawtags $id $x $xt $y]
3576 set headline [lindex $commitinfo($id) 0]
3577 set name [lindex $commitinfo($id) 1]
3578 set date [lindex $commitinfo($id) 2]
3579 set date [formatdate $date]
3580 set font $mainfont
3581 set nfont $mainfont
3582 set isbold [ishighlighted $row]
3583 if {$isbold > 0} {
3584 lappend boldrows $row
3585 lappend font bold
3586 if {$isbold > 1} {
3587 lappend boldnamerows $row
3588 lappend nfont bold
3591 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3592 -text $headline -font $font -tags text]
3593 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3594 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3595 -text $name -font $nfont -tags text]
3596 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3597 -text $date -font $mainfont -tags text]
3598 set xr [expr {$xt + [font measure $mainfont $headline]}]
3599 if {$xr > $canvxmax} {
3600 set canvxmax $xr
3601 setcanvscroll
3605 proc drawcmitrow {row} {
3606 global displayorder rowidlist
3607 global iddrawn markingmatches
3608 global commitinfo parentlist numcommits
3609 global filehighlight fhighlights findstring nhighlights
3610 global hlview vhighlights
3611 global highlight_related rhighlights
3613 if {$row >= $numcommits} return
3615 set id [lindex $displayorder $row]
3616 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3617 askvhighlight $row $id
3619 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3620 askfilehighlight $row $id
3622 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3623 askfindhighlight $row $id
3625 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3626 askrelhighlight $row $id
3628 if {![info exists iddrawn($id)]} {
3629 set col [lsearch -exact [lindex $rowidlist $row] $id]
3630 if {$col < 0} {
3631 puts "oops, row $row id $id not in list"
3632 return
3634 if {![info exists commitinfo($id)]} {
3635 getcommit $id
3637 assigncolor $id
3638 drawcmittext $id $row $col
3639 set iddrawn($id) 1
3641 if {$markingmatches} {
3642 markrowmatches $row $id
3646 proc drawcommits {row {endrow {}}} {
3647 global numcommits iddrawn displayorder curview
3648 global parentlist rowidlist
3650 if {$row < 0} {
3651 set row 0
3653 if {$endrow eq {}} {
3654 set endrow $row
3656 if {$endrow >= $numcommits} {
3657 set endrow [expr {$numcommits - 1}]
3660 # make the lines join to already-drawn rows either side
3661 set r [expr {$row - 1}]
3662 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3663 set r $row
3665 set er [expr {$endrow + 1}]
3666 if {$er >= $numcommits ||
3667 ![info exists iddrawn([lindex $displayorder $er])]} {
3668 set er $endrow
3670 for {} {$r <= $er} {incr r} {
3671 set id [lindex $displayorder $r]
3672 set wasdrawn [info exists iddrawn($id)]
3673 drawcmitrow $r
3674 if {$r == $er} break
3675 set nextid [lindex $displayorder [expr {$r + 1}]]
3676 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3677 catch {unset prevlines}
3678 continue
3680 drawparentlinks $id $r
3682 if {[info exists lineends($r)]} {
3683 foreach lid $lineends($r) {
3684 unset prevlines($lid)
3687 set rowids [lindex $rowidlist $r]
3688 foreach lid $rowids {
3689 if {$lid eq {}} continue
3690 if {$lid eq $id} {
3691 # see if this is the first child of any of its parents
3692 foreach p [lindex $parentlist $r] {
3693 if {[lsearch -exact $rowids $p] < 0} {
3694 # make this line extend up to the child
3695 set le [drawlineseg $p $r $er 0]
3696 lappend lineends($le) $p
3697 set prevlines($p) 1
3700 } elseif {![info exists prevlines($lid)]} {
3701 set le [drawlineseg $lid $r $er 1]
3702 lappend lineends($le) $lid
3703 set prevlines($lid) 1
3709 proc drawfrac {f0 f1} {
3710 global canv linespc
3712 set ymax [lindex [$canv cget -scrollregion] 3]
3713 if {$ymax eq {} || $ymax == 0} return
3714 set y0 [expr {int($f0 * $ymax)}]
3715 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3716 set y1 [expr {int($f1 * $ymax)}]
3717 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3718 drawcommits $row $endrow
3721 proc drawvisible {} {
3722 global canv
3723 eval drawfrac [$canv yview]
3726 proc clear_display {} {
3727 global iddrawn linesegs
3728 global vhighlights fhighlights nhighlights rhighlights
3730 allcanvs delete all
3731 catch {unset iddrawn}
3732 catch {unset linesegs}
3733 catch {unset vhighlights}
3734 catch {unset fhighlights}
3735 catch {unset nhighlights}
3736 catch {unset rhighlights}
3739 proc findcrossings {id} {
3740 global rowidlist parentlist numcommits displayorder
3742 set cross {}
3743 set ccross {}
3744 foreach {s e} [rowranges $id] {
3745 if {$e >= $numcommits} {
3746 set e [expr {$numcommits - 1}]
3748 if {$e <= $s} continue
3749 for {set row $e} {[incr row -1] >= $s} {} {
3750 set x [lsearch -exact [lindex $rowidlist $row] $id]
3751 if {$x < 0} break
3752 set olds [lindex $parentlist $row]
3753 set kid [lindex $displayorder $row]
3754 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3755 if {$kidx < 0} continue
3756 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3757 foreach p $olds {
3758 set px [lsearch -exact $nextrow $p]
3759 if {$px < 0} continue
3760 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3761 if {[lsearch -exact $ccross $p] >= 0} continue
3762 if {$x == $px + ($kidx < $px? -1: 1)} {
3763 lappend ccross $p
3764 } elseif {[lsearch -exact $cross $p] < 0} {
3765 lappend cross $p
3771 return [concat $ccross {{}} $cross]
3774 proc assigncolor {id} {
3775 global colormap colors nextcolor
3776 global commitrow parentlist children children curview
3778 if {[info exists colormap($id)]} return
3779 set ncolors [llength $colors]
3780 if {[info exists children($curview,$id)]} {
3781 set kids $children($curview,$id)
3782 } else {
3783 set kids {}
3785 if {[llength $kids] == 1} {
3786 set child [lindex $kids 0]
3787 if {[info exists colormap($child)]
3788 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3789 set colormap($id) $colormap($child)
3790 return
3793 set badcolors {}
3794 set origbad {}
3795 foreach x [findcrossings $id] {
3796 if {$x eq {}} {
3797 # delimiter between corner crossings and other crossings
3798 if {[llength $badcolors] >= $ncolors - 1} break
3799 set origbad $badcolors
3801 if {[info exists colormap($x)]
3802 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3803 lappend badcolors $colormap($x)
3806 if {[llength $badcolors] >= $ncolors} {
3807 set badcolors $origbad
3809 set origbad $badcolors
3810 if {[llength $badcolors] < $ncolors - 1} {
3811 foreach child $kids {
3812 if {[info exists colormap($child)]
3813 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3814 lappend badcolors $colormap($child)
3816 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3817 if {[info exists colormap($p)]
3818 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3819 lappend badcolors $colormap($p)
3823 if {[llength $badcolors] >= $ncolors} {
3824 set badcolors $origbad
3827 for {set i 0} {$i <= $ncolors} {incr i} {
3828 set c [lindex $colors $nextcolor]
3829 if {[incr nextcolor] >= $ncolors} {
3830 set nextcolor 0
3832 if {[lsearch -exact $badcolors $c]} break
3834 set colormap($id) $c
3837 proc bindline {t id} {
3838 global canv
3840 $canv bind $t <Enter> "lineenter %x %y $id"
3841 $canv bind $t <Motion> "linemotion %x %y $id"
3842 $canv bind $t <Leave> "lineleave $id"
3843 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3846 proc drawtags {id x xt y1} {
3847 global idtags idheads idotherrefs mainhead
3848 global linespc lthickness
3849 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3851 set marks {}
3852 set ntags 0
3853 set nheads 0
3854 if {[info exists idtags($id)]} {
3855 set marks $idtags($id)
3856 set ntags [llength $marks]
3858 if {[info exists idheads($id)]} {
3859 set marks [concat $marks $idheads($id)]
3860 set nheads [llength $idheads($id)]
3862 if {[info exists idotherrefs($id)]} {
3863 set marks [concat $marks $idotherrefs($id)]
3865 if {$marks eq {}} {
3866 return $xt
3869 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3870 set yt [expr {$y1 - 0.5 * $linespc}]
3871 set yb [expr {$yt + $linespc - 1}]
3872 set xvals {}
3873 set wvals {}
3874 set i -1
3875 foreach tag $marks {
3876 incr i
3877 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3878 set wid [font measure [concat $mainfont bold] $tag]
3879 } else {
3880 set wid [font measure $mainfont $tag]
3882 lappend xvals $xt
3883 lappend wvals $wid
3884 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3886 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3887 -width $lthickness -fill black -tags tag.$id]
3888 $canv lower $t
3889 foreach tag $marks x $xvals wid $wvals {
3890 set xl [expr {$x + $delta}]
3891 set xr [expr {$x + $delta + $wid + $lthickness}]
3892 set font $mainfont
3893 if {[incr ntags -1] >= 0} {
3894 # draw a tag
3895 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3896 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3897 -width 1 -outline black -fill yellow -tags tag.$id]
3898 $canv bind $t <1> [list showtag $tag 1]
3899 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3900 } else {
3901 # draw a head or other ref
3902 if {[incr nheads -1] >= 0} {
3903 set col green
3904 if {$tag eq $mainhead} {
3905 lappend font bold
3907 } else {
3908 set col "#ddddff"
3910 set xl [expr {$xl - $delta/2}]
3911 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3912 -width 1 -outline black -fill $col -tags tag.$id
3913 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3914 set rwid [font measure $mainfont $remoteprefix]
3915 set xi [expr {$x + 1}]
3916 set yti [expr {$yt + 1}]
3917 set xri [expr {$x + $rwid}]
3918 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3919 -width 0 -fill "#ffddaa" -tags tag.$id
3922 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3923 -font $font -tags [list tag.$id text]]
3924 if {$ntags >= 0} {
3925 $canv bind $t <1> [list showtag $tag 1]
3926 } elseif {$nheads >= 0} {
3927 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3930 return $xt
3933 proc xcoord {i level ln} {
3934 global canvx0 xspc1 xspc2
3936 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3937 if {$i > 0 && $i == $level} {
3938 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3939 } elseif {$i > $level} {
3940 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3942 return $x
3945 proc show_status {msg} {
3946 global canv mainfont fgcolor
3948 clear_display
3949 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3950 -tags text -fill $fgcolor
3953 # Insert a new commit as the child of the commit on row $row.
3954 # The new commit will be displayed on row $row and the commits
3955 # on that row and below will move down one row.
3956 proc insertrow {row newcmit} {
3957 global displayorder parentlist commitlisted children
3958 global commitrow curview rowidlist numcommits
3959 global rowlaidout rowoptim numcommits
3960 global selectedline rowchk commitidx
3962 if {$row >= $numcommits} {
3963 puts "oops, inserting new row $row but only have $numcommits rows"
3964 return
3966 set p [lindex $displayorder $row]
3967 set displayorder [linsert $displayorder $row $newcmit]
3968 set parentlist [linsert $parentlist $row $p]
3969 set kids $children($curview,$p)
3970 lappend kids $newcmit
3971 set children($curview,$p) $kids
3972 set children($curview,$newcmit) {}
3973 set commitlisted [linsert $commitlisted $row 1]
3974 set l [llength $displayorder]
3975 for {set r $row} {$r < $l} {incr r} {
3976 set id [lindex $displayorder $r]
3977 set commitrow($curview,$id) $r
3979 incr commitidx($curview)
3981 set idlist [lindex $rowidlist $row]
3982 if {[llength $kids] == 1} {
3983 set col [lsearch -exact $idlist $p]
3984 lset idlist $col $newcmit
3985 } else {
3986 set col [llength $idlist]
3987 lappend idlist $newcmit
3989 set rowidlist [linsert $rowidlist $row $idlist]
3991 catch {unset rowchk}
3993 incr rowlaidout
3994 incr rowoptim
3995 incr numcommits
3997 if {[info exists selectedline] && $selectedline >= $row} {
3998 incr selectedline
4000 redisplay
4003 # Remove a commit that was inserted with insertrow on row $row.
4004 proc removerow {row} {
4005 global displayorder parentlist commitlisted children
4006 global commitrow curview rowidlist numcommits
4007 global rowlaidout rowoptim numcommits
4008 global linesegends selectedline rowchk commitidx
4010 if {$row >= $numcommits} {
4011 puts "oops, removing row $row but only have $numcommits rows"
4012 return
4014 set rp1 [expr {$row + 1}]
4015 set id [lindex $displayorder $row]
4016 set p [lindex $parentlist $row]
4017 set displayorder [lreplace $displayorder $row $row]
4018 set parentlist [lreplace $parentlist $row $row]
4019 set commitlisted [lreplace $commitlisted $row $row]
4020 set kids $children($curview,$p)
4021 set i [lsearch -exact $kids $id]
4022 if {$i >= 0} {
4023 set kids [lreplace $kids $i $i]
4024 set children($curview,$p) $kids
4026 set l [llength $displayorder]
4027 for {set r $row} {$r < $l} {incr r} {
4028 set id [lindex $displayorder $r]
4029 set commitrow($curview,$id) $r
4031 incr commitidx($curview) -1
4033 set rowidlist [lreplace $rowidlist $row $row]
4035 catch {unset rowchk}
4037 incr rowlaidout -1
4038 incr rowoptim -1
4039 incr numcommits -1
4041 if {[info exists selectedline] && $selectedline > $row} {
4042 incr selectedline -1
4044 redisplay
4047 # Don't change the text pane cursor if it is currently the hand cursor,
4048 # showing that we are over a sha1 ID link.
4049 proc settextcursor {c} {
4050 global ctext curtextcursor
4052 if {[$ctext cget -cursor] == $curtextcursor} {
4053 $ctext config -cursor $c
4055 set curtextcursor $c
4058 proc nowbusy {what} {
4059 global isbusy
4061 if {[array names isbusy] eq {}} {
4062 . config -cursor watch
4063 settextcursor watch
4065 set isbusy($what) 1
4068 proc notbusy {what} {
4069 global isbusy maincursor textcursor
4071 catch {unset isbusy($what)}
4072 if {[array names isbusy] eq {}} {
4073 . config -cursor $maincursor
4074 settextcursor $textcursor
4078 proc findmatches {f} {
4079 global findtype findstring
4080 if {$findtype == "Regexp"} {
4081 set matches [regexp -indices -all -inline $findstring $f]
4082 } else {
4083 set fs $findstring
4084 if {$findtype == "IgnCase"} {
4085 set f [string tolower $f]
4086 set fs [string tolower $fs]
4088 set matches {}
4089 set i 0
4090 set l [string length $fs]
4091 while {[set j [string first $fs $f $i]] >= 0} {
4092 lappend matches [list $j [expr {$j+$l-1}]]
4093 set i [expr {$j + $l}]
4096 return $matches
4099 proc dofind {{rev 0}} {
4100 global findstring findstartline findcurline selectedline numcommits
4102 unmarkmatches
4103 cancel_next_highlight
4104 focus .
4105 if {$findstring eq {} || $numcommits == 0} return
4106 if {![info exists selectedline]} {
4107 set findstartline [lindex [visiblerows] $rev]
4108 } else {
4109 set findstartline $selectedline
4111 set findcurline $findstartline
4112 nowbusy finding
4113 if {!$rev} {
4114 run findmore
4115 } else {
4116 if {$findcurline == 0} {
4117 set findcurline $numcommits
4119 incr findcurline -1
4120 run findmorerev
4124 proc findnext {restart} {
4125 global findcurline
4126 if {![info exists findcurline]} {
4127 if {$restart} {
4128 dofind
4129 } else {
4130 bell
4132 } else {
4133 run findmore
4134 nowbusy finding
4138 proc findprev {} {
4139 global findcurline
4140 if {![info exists findcurline]} {
4141 dofind 1
4142 } else {
4143 run findmorerev
4144 nowbusy finding
4148 proc findmore {} {
4149 global commitdata commitinfo numcommits findstring findpattern findloc
4150 global findstartline findcurline displayorder
4152 set fldtypes {Headline Author Date Committer CDate Comments}
4153 set l [expr {$findcurline + 1}]
4154 if {$l >= $numcommits} {
4155 set l 0
4157 if {$l <= $findstartline} {
4158 set lim [expr {$findstartline + 1}]
4159 } else {
4160 set lim $numcommits
4162 if {$lim - $l > 500} {
4163 set lim [expr {$l + 500}]
4165 set last 0
4166 for {} {$l < $lim} {incr l} {
4167 set id [lindex $displayorder $l]
4168 # shouldn't happen unless git log doesn't give all the commits...
4169 if {![info exists commitdata($id)]} continue
4170 if {![doesmatch $commitdata($id)]} continue
4171 if {![info exists commitinfo($id)]} {
4172 getcommit $id
4174 set info $commitinfo($id)
4175 foreach f $info ty $fldtypes {
4176 if {($findloc eq "All fields" || $findloc eq $ty) &&
4177 [doesmatch $f]} {
4178 findselectline $l
4179 notbusy finding
4180 return 0
4184 if {$l == $findstartline + 1} {
4185 bell
4186 unset findcurline
4187 notbusy finding
4188 return 0
4190 set findcurline [expr {$l - 1}]
4191 return 1
4194 proc findmorerev {} {
4195 global commitdata commitinfo numcommits findstring findpattern findloc
4196 global findstartline findcurline displayorder
4198 set fldtypes {Headline Author Date Committer CDate Comments}
4199 set l $findcurline
4200 if {$l == 0} {
4201 set l $numcommits
4203 incr l -1
4204 if {$l >= $findstartline} {
4205 set lim [expr {$findstartline - 1}]
4206 } else {
4207 set lim -1
4209 if {$l - $lim > 500} {
4210 set lim [expr {$l - 500}]
4212 set last 0
4213 for {} {$l > $lim} {incr l -1} {
4214 set id [lindex $displayorder $l]
4215 if {![info exists commitdata($id)]} continue
4216 if {![doesmatch $commitdata($id)]} continue
4217 if {![info exists commitinfo($id)]} {
4218 getcommit $id
4220 set info $commitinfo($id)
4221 foreach f $info ty $fldtypes {
4222 if {($findloc eq "All fields" || $findloc eq $ty) &&
4223 [doesmatch $f]} {
4224 findselectline $l
4225 notbusy finding
4226 return 0
4230 if {$l == -1} {
4231 bell
4232 unset findcurline
4233 notbusy finding
4234 return 0
4236 set findcurline [expr {$l + 1}]
4237 return 1
4240 proc findselectline {l} {
4241 global findloc commentend ctext findcurline markingmatches
4243 set markingmatches 1
4244 set findcurline $l
4245 selectline $l 1
4246 if {$findloc == "All fields" || $findloc == "Comments"} {
4247 # highlight the matches in the comments
4248 set f [$ctext get 1.0 $commentend]
4249 set matches [findmatches $f]
4250 foreach match $matches {
4251 set start [lindex $match 0]
4252 set end [expr {[lindex $match 1] + 1}]
4253 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4256 drawvisible
4259 # mark the bits of a headline or author that match a find string
4260 proc markmatches {canv l str tag matches font row} {
4261 global selectedline
4263 set bbox [$canv bbox $tag]
4264 set x0 [lindex $bbox 0]
4265 set y0 [lindex $bbox 1]
4266 set y1 [lindex $bbox 3]
4267 foreach match $matches {
4268 set start [lindex $match 0]
4269 set end [lindex $match 1]
4270 if {$start > $end} continue
4271 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4272 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4273 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4274 [expr {$x0+$xlen+2}] $y1 \
4275 -outline {} -tags [list match$l matches] -fill yellow]
4276 $canv lower $t
4277 if {[info exists selectedline] && $row == $selectedline} {
4278 $canv raise $t secsel
4283 proc unmarkmatches {} {
4284 global findids markingmatches findcurline
4286 allcanvs delete matches
4287 catch {unset findids}
4288 set markingmatches 0
4289 catch {unset findcurline}
4292 proc selcanvline {w x y} {
4293 global canv canvy0 ctext linespc
4294 global rowtextx
4295 set ymax [lindex [$canv cget -scrollregion] 3]
4296 if {$ymax == {}} return
4297 set yfrac [lindex [$canv yview] 0]
4298 set y [expr {$y + $yfrac * $ymax}]
4299 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4300 if {$l < 0} {
4301 set l 0
4303 if {$w eq $canv} {
4304 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4306 unmarkmatches
4307 selectline $l 1
4310 proc commit_descriptor {p} {
4311 global commitinfo
4312 if {![info exists commitinfo($p)]} {
4313 getcommit $p
4315 set l "..."
4316 if {[llength $commitinfo($p)] > 1} {
4317 set l [lindex $commitinfo($p) 0]
4319 return "$p ($l)\n"
4322 # append some text to the ctext widget, and make any SHA1 ID
4323 # that we know about be a clickable link.
4324 proc appendwithlinks {text tags} {
4325 global ctext commitrow linknum curview
4327 set start [$ctext index "end - 1c"]
4328 $ctext insert end $text $tags
4329 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4330 foreach l $links {
4331 set s [lindex $l 0]
4332 set e [lindex $l 1]
4333 set linkid [string range $text $s $e]
4334 if {![info exists commitrow($curview,$linkid)]} continue
4335 incr e
4336 $ctext tag add link "$start + $s c" "$start + $e c"
4337 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4338 $ctext tag bind link$linknum <1> \
4339 [list selectline $commitrow($curview,$linkid) 1]
4340 incr linknum
4342 $ctext tag conf link -foreground blue -underline 1
4343 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4344 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4347 proc viewnextline {dir} {
4348 global canv linespc
4350 $canv delete hover
4351 set ymax [lindex [$canv cget -scrollregion] 3]
4352 set wnow [$canv yview]
4353 set wtop [expr {[lindex $wnow 0] * $ymax}]
4354 set newtop [expr {$wtop + $dir * $linespc}]
4355 if {$newtop < 0} {
4356 set newtop 0
4357 } elseif {$newtop > $ymax} {
4358 set newtop $ymax
4360 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4363 # add a list of tag or branch names at position pos
4364 # returns the number of names inserted
4365 proc appendrefs {pos ids var} {
4366 global ctext commitrow linknum curview $var maxrefs
4368 if {[catch {$ctext index $pos}]} {
4369 return 0
4371 $ctext conf -state normal
4372 $ctext delete $pos "$pos lineend"
4373 set tags {}
4374 foreach id $ids {
4375 foreach tag [set $var\($id\)] {
4376 lappend tags [list $tag $id]
4379 if {[llength $tags] > $maxrefs} {
4380 $ctext insert $pos "many ([llength $tags])"
4381 } else {
4382 set tags [lsort -index 0 -decreasing $tags]
4383 set sep {}
4384 foreach ti $tags {
4385 set id [lindex $ti 1]
4386 set lk link$linknum
4387 incr linknum
4388 $ctext tag delete $lk
4389 $ctext insert $pos $sep
4390 $ctext insert $pos [lindex $ti 0] $lk
4391 if {[info exists commitrow($curview,$id)]} {
4392 $ctext tag conf $lk -foreground blue
4393 $ctext tag bind $lk <1> \
4394 [list selectline $commitrow($curview,$id) 1]
4395 $ctext tag conf $lk -underline 1
4396 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4397 $ctext tag bind $lk <Leave> \
4398 { %W configure -cursor $curtextcursor }
4400 set sep ", "
4403 $ctext conf -state disabled
4404 return [llength $tags]
4407 # called when we have finished computing the nearby tags
4408 proc dispneartags {delay} {
4409 global selectedline currentid showneartags tagphase
4411 if {![info exists selectedline] || !$showneartags} return
4412 after cancel dispnexttag
4413 if {$delay} {
4414 after 200 dispnexttag
4415 set tagphase -1
4416 } else {
4417 after idle dispnexttag
4418 set tagphase 0
4422 proc dispnexttag {} {
4423 global selectedline currentid showneartags tagphase ctext
4425 if {![info exists selectedline] || !$showneartags} return
4426 switch -- $tagphase {
4428 set dtags [desctags $currentid]
4429 if {$dtags ne {}} {
4430 appendrefs precedes $dtags idtags
4434 set atags [anctags $currentid]
4435 if {$atags ne {}} {
4436 appendrefs follows $atags idtags
4440 set dheads [descheads $currentid]
4441 if {$dheads ne {}} {
4442 if {[appendrefs branch $dheads idheads] > 1
4443 && [$ctext get "branch -3c"] eq "h"} {
4444 # turn "Branch" into "Branches"
4445 $ctext conf -state normal
4446 $ctext insert "branch -2c" "es"
4447 $ctext conf -state disabled
4452 if {[incr tagphase] <= 2} {
4453 after idle dispnexttag
4457 proc selectline {l isnew} {
4458 global canv canv2 canv3 ctext commitinfo selectedline
4459 global displayorder linehtag linentag linedtag
4460 global canvy0 linespc parentlist children curview
4461 global currentid sha1entry
4462 global commentend idtags linknum
4463 global mergemax numcommits pending_select
4464 global cmitmode showneartags allcommits
4466 catch {unset pending_select}
4467 $canv delete hover
4468 normalline
4469 cancel_next_highlight
4470 unsel_reflist
4471 if {$l < 0 || $l >= $numcommits} return
4472 set y [expr {$canvy0 + $l * $linespc}]
4473 set ymax [lindex [$canv cget -scrollregion] 3]
4474 set ytop [expr {$y - $linespc - 1}]
4475 set ybot [expr {$y + $linespc + 1}]
4476 set wnow [$canv yview]
4477 set wtop [expr {[lindex $wnow 0] * $ymax}]
4478 set wbot [expr {[lindex $wnow 1] * $ymax}]
4479 set wh [expr {$wbot - $wtop}]
4480 set newtop $wtop
4481 if {$ytop < $wtop} {
4482 if {$ybot < $wtop} {
4483 set newtop [expr {$y - $wh / 2.0}]
4484 } else {
4485 set newtop $ytop
4486 if {$newtop > $wtop - $linespc} {
4487 set newtop [expr {$wtop - $linespc}]
4490 } elseif {$ybot > $wbot} {
4491 if {$ytop > $wbot} {
4492 set newtop [expr {$y - $wh / 2.0}]
4493 } else {
4494 set newtop [expr {$ybot - $wh}]
4495 if {$newtop < $wtop + $linespc} {
4496 set newtop [expr {$wtop + $linespc}]
4500 if {$newtop != $wtop} {
4501 if {$newtop < 0} {
4502 set newtop 0
4504 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4505 drawvisible
4508 if {![info exists linehtag($l)]} return
4509 $canv delete secsel
4510 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4511 -tags secsel -fill [$canv cget -selectbackground]]
4512 $canv lower $t
4513 $canv2 delete secsel
4514 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4515 -tags secsel -fill [$canv2 cget -selectbackground]]
4516 $canv2 lower $t
4517 $canv3 delete secsel
4518 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4519 -tags secsel -fill [$canv3 cget -selectbackground]]
4520 $canv3 lower $t
4522 if {$isnew} {
4523 addtohistory [list selectline $l 0]
4526 set selectedline $l
4528 set id [lindex $displayorder $l]
4529 set currentid $id
4530 $sha1entry delete 0 end
4531 $sha1entry insert 0 $id
4532 $sha1entry selection from 0
4533 $sha1entry selection to end
4534 rhighlight_sel $id
4536 $ctext conf -state normal
4537 clear_ctext
4538 set linknum 0
4539 set info $commitinfo($id)
4540 set date [formatdate [lindex $info 2]]
4541 $ctext insert end "Author: [lindex $info 1] $date\n"
4542 set date [formatdate [lindex $info 4]]
4543 $ctext insert end "Committer: [lindex $info 3] $date\n"
4544 if {[info exists idtags($id)]} {
4545 $ctext insert end "Tags:"
4546 foreach tag $idtags($id) {
4547 $ctext insert end " $tag"
4549 $ctext insert end "\n"
4552 set headers {}
4553 set olds [lindex $parentlist $l]
4554 if {[llength $olds] > 1} {
4555 set np 0
4556 foreach p $olds {
4557 if {$np >= $mergemax} {
4558 set tag mmax
4559 } else {
4560 set tag m$np
4562 $ctext insert end "Parent: " $tag
4563 appendwithlinks [commit_descriptor $p] {}
4564 incr np
4566 } else {
4567 foreach p $olds {
4568 append headers "Parent: [commit_descriptor $p]"
4572 foreach c $children($curview,$id) {
4573 append headers "Child: [commit_descriptor $c]"
4576 # make anything that looks like a SHA1 ID be a clickable link
4577 appendwithlinks $headers {}
4578 if {$showneartags} {
4579 if {![info exists allcommits]} {
4580 getallcommits
4582 $ctext insert end "Branch: "
4583 $ctext mark set branch "end -1c"
4584 $ctext mark gravity branch left
4585 $ctext insert end "\nFollows: "
4586 $ctext mark set follows "end -1c"
4587 $ctext mark gravity follows left
4588 $ctext insert end "\nPrecedes: "
4589 $ctext mark set precedes "end -1c"
4590 $ctext mark gravity precedes left
4591 $ctext insert end "\n"
4592 dispneartags 1
4594 $ctext insert end "\n"
4595 set comment [lindex $info 5]
4596 if {[string first "\r" $comment] >= 0} {
4597 set comment [string map {"\r" "\n "} $comment]
4599 appendwithlinks $comment {comment}
4601 $ctext tag remove found 1.0 end
4602 $ctext conf -state disabled
4603 set commentend [$ctext index "end - 1c"]
4605 init_flist "Comments"
4606 if {$cmitmode eq "tree"} {
4607 gettree $id
4608 } elseif {[llength $olds] <= 1} {
4609 startdiff $id
4610 } else {
4611 mergediff $id $l
4615 proc selfirstline {} {
4616 unmarkmatches
4617 selectline 0 1
4620 proc sellastline {} {
4621 global numcommits
4622 unmarkmatches
4623 set l [expr {$numcommits - 1}]
4624 selectline $l 1
4627 proc selnextline {dir} {
4628 global selectedline
4629 focus .
4630 if {![info exists selectedline]} return
4631 set l [expr {$selectedline + $dir}]
4632 unmarkmatches
4633 selectline $l 1
4636 proc selnextpage {dir} {
4637 global canv linespc selectedline numcommits
4639 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4640 if {$lpp < 1} {
4641 set lpp 1
4643 allcanvs yview scroll [expr {$dir * $lpp}] units
4644 drawvisible
4645 if {![info exists selectedline]} return
4646 set l [expr {$selectedline + $dir * $lpp}]
4647 if {$l < 0} {
4648 set l 0
4649 } elseif {$l >= $numcommits} {
4650 set l [expr $numcommits - 1]
4652 unmarkmatches
4653 selectline $l 1
4656 proc unselectline {} {
4657 global selectedline currentid
4659 catch {unset selectedline}
4660 catch {unset currentid}
4661 allcanvs delete secsel
4662 rhighlight_none
4663 cancel_next_highlight
4666 proc reselectline {} {
4667 global selectedline
4669 if {[info exists selectedline]} {
4670 selectline $selectedline 0
4674 proc addtohistory {cmd} {
4675 global history historyindex curview
4677 set elt [list $curview $cmd]
4678 if {$historyindex > 0
4679 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4680 return
4683 if {$historyindex < [llength $history]} {
4684 set history [lreplace $history $historyindex end $elt]
4685 } else {
4686 lappend history $elt
4688 incr historyindex
4689 if {$historyindex > 1} {
4690 .tf.bar.leftbut conf -state normal
4691 } else {
4692 .tf.bar.leftbut conf -state disabled
4694 .tf.bar.rightbut conf -state disabled
4697 proc godo {elt} {
4698 global curview
4700 set view [lindex $elt 0]
4701 set cmd [lindex $elt 1]
4702 if {$curview != $view} {
4703 showview $view
4705 eval $cmd
4708 proc goback {} {
4709 global history historyindex
4710 focus .
4712 if {$historyindex > 1} {
4713 incr historyindex -1
4714 godo [lindex $history [expr {$historyindex - 1}]]
4715 .tf.bar.rightbut conf -state normal
4717 if {$historyindex <= 1} {
4718 .tf.bar.leftbut conf -state disabled
4722 proc goforw {} {
4723 global history historyindex
4724 focus .
4726 if {$historyindex < [llength $history]} {
4727 set cmd [lindex $history $historyindex]
4728 incr historyindex
4729 godo $cmd
4730 .tf.bar.leftbut conf -state normal
4732 if {$historyindex >= [llength $history]} {
4733 .tf.bar.rightbut conf -state disabled
4737 proc gettree {id} {
4738 global treefilelist treeidlist diffids diffmergeid treepending
4739 global nullid nullid2
4741 set diffids $id
4742 catch {unset diffmergeid}
4743 if {![info exists treefilelist($id)]} {
4744 if {![info exists treepending]} {
4745 if {$id eq $nullid} {
4746 set cmd [list | git ls-files]
4747 } elseif {$id eq $nullid2} {
4748 set cmd [list | git ls-files --stage -t]
4749 } else {
4750 set cmd [list | git ls-tree -r $id]
4752 if {[catch {set gtf [open $cmd r]}]} {
4753 return
4755 set treepending $id
4756 set treefilelist($id) {}
4757 set treeidlist($id) {}
4758 fconfigure $gtf -blocking 0
4759 filerun $gtf [list gettreeline $gtf $id]
4761 } else {
4762 setfilelist $id
4766 proc gettreeline {gtf id} {
4767 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4769 set nl 0
4770 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4771 if {$diffids eq $nullid} {
4772 set fname $line
4773 } else {
4774 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4775 set i [string first "\t" $line]
4776 if {$i < 0} continue
4777 set sha1 [lindex $line 2]
4778 set fname [string range $line [expr {$i+1}] end]
4779 if {[string index $fname 0] eq "\""} {
4780 set fname [lindex $fname 0]
4782 lappend treeidlist($id) $sha1
4784 lappend treefilelist($id) $fname
4786 if {![eof $gtf]} {
4787 return [expr {$nl >= 1000? 2: 1}]
4789 close $gtf
4790 unset treepending
4791 if {$cmitmode ne "tree"} {
4792 if {![info exists diffmergeid]} {
4793 gettreediffs $diffids
4795 } elseif {$id ne $diffids} {
4796 gettree $diffids
4797 } else {
4798 setfilelist $id
4800 return 0
4803 proc showfile {f} {
4804 global treefilelist treeidlist diffids nullid nullid2
4805 global ctext commentend
4807 set i [lsearch -exact $treefilelist($diffids) $f]
4808 if {$i < 0} {
4809 puts "oops, $f not in list for id $diffids"
4810 return
4812 if {$diffids eq $nullid} {
4813 if {[catch {set bf [open $f r]} err]} {
4814 puts "oops, can't read $f: $err"
4815 return
4817 } else {
4818 set blob [lindex $treeidlist($diffids) $i]
4819 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4820 puts "oops, error reading blob $blob: $err"
4821 return
4824 fconfigure $bf -blocking 0
4825 filerun $bf [list getblobline $bf $diffids]
4826 $ctext config -state normal
4827 clear_ctext $commentend
4828 $ctext insert end "\n"
4829 $ctext insert end "$f\n" filesep
4830 $ctext config -state disabled
4831 $ctext yview $commentend
4834 proc getblobline {bf id} {
4835 global diffids cmitmode ctext
4837 if {$id ne $diffids || $cmitmode ne "tree"} {
4838 catch {close $bf}
4839 return 0
4841 $ctext config -state normal
4842 set nl 0
4843 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4844 $ctext insert end "$line\n"
4846 if {[eof $bf]} {
4847 # delete last newline
4848 $ctext delete "end - 2c" "end - 1c"
4849 close $bf
4850 return 0
4852 $ctext config -state disabled
4853 return [expr {$nl >= 1000? 2: 1}]
4856 proc mergediff {id l} {
4857 global diffmergeid diffopts mdifffd
4858 global diffids
4859 global parentlist
4861 set diffmergeid $id
4862 set diffids $id
4863 # this doesn't seem to actually affect anything...
4864 set env(GIT_DIFF_OPTS) $diffopts
4865 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4866 if {[catch {set mdf [open $cmd r]} err]} {
4867 error_popup "Error getting merge diffs: $err"
4868 return
4870 fconfigure $mdf -blocking 0
4871 set mdifffd($id) $mdf
4872 set np [llength [lindex $parentlist $l]]
4873 filerun $mdf [list getmergediffline $mdf $id $np]
4876 proc getmergediffline {mdf id np} {
4877 global diffmergeid ctext cflist mergemax
4878 global difffilestart mdifffd
4880 $ctext conf -state normal
4881 set nr 0
4882 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4883 if {![info exists diffmergeid] || $id != $diffmergeid
4884 || $mdf != $mdifffd($id)} {
4885 close $mdf
4886 return 0
4888 if {[regexp {^diff --cc (.*)} $line match fname]} {
4889 # start of a new file
4890 $ctext insert end "\n"
4891 set here [$ctext index "end - 1c"]
4892 lappend difffilestart $here
4893 add_flist [list $fname]
4894 set l [expr {(78 - [string length $fname]) / 2}]
4895 set pad [string range "----------------------------------------" 1 $l]
4896 $ctext insert end "$pad $fname $pad\n" filesep
4897 } elseif {[regexp {^@@} $line]} {
4898 $ctext insert end "$line\n" hunksep
4899 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4900 # do nothing
4901 } else {
4902 # parse the prefix - one ' ', '-' or '+' for each parent
4903 set spaces {}
4904 set minuses {}
4905 set pluses {}
4906 set isbad 0
4907 for {set j 0} {$j < $np} {incr j} {
4908 set c [string range $line $j $j]
4909 if {$c == " "} {
4910 lappend spaces $j
4911 } elseif {$c == "-"} {
4912 lappend minuses $j
4913 } elseif {$c == "+"} {
4914 lappend pluses $j
4915 } else {
4916 set isbad 1
4917 break
4920 set tags {}
4921 set num {}
4922 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4923 # line doesn't appear in result, parents in $minuses have the line
4924 set num [lindex $minuses 0]
4925 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4926 # line appears in result, parents in $pluses don't have the line
4927 lappend tags mresult
4928 set num [lindex $spaces 0]
4930 if {$num ne {}} {
4931 if {$num >= $mergemax} {
4932 set num "max"
4934 lappend tags m$num
4936 $ctext insert end "$line\n" $tags
4939 $ctext conf -state disabled
4940 if {[eof $mdf]} {
4941 close $mdf
4942 return 0
4944 return [expr {$nr >= 1000? 2: 1}]
4947 proc startdiff {ids} {
4948 global treediffs diffids treepending diffmergeid nullid nullid2
4950 set diffids $ids
4951 catch {unset diffmergeid}
4952 if {![info exists treediffs($ids)] ||
4953 [lsearch -exact $ids $nullid] >= 0 ||
4954 [lsearch -exact $ids $nullid2] >= 0} {
4955 if {![info exists treepending]} {
4956 gettreediffs $ids
4958 } else {
4959 addtocflist $ids
4963 proc addtocflist {ids} {
4964 global treediffs cflist
4965 add_flist $treediffs($ids)
4966 getblobdiffs $ids
4969 proc diffcmd {ids flags} {
4970 global nullid nullid2
4972 set i [lsearch -exact $ids $nullid]
4973 set j [lsearch -exact $ids $nullid2]
4974 if {$i >= 0} {
4975 if {[llength $ids] > 1 && $j < 0} {
4976 # comparing working directory with some specific revision
4977 set cmd [concat | git diff-index $flags]
4978 if {$i == 0} {
4979 lappend cmd -R [lindex $ids 1]
4980 } else {
4981 lappend cmd [lindex $ids 0]
4983 } else {
4984 # comparing working directory with index
4985 set cmd [concat | git diff-files $flags]
4986 if {$j == 1} {
4987 lappend cmd -R
4990 } elseif {$j >= 0} {
4991 set cmd [concat | git diff-index --cached $flags]
4992 if {[llength $ids] > 1} {
4993 # comparing index with specific revision
4994 if {$i == 0} {
4995 lappend cmd -R [lindex $ids 1]
4996 } else {
4997 lappend cmd [lindex $ids 0]
4999 } else {
5000 # comparing index with HEAD
5001 lappend cmd HEAD
5003 } else {
5004 set cmd [concat | git diff-tree -r $flags $ids]
5006 return $cmd
5009 proc gettreediffs {ids} {
5010 global treediff treepending
5012 set treepending $ids
5013 set treediff {}
5014 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5015 fconfigure $gdtf -blocking 0
5016 filerun $gdtf [list gettreediffline $gdtf $ids]
5019 proc gettreediffline {gdtf ids} {
5020 global treediff treediffs treepending diffids diffmergeid
5021 global cmitmode
5023 set nr 0
5024 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5025 set i [string first "\t" $line]
5026 if {$i >= 0} {
5027 set file [string range $line [expr {$i+1}] end]
5028 if {[string index $file 0] eq "\""} {
5029 set file [lindex $file 0]
5031 lappend treediff $file
5034 if {![eof $gdtf]} {
5035 return [expr {$nr >= 1000? 2: 1}]
5037 close $gdtf
5038 set treediffs($ids) $treediff
5039 unset treepending
5040 if {$cmitmode eq "tree"} {
5041 gettree $diffids
5042 } elseif {$ids != $diffids} {
5043 if {![info exists diffmergeid]} {
5044 gettreediffs $diffids
5046 } else {
5047 addtocflist $ids
5049 return 0
5052 # empty string or positive integer
5053 proc diffcontextvalidate {v} {
5054 return [regexp {^(|[1-9][0-9]*)$} $v]
5057 proc diffcontextchange {n1 n2 op} {
5058 global diffcontextstring diffcontext
5060 if {[string is integer -strict $diffcontextstring]} {
5061 if {$diffcontextstring > 0} {
5062 set diffcontext $diffcontextstring
5063 reselectline
5068 proc getblobdiffs {ids} {
5069 global diffopts blobdifffd diffids env
5070 global diffinhdr treediffs
5071 global diffcontext
5073 set env(GIT_DIFF_OPTS) $diffopts
5074 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5075 puts "error getting diffs: $err"
5076 return
5078 set diffinhdr 0
5079 fconfigure $bdf -blocking 0
5080 set blobdifffd($ids) $bdf
5081 filerun $bdf [list getblobdiffline $bdf $diffids]
5084 proc setinlist {var i val} {
5085 global $var
5087 while {[llength [set $var]] < $i} {
5088 lappend $var {}
5090 if {[llength [set $var]] == $i} {
5091 lappend $var $val
5092 } else {
5093 lset $var $i $val
5097 proc makediffhdr {fname ids} {
5098 global ctext curdiffstart treediffs
5100 set i [lsearch -exact $treediffs($ids) $fname]
5101 if {$i >= 0} {
5102 setinlist difffilestart $i $curdiffstart
5104 set l [expr {(78 - [string length $fname]) / 2}]
5105 set pad [string range "----------------------------------------" 1 $l]
5106 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5109 proc getblobdiffline {bdf ids} {
5110 global diffids blobdifffd ctext curdiffstart
5111 global diffnexthead diffnextnote difffilestart
5112 global diffinhdr treediffs
5114 set nr 0
5115 $ctext conf -state normal
5116 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5117 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5118 close $bdf
5119 return 0
5121 if {![string compare -length 11 "diff --git " $line]} {
5122 # trim off "diff --git "
5123 set line [string range $line 11 end]
5124 set diffinhdr 1
5125 # start of a new file
5126 $ctext insert end "\n"
5127 set curdiffstart [$ctext index "end - 1c"]
5128 $ctext insert end "\n" filesep
5129 # If the name hasn't changed the length will be odd,
5130 # the middle char will be a space, and the two bits either
5131 # side will be a/name and b/name, or "a/name" and "b/name".
5132 # If the name has changed we'll get "rename from" and
5133 # "rename to" or "copy from" and "copy to" lines following this,
5134 # and we'll use them to get the filenames.
5135 # This complexity is necessary because spaces in the filename(s)
5136 # don't get escaped.
5137 set l [string length $line]
5138 set i [expr {$l / 2}]
5139 if {!(($l & 1) && [string index $line $i] eq " " &&
5140 [string range $line 2 [expr {$i - 1}]] eq \
5141 [string range $line [expr {$i + 3}] end])} {
5142 continue
5144 # unescape if quoted and chop off the a/ from the front
5145 if {[string index $line 0] eq "\""} {
5146 set fname [string range [lindex $line 0] 2 end]
5147 } else {
5148 set fname [string range $line 2 [expr {$i - 1}]]
5150 makediffhdr $fname $ids
5152 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5153 $line match f1l f1c f2l f2c rest]} {
5154 $ctext insert end "$line\n" hunksep
5155 set diffinhdr 0
5157 } elseif {$diffinhdr} {
5158 if {![string compare -length 12 "rename from " $line] ||
5159 ![string compare -length 10 "copy from " $line]} {
5160 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5161 if {[string index $fname 0] eq "\""} {
5162 set fname [lindex $fname 0]
5164 set i [lsearch -exact $treediffs($ids) $fname]
5165 if {$i >= 0} {
5166 setinlist difffilestart $i $curdiffstart
5168 } elseif {![string compare -length 10 $line "rename to "] ||
5169 ![string compare -length 8 $line "copy to "]} {
5170 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5171 if {[string index $fname 0] eq "\""} {
5172 set fname [lindex $fname 0]
5174 makediffhdr $fname $ids
5175 } elseif {[string compare -length 3 $line "---"] == 0} {
5176 # do nothing
5177 continue
5178 } elseif {[string compare -length 3 $line "+++"] == 0} {
5179 set diffinhdr 0
5180 continue
5182 $ctext insert end "$line\n" filesep
5184 } else {
5185 set x [string range $line 0 0]
5186 if {$x == "-" || $x == "+"} {
5187 set tag [expr {$x == "+"}]
5188 $ctext insert end "$line\n" d$tag
5189 } elseif {$x == " "} {
5190 $ctext insert end "$line\n"
5191 } else {
5192 # "\ No newline at end of file",
5193 # or something else we don't recognize
5194 $ctext insert end "$line\n" hunksep
5198 $ctext conf -state disabled
5199 if {[eof $bdf]} {
5200 close $bdf
5201 return 0
5203 return [expr {$nr >= 1000? 2: 1}]
5206 proc changediffdisp {} {
5207 global ctext diffelide
5209 $ctext tag conf d0 -elide [lindex $diffelide 0]
5210 $ctext tag conf d1 -elide [lindex $diffelide 1]
5213 proc prevfile {} {
5214 global difffilestart ctext
5215 set prev [lindex $difffilestart 0]
5216 set here [$ctext index @0,0]
5217 foreach loc $difffilestart {
5218 if {[$ctext compare $loc >= $here]} {
5219 $ctext yview $prev
5220 return
5222 set prev $loc
5224 $ctext yview $prev
5227 proc nextfile {} {
5228 global difffilestart ctext
5229 set here [$ctext index @0,0]
5230 foreach loc $difffilestart {
5231 if {[$ctext compare $loc > $here]} {
5232 $ctext yview $loc
5233 return
5238 proc clear_ctext {{first 1.0}} {
5239 global ctext smarktop smarkbot
5241 set l [lindex [split $first .] 0]
5242 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5243 set smarktop $l
5245 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5246 set smarkbot $l
5248 $ctext delete $first end
5251 proc incrsearch {name ix op} {
5252 global ctext searchstring searchdirn
5254 $ctext tag remove found 1.0 end
5255 if {[catch {$ctext index anchor}]} {
5256 # no anchor set, use start of selection, or of visible area
5257 set sel [$ctext tag ranges sel]
5258 if {$sel ne {}} {
5259 $ctext mark set anchor [lindex $sel 0]
5260 } elseif {$searchdirn eq "-forwards"} {
5261 $ctext mark set anchor @0,0
5262 } else {
5263 $ctext mark set anchor @0,[winfo height $ctext]
5266 if {$searchstring ne {}} {
5267 set here [$ctext search $searchdirn -- $searchstring anchor]
5268 if {$here ne {}} {
5269 $ctext see $here
5271 searchmarkvisible 1
5275 proc dosearch {} {
5276 global sstring ctext searchstring searchdirn
5278 focus $sstring
5279 $sstring icursor end
5280 set searchdirn -forwards
5281 if {$searchstring ne {}} {
5282 set sel [$ctext tag ranges sel]
5283 if {$sel ne {}} {
5284 set start "[lindex $sel 0] + 1c"
5285 } elseif {[catch {set start [$ctext index anchor]}]} {
5286 set start "@0,0"
5288 set match [$ctext search -count mlen -- $searchstring $start]
5289 $ctext tag remove sel 1.0 end
5290 if {$match eq {}} {
5291 bell
5292 return
5294 $ctext see $match
5295 set mend "$match + $mlen c"
5296 $ctext tag add sel $match $mend
5297 $ctext mark unset anchor
5301 proc dosearchback {} {
5302 global sstring ctext searchstring searchdirn
5304 focus $sstring
5305 $sstring icursor end
5306 set searchdirn -backwards
5307 if {$searchstring ne {}} {
5308 set sel [$ctext tag ranges sel]
5309 if {$sel ne {}} {
5310 set start [lindex $sel 0]
5311 } elseif {[catch {set start [$ctext index anchor]}]} {
5312 set start @0,[winfo height $ctext]
5314 set match [$ctext search -backwards -count ml -- $searchstring $start]
5315 $ctext tag remove sel 1.0 end
5316 if {$match eq {}} {
5317 bell
5318 return
5320 $ctext see $match
5321 set mend "$match + $ml c"
5322 $ctext tag add sel $match $mend
5323 $ctext mark unset anchor
5327 proc searchmark {first last} {
5328 global ctext searchstring
5330 set mend $first.0
5331 while {1} {
5332 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5333 if {$match eq {}} break
5334 set mend "$match + $mlen c"
5335 $ctext tag add found $match $mend
5339 proc searchmarkvisible {doall} {
5340 global ctext smarktop smarkbot
5342 set topline [lindex [split [$ctext index @0,0] .] 0]
5343 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5344 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5345 # no overlap with previous
5346 searchmark $topline $botline
5347 set smarktop $topline
5348 set smarkbot $botline
5349 } else {
5350 if {$topline < $smarktop} {
5351 searchmark $topline [expr {$smarktop-1}]
5352 set smarktop $topline
5354 if {$botline > $smarkbot} {
5355 searchmark [expr {$smarkbot+1}] $botline
5356 set smarkbot $botline
5361 proc scrolltext {f0 f1} {
5362 global searchstring
5364 .bleft.sb set $f0 $f1
5365 if {$searchstring ne {}} {
5366 searchmarkvisible 0
5370 proc setcoords {} {
5371 global linespc charspc canvx0 canvy0 mainfont
5372 global xspc1 xspc2 lthickness
5374 set linespc [font metrics $mainfont -linespace]
5375 set charspc [font measure $mainfont "m"]
5376 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5377 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5378 set lthickness [expr {int($linespc / 9) + 1}]
5379 set xspc1(0) $linespc
5380 set xspc2 $linespc
5383 proc redisplay {} {
5384 global canv
5385 global selectedline
5387 set ymax [lindex [$canv cget -scrollregion] 3]
5388 if {$ymax eq {} || $ymax == 0} return
5389 set span [$canv yview]
5390 clear_display
5391 setcanvscroll
5392 allcanvs yview moveto [lindex $span 0]
5393 drawvisible
5394 if {[info exists selectedline]} {
5395 selectline $selectedline 0
5396 allcanvs yview moveto [lindex $span 0]
5400 proc incrfont {inc} {
5401 global mainfont textfont ctext canv phase cflist showrefstop
5402 global charspc tabstop
5403 global stopped entries
5404 unmarkmatches
5405 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5406 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5407 setcoords
5408 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5409 $cflist conf -font $textfont
5410 $ctext tag conf filesep -font [concat $textfont bold]
5411 foreach e $entries {
5412 $e conf -font $mainfont
5414 if {$phase eq "getcommits"} {
5415 $canv itemconf textitems -font $mainfont
5417 if {[info exists showrefstop] && [winfo exists $showrefstop]} {
5418 $showrefstop.list conf -font $mainfont
5420 redisplay
5423 proc clearsha1 {} {
5424 global sha1entry sha1string
5425 if {[string length $sha1string] == 40} {
5426 $sha1entry delete 0 end
5430 proc sha1change {n1 n2 op} {
5431 global sha1string currentid sha1but
5432 if {$sha1string == {}
5433 || ([info exists currentid] && $sha1string == $currentid)} {
5434 set state disabled
5435 } else {
5436 set state normal
5438 if {[$sha1but cget -state] == $state} return
5439 if {$state == "normal"} {
5440 $sha1but conf -state normal -relief raised -text "Goto: "
5441 } else {
5442 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5446 proc gotocommit {} {
5447 global sha1string currentid commitrow tagids headids
5448 global displayorder numcommits curview
5450 if {$sha1string == {}
5451 || ([info exists currentid] && $sha1string == $currentid)} return
5452 if {[info exists tagids($sha1string)]} {
5453 set id $tagids($sha1string)
5454 } elseif {[info exists headids($sha1string)]} {
5455 set id $headids($sha1string)
5456 } else {
5457 set id [string tolower $sha1string]
5458 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5459 set matches {}
5460 foreach i $displayorder {
5461 if {[string match $id* $i]} {
5462 lappend matches $i
5465 if {$matches ne {}} {
5466 if {[llength $matches] > 1} {
5467 error_popup "Short SHA1 id $id is ambiguous"
5468 return
5470 set id [lindex $matches 0]
5474 if {[info exists commitrow($curview,$id)]} {
5475 selectline $commitrow($curview,$id) 1
5476 return
5478 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5479 set type "SHA1 id"
5480 } else {
5481 set type "Tag/Head"
5483 error_popup "$type $sha1string is not known"
5486 proc lineenter {x y id} {
5487 global hoverx hovery hoverid hovertimer
5488 global commitinfo canv
5490 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5491 set hoverx $x
5492 set hovery $y
5493 set hoverid $id
5494 if {[info exists hovertimer]} {
5495 after cancel $hovertimer
5497 set hovertimer [after 500 linehover]
5498 $canv delete hover
5501 proc linemotion {x y id} {
5502 global hoverx hovery hoverid hovertimer
5504 if {[info exists hoverid] && $id == $hoverid} {
5505 set hoverx $x
5506 set hovery $y
5507 if {[info exists hovertimer]} {
5508 after cancel $hovertimer
5510 set hovertimer [after 500 linehover]
5514 proc lineleave {id} {
5515 global hoverid hovertimer canv
5517 if {[info exists hoverid] && $id == $hoverid} {
5518 $canv delete hover
5519 if {[info exists hovertimer]} {
5520 after cancel $hovertimer
5521 unset hovertimer
5523 unset hoverid
5527 proc linehover {} {
5528 global hoverx hovery hoverid hovertimer
5529 global canv linespc lthickness
5530 global commitinfo mainfont
5532 set text [lindex $commitinfo($hoverid) 0]
5533 set ymax [lindex [$canv cget -scrollregion] 3]
5534 if {$ymax == {}} return
5535 set yfrac [lindex [$canv yview] 0]
5536 set x [expr {$hoverx + 2 * $linespc}]
5537 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5538 set x0 [expr {$x - 2 * $lthickness}]
5539 set y0 [expr {$y - 2 * $lthickness}]
5540 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5541 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5542 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5543 -fill \#ffff80 -outline black -width 1 -tags hover]
5544 $canv raise $t
5545 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5546 -font $mainfont]
5547 $canv raise $t
5550 proc clickisonarrow {id y} {
5551 global lthickness
5553 set ranges [rowranges $id]
5554 set thresh [expr {2 * $lthickness + 6}]
5555 set n [expr {[llength $ranges] - 1}]
5556 for {set i 1} {$i < $n} {incr i} {
5557 set row [lindex $ranges $i]
5558 if {abs([yc $row] - $y) < $thresh} {
5559 return $i
5562 return {}
5565 proc arrowjump {id n y} {
5566 global canv
5568 # 1 <-> 2, 3 <-> 4, etc...
5569 set n [expr {(($n - 1) ^ 1) + 1}]
5570 set row [lindex [rowranges $id] $n]
5571 set yt [yc $row]
5572 set ymax [lindex [$canv cget -scrollregion] 3]
5573 if {$ymax eq {} || $ymax <= 0} return
5574 set view [$canv yview]
5575 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5576 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5577 if {$yfrac < 0} {
5578 set yfrac 0
5580 allcanvs yview moveto $yfrac
5583 proc lineclick {x y id isnew} {
5584 global ctext commitinfo children canv thickerline curview
5586 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5587 unmarkmatches
5588 unselectline
5589 normalline
5590 $canv delete hover
5591 # draw this line thicker than normal
5592 set thickerline $id
5593 drawlines $id
5594 if {$isnew} {
5595 set ymax [lindex [$canv cget -scrollregion] 3]
5596 if {$ymax eq {}} return
5597 set yfrac [lindex [$canv yview] 0]
5598 set y [expr {$y + $yfrac * $ymax}]
5600 set dirn [clickisonarrow $id $y]
5601 if {$dirn ne {}} {
5602 arrowjump $id $dirn $y
5603 return
5606 if {$isnew} {
5607 addtohistory [list lineclick $x $y $id 0]
5609 # fill the details pane with info about this line
5610 $ctext conf -state normal
5611 clear_ctext
5612 $ctext tag conf link -foreground blue -underline 1
5613 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5614 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5615 $ctext insert end "Parent:\t"
5616 $ctext insert end $id [list link link0]
5617 $ctext tag bind link0 <1> [list selbyid $id]
5618 set info $commitinfo($id)
5619 $ctext insert end "\n\t[lindex $info 0]\n"
5620 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5621 set date [formatdate [lindex $info 2]]
5622 $ctext insert end "\tDate:\t$date\n"
5623 set kids $children($curview,$id)
5624 if {$kids ne {}} {
5625 $ctext insert end "\nChildren:"
5626 set i 0
5627 foreach child $kids {
5628 incr i
5629 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5630 set info $commitinfo($child)
5631 $ctext insert end "\n\t"
5632 $ctext insert end $child [list link link$i]
5633 $ctext tag bind link$i <1> [list selbyid $child]
5634 $ctext insert end "\n\t[lindex $info 0]"
5635 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5636 set date [formatdate [lindex $info 2]]
5637 $ctext insert end "\n\tDate:\t$date\n"
5640 $ctext conf -state disabled
5641 init_flist {}
5644 proc normalline {} {
5645 global thickerline
5646 if {[info exists thickerline]} {
5647 set id $thickerline
5648 unset thickerline
5649 drawlines $id
5653 proc selbyid {id} {
5654 global commitrow curview
5655 if {[info exists commitrow($curview,$id)]} {
5656 selectline $commitrow($curview,$id) 1
5660 proc mstime {} {
5661 global startmstime
5662 if {![info exists startmstime]} {
5663 set startmstime [clock clicks -milliseconds]
5665 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5668 proc rowmenu {x y id} {
5669 global rowctxmenu commitrow selectedline rowmenuid curview
5670 global nullid nullid2 fakerowmenu mainhead
5672 set rowmenuid $id
5673 if {![info exists selectedline]
5674 || $commitrow($curview,$id) eq $selectedline} {
5675 set state disabled
5676 } else {
5677 set state normal
5679 if {$id ne $nullid && $id ne $nullid2} {
5680 set menu $rowctxmenu
5681 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5682 } else {
5683 set menu $fakerowmenu
5685 $menu entryconfigure "Diff this*" -state $state
5686 $menu entryconfigure "Diff selected*" -state $state
5687 $menu entryconfigure "Make patch" -state $state
5688 tk_popup $menu $x $y
5691 proc diffvssel {dirn} {
5692 global rowmenuid selectedline displayorder
5694 if {![info exists selectedline]} return
5695 if {$dirn} {
5696 set oldid [lindex $displayorder $selectedline]
5697 set newid $rowmenuid
5698 } else {
5699 set oldid $rowmenuid
5700 set newid [lindex $displayorder $selectedline]
5702 addtohistory [list doseldiff $oldid $newid]
5703 doseldiff $oldid $newid
5706 proc doseldiff {oldid newid} {
5707 global ctext
5708 global commitinfo
5710 $ctext conf -state normal
5711 clear_ctext
5712 init_flist "Top"
5713 $ctext insert end "From "
5714 $ctext tag conf link -foreground blue -underline 1
5715 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5716 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5717 $ctext tag bind link0 <1> [list selbyid $oldid]
5718 $ctext insert end $oldid [list link link0]
5719 $ctext insert end "\n "
5720 $ctext insert end [lindex $commitinfo($oldid) 0]
5721 $ctext insert end "\n\nTo "
5722 $ctext tag bind link1 <1> [list selbyid $newid]
5723 $ctext insert end $newid [list link link1]
5724 $ctext insert end "\n "
5725 $ctext insert end [lindex $commitinfo($newid) 0]
5726 $ctext insert end "\n"
5727 $ctext conf -state disabled
5728 $ctext tag remove found 1.0 end
5729 startdiff [list $oldid $newid]
5732 proc mkpatch {} {
5733 global rowmenuid currentid commitinfo patchtop patchnum
5735 if {![info exists currentid]} return
5736 set oldid $currentid
5737 set oldhead [lindex $commitinfo($oldid) 0]
5738 set newid $rowmenuid
5739 set newhead [lindex $commitinfo($newid) 0]
5740 set top .patch
5741 set patchtop $top
5742 catch {destroy $top}
5743 toplevel $top
5744 label $top.title -text "Generate patch"
5745 grid $top.title - -pady 10
5746 label $top.from -text "From:"
5747 entry $top.fromsha1 -width 40 -relief flat
5748 $top.fromsha1 insert 0 $oldid
5749 $top.fromsha1 conf -state readonly
5750 grid $top.from $top.fromsha1 -sticky w
5751 entry $top.fromhead -width 60 -relief flat
5752 $top.fromhead insert 0 $oldhead
5753 $top.fromhead conf -state readonly
5754 grid x $top.fromhead -sticky w
5755 label $top.to -text "To:"
5756 entry $top.tosha1 -width 40 -relief flat
5757 $top.tosha1 insert 0 $newid
5758 $top.tosha1 conf -state readonly
5759 grid $top.to $top.tosha1 -sticky w
5760 entry $top.tohead -width 60 -relief flat
5761 $top.tohead insert 0 $newhead
5762 $top.tohead conf -state readonly
5763 grid x $top.tohead -sticky w
5764 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5765 grid $top.rev x -pady 10
5766 label $top.flab -text "Output file:"
5767 entry $top.fname -width 60
5768 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5769 incr patchnum
5770 grid $top.flab $top.fname -sticky w
5771 frame $top.buts
5772 button $top.buts.gen -text "Generate" -command mkpatchgo
5773 button $top.buts.can -text "Cancel" -command mkpatchcan
5774 grid $top.buts.gen $top.buts.can
5775 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5776 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5777 grid $top.buts - -pady 10 -sticky ew
5778 focus $top.fname
5781 proc mkpatchrev {} {
5782 global patchtop
5784 set oldid [$patchtop.fromsha1 get]
5785 set oldhead [$patchtop.fromhead get]
5786 set newid [$patchtop.tosha1 get]
5787 set newhead [$patchtop.tohead get]
5788 foreach e [list fromsha1 fromhead tosha1 tohead] \
5789 v [list $newid $newhead $oldid $oldhead] {
5790 $patchtop.$e conf -state normal
5791 $patchtop.$e delete 0 end
5792 $patchtop.$e insert 0 $v
5793 $patchtop.$e conf -state readonly
5797 proc mkpatchgo {} {
5798 global patchtop nullid nullid2
5800 set oldid [$patchtop.fromsha1 get]
5801 set newid [$patchtop.tosha1 get]
5802 set fname [$patchtop.fname get]
5803 set cmd [diffcmd [list $oldid $newid] -p]
5804 lappend cmd >$fname &
5805 if {[catch {eval exec $cmd} err]} {
5806 error_popup "Error creating patch: $err"
5808 catch {destroy $patchtop}
5809 unset patchtop
5812 proc mkpatchcan {} {
5813 global patchtop
5815 catch {destroy $patchtop}
5816 unset patchtop
5819 proc mktag {} {
5820 global rowmenuid mktagtop commitinfo
5822 set top .maketag
5823 set mktagtop $top
5824 catch {destroy $top}
5825 toplevel $top
5826 label $top.title -text "Create tag"
5827 grid $top.title - -pady 10
5828 label $top.id -text "ID:"
5829 entry $top.sha1 -width 40 -relief flat
5830 $top.sha1 insert 0 $rowmenuid
5831 $top.sha1 conf -state readonly
5832 grid $top.id $top.sha1 -sticky w
5833 entry $top.head -width 60 -relief flat
5834 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5835 $top.head conf -state readonly
5836 grid x $top.head -sticky w
5837 label $top.tlab -text "Tag name:"
5838 entry $top.tag -width 60
5839 grid $top.tlab $top.tag -sticky w
5840 frame $top.buts
5841 button $top.buts.gen -text "Create" -command mktaggo
5842 button $top.buts.can -text "Cancel" -command mktagcan
5843 grid $top.buts.gen $top.buts.can
5844 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5845 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5846 grid $top.buts - -pady 10 -sticky ew
5847 focus $top.tag
5850 proc domktag {} {
5851 global mktagtop env tagids idtags
5853 set id [$mktagtop.sha1 get]
5854 set tag [$mktagtop.tag get]
5855 if {$tag == {}} {
5856 error_popup "No tag name specified"
5857 return
5859 if {[info exists tagids($tag)]} {
5860 error_popup "Tag \"$tag\" already exists"
5861 return
5863 if {[catch {
5864 set dir [gitdir]
5865 set fname [file join $dir "refs/tags" $tag]
5866 set f [open $fname w]
5867 puts $f $id
5868 close $f
5869 } err]} {
5870 error_popup "Error creating tag: $err"
5871 return
5874 set tagids($tag) $id
5875 lappend idtags($id) $tag
5876 redrawtags $id
5877 addedtag $id
5878 dispneartags 0
5879 run refill_reflist
5882 proc redrawtags {id} {
5883 global canv linehtag commitrow idpos selectedline curview
5884 global mainfont canvxmax iddrawn
5886 if {![info exists commitrow($curview,$id)]} return
5887 if {![info exists iddrawn($id)]} return
5888 drawcommits $commitrow($curview,$id)
5889 $canv delete tag.$id
5890 set xt [eval drawtags $id $idpos($id)]
5891 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5892 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5893 set xr [expr {$xt + [font measure $mainfont $text]}]
5894 if {$xr > $canvxmax} {
5895 set canvxmax $xr
5896 setcanvscroll
5898 if {[info exists selectedline]
5899 && $selectedline == $commitrow($curview,$id)} {
5900 selectline $selectedline 0
5904 proc mktagcan {} {
5905 global mktagtop
5907 catch {destroy $mktagtop}
5908 unset mktagtop
5911 proc mktaggo {} {
5912 domktag
5913 mktagcan
5916 proc writecommit {} {
5917 global rowmenuid wrcomtop commitinfo wrcomcmd
5919 set top .writecommit
5920 set wrcomtop $top
5921 catch {destroy $top}
5922 toplevel $top
5923 label $top.title -text "Write commit to file"
5924 grid $top.title - -pady 10
5925 label $top.id -text "ID:"
5926 entry $top.sha1 -width 40 -relief flat
5927 $top.sha1 insert 0 $rowmenuid
5928 $top.sha1 conf -state readonly
5929 grid $top.id $top.sha1 -sticky w
5930 entry $top.head -width 60 -relief flat
5931 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5932 $top.head conf -state readonly
5933 grid x $top.head -sticky w
5934 label $top.clab -text "Command:"
5935 entry $top.cmd -width 60 -textvariable wrcomcmd
5936 grid $top.clab $top.cmd -sticky w -pady 10
5937 label $top.flab -text "Output file:"
5938 entry $top.fname -width 60
5939 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5940 grid $top.flab $top.fname -sticky w
5941 frame $top.buts
5942 button $top.buts.gen -text "Write" -command wrcomgo
5943 button $top.buts.can -text "Cancel" -command wrcomcan
5944 grid $top.buts.gen $top.buts.can
5945 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5946 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5947 grid $top.buts - -pady 10 -sticky ew
5948 focus $top.fname
5951 proc wrcomgo {} {
5952 global wrcomtop
5954 set id [$wrcomtop.sha1 get]
5955 set cmd "echo $id | [$wrcomtop.cmd get]"
5956 set fname [$wrcomtop.fname get]
5957 if {[catch {exec sh -c $cmd >$fname &} err]} {
5958 error_popup "Error writing commit: $err"
5960 catch {destroy $wrcomtop}
5961 unset wrcomtop
5964 proc wrcomcan {} {
5965 global wrcomtop
5967 catch {destroy $wrcomtop}
5968 unset wrcomtop
5971 proc mkbranch {} {
5972 global rowmenuid mkbrtop
5974 set top .makebranch
5975 catch {destroy $top}
5976 toplevel $top
5977 label $top.title -text "Create new branch"
5978 grid $top.title - -pady 10
5979 label $top.id -text "ID:"
5980 entry $top.sha1 -width 40 -relief flat
5981 $top.sha1 insert 0 $rowmenuid
5982 $top.sha1 conf -state readonly
5983 grid $top.id $top.sha1 -sticky w
5984 label $top.nlab -text "Name:"
5985 entry $top.name -width 40
5986 grid $top.nlab $top.name -sticky w
5987 frame $top.buts
5988 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5989 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5990 grid $top.buts.go $top.buts.can
5991 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5992 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5993 grid $top.buts - -pady 10 -sticky ew
5994 focus $top.name
5997 proc mkbrgo {top} {
5998 global headids idheads
6000 set name [$top.name get]
6001 set id [$top.sha1 get]
6002 if {$name eq {}} {
6003 error_popup "Please specify a name for the new branch"
6004 return
6006 catch {destroy $top}
6007 nowbusy newbranch
6008 update
6009 if {[catch {
6010 exec git branch $name $id
6011 } err]} {
6012 notbusy newbranch
6013 error_popup $err
6014 } else {
6015 set headids($name) $id
6016 lappend idheads($id) $name
6017 addedhead $id $name
6018 notbusy newbranch
6019 redrawtags $id
6020 dispneartags 0
6021 run refill_reflist
6025 proc cherrypick {} {
6026 global rowmenuid curview commitrow
6027 global mainhead
6029 set oldhead [exec git rev-parse HEAD]
6030 set dheads [descheads $rowmenuid]
6031 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6032 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6033 included in branch $mainhead -- really re-apply it?"]
6034 if {!$ok} return
6036 nowbusy cherrypick
6037 update
6038 # Unfortunately git-cherry-pick writes stuff to stderr even when
6039 # no error occurs, and exec takes that as an indication of error...
6040 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6041 notbusy cherrypick
6042 error_popup $err
6043 return
6045 set newhead [exec git rev-parse HEAD]
6046 if {$newhead eq $oldhead} {
6047 notbusy cherrypick
6048 error_popup "No changes committed"
6049 return
6051 addnewchild $newhead $oldhead
6052 if {[info exists commitrow($curview,$oldhead)]} {
6053 insertrow $commitrow($curview,$oldhead) $newhead
6054 if {$mainhead ne {}} {
6055 movehead $newhead $mainhead
6056 movedhead $newhead $mainhead
6058 redrawtags $oldhead
6059 redrawtags $newhead
6061 notbusy cherrypick
6064 proc resethead {} {
6065 global mainheadid mainhead rowmenuid confirm_ok resettype
6066 global showlocalchanges
6068 set confirm_ok 0
6069 set w ".confirmreset"
6070 toplevel $w
6071 wm transient $w .
6072 wm title $w "Confirm reset"
6073 message $w.m -text \
6074 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6075 -justify center -aspect 1000
6076 pack $w.m -side top -fill x -padx 20 -pady 20
6077 frame $w.f -relief sunken -border 2
6078 message $w.f.rt -text "Reset type:" -aspect 1000
6079 grid $w.f.rt -sticky w
6080 set resettype mixed
6081 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6082 -text "Soft: Leave working tree and index untouched"
6083 grid $w.f.soft -sticky w
6084 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6085 -text "Mixed: Leave working tree untouched, reset index"
6086 grid $w.f.mixed -sticky w
6087 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6088 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6089 grid $w.f.hard -sticky w
6090 pack $w.f -side top -fill x
6091 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6092 pack $w.ok -side left -fill x -padx 20 -pady 20
6093 button $w.cancel -text Cancel -command "destroy $w"
6094 pack $w.cancel -side right -fill x -padx 20 -pady 20
6095 bind $w <Visibility> "grab $w; focus $w"
6096 tkwait window $w
6097 if {!$confirm_ok} return
6098 if {[catch {set fd [open \
6099 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6100 error_popup $err
6101 } else {
6102 dohidelocalchanges
6103 set w ".resetprogress"
6104 filerun $fd [list readresetstat $fd $w]
6105 toplevel $w
6106 wm transient $w
6107 wm title $w "Reset progress"
6108 message $w.m -text "Reset in progress, please wait..." \
6109 -justify center -aspect 1000
6110 pack $w.m -side top -fill x -padx 20 -pady 5
6111 canvas $w.c -width 150 -height 20 -bg white
6112 $w.c create rect 0 0 0 20 -fill green -tags rect
6113 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6114 nowbusy reset
6118 proc readresetstat {fd w} {
6119 global mainhead mainheadid showlocalchanges
6121 if {[gets $fd line] >= 0} {
6122 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6123 set x [expr {($m * 150) / $n}]
6124 $w.c coords rect 0 0 $x 20
6126 return 1
6128 destroy $w
6129 notbusy reset
6130 if {[catch {close $fd} err]} {
6131 error_popup $err
6133 set oldhead $mainheadid
6134 set newhead [exec git rev-parse HEAD]
6135 if {$newhead ne $oldhead} {
6136 movehead $newhead $mainhead
6137 movedhead $newhead $mainhead
6138 set mainheadid $newhead
6139 redrawtags $oldhead
6140 redrawtags $newhead
6142 if {$showlocalchanges} {
6143 doshowlocalchanges
6145 return 0
6148 # context menu for a head
6149 proc headmenu {x y id head} {
6150 global headmenuid headmenuhead headctxmenu mainhead
6152 set headmenuid $id
6153 set headmenuhead $head
6154 set state normal
6155 if {$head eq $mainhead} {
6156 set state disabled
6158 $headctxmenu entryconfigure 0 -state $state
6159 $headctxmenu entryconfigure 1 -state $state
6160 tk_popup $headctxmenu $x $y
6163 proc cobranch {} {
6164 global headmenuid headmenuhead mainhead headids
6165 global showlocalchanges mainheadid
6167 # check the tree is clean first??
6168 set oldmainhead $mainhead
6169 nowbusy checkout
6170 update
6171 dohidelocalchanges
6172 if {[catch {
6173 exec git checkout -q $headmenuhead
6174 } err]} {
6175 notbusy checkout
6176 error_popup $err
6177 } else {
6178 notbusy checkout
6179 set mainhead $headmenuhead
6180 set mainheadid $headmenuid
6181 if {[info exists headids($oldmainhead)]} {
6182 redrawtags $headids($oldmainhead)
6184 redrawtags $headmenuid
6186 if {$showlocalchanges} {
6187 dodiffindex
6191 proc rmbranch {} {
6192 global headmenuid headmenuhead mainhead
6193 global idheads
6195 set head $headmenuhead
6196 set id $headmenuid
6197 # this check shouldn't be needed any more...
6198 if {$head eq $mainhead} {
6199 error_popup "Cannot delete the currently checked-out branch"
6200 return
6202 set dheads [descheads $id]
6203 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6204 # the stuff on this branch isn't on any other branch
6205 if {![confirm_popup "The commits on branch $head aren't on any other\
6206 branch.\nReally delete branch $head?"]} return
6208 nowbusy rmbranch
6209 update
6210 if {[catch {exec git branch -D $head} err]} {
6211 notbusy rmbranch
6212 error_popup $err
6213 return
6215 removehead $id $head
6216 removedhead $id $head
6217 redrawtags $id
6218 notbusy rmbranch
6219 dispneartags 0
6220 run refill_reflist
6223 # Display a list of tags and heads
6224 proc showrefs {} {
6225 global showrefstop bgcolor fgcolor selectbgcolor mainfont
6226 global bglist fglist uifont reflistfilter reflist maincursor
6228 set top .showrefs
6229 set showrefstop $top
6230 if {[winfo exists $top]} {
6231 raise $top
6232 refill_reflist
6233 return
6235 toplevel $top
6236 wm title $top "Tags and heads: [file tail [pwd]]"
6237 text $top.list -background $bgcolor -foreground $fgcolor \
6238 -selectbackground $selectbgcolor -font $mainfont \
6239 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6240 -width 30 -height 20 -cursor $maincursor \
6241 -spacing1 1 -spacing3 1 -state disabled
6242 $top.list tag configure highlight -background $selectbgcolor
6243 lappend bglist $top.list
6244 lappend fglist $top.list
6245 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6246 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6247 grid $top.list $top.ysb -sticky nsew
6248 grid $top.xsb x -sticky ew
6249 frame $top.f
6250 label $top.f.l -text "Filter: " -font $uifont
6251 entry $top.f.e -width 20 -textvariable reflistfilter -font $uifont
6252 set reflistfilter "*"
6253 trace add variable reflistfilter write reflistfilter_change
6254 pack $top.f.e -side right -fill x -expand 1
6255 pack $top.f.l -side left
6256 grid $top.f - -sticky ew -pady 2
6257 button $top.close -command [list destroy $top] -text "Close" \
6258 -font $uifont
6259 grid $top.close -
6260 grid columnconfigure $top 0 -weight 1
6261 grid rowconfigure $top 0 -weight 1
6262 bind $top.list <1> {break}
6263 bind $top.list <B1-Motion> {break}
6264 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6265 set reflist {}
6266 refill_reflist
6269 proc sel_reflist {w x y} {
6270 global showrefstop reflist headids tagids otherrefids
6272 if {![winfo exists $showrefstop]} return
6273 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6274 set ref [lindex $reflist [expr {$l-1}]]
6275 set n [lindex $ref 0]
6276 switch -- [lindex $ref 1] {
6277 "H" {selbyid $headids($n)}
6278 "T" {selbyid $tagids($n)}
6279 "o" {selbyid $otherrefids($n)}
6281 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6284 proc unsel_reflist {} {
6285 global showrefstop
6287 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6288 $showrefstop.list tag remove highlight 0.0 end
6291 proc reflistfilter_change {n1 n2 op} {
6292 global reflistfilter
6294 after cancel refill_reflist
6295 after 200 refill_reflist
6298 proc refill_reflist {} {
6299 global reflist reflistfilter showrefstop headids tagids otherrefids
6300 global commitrow curview commitinterest
6302 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6303 set refs {}
6304 foreach n [array names headids] {
6305 if {[string match $reflistfilter $n]} {
6306 if {[info exists commitrow($curview,$headids($n))]} {
6307 lappend refs [list $n H]
6308 } else {
6309 set commitinterest($headids($n)) {run refill_reflist}
6313 foreach n [array names tagids] {
6314 if {[string match $reflistfilter $n]} {
6315 if {[info exists commitrow($curview,$tagids($n))]} {
6316 lappend refs [list $n T]
6317 } else {
6318 set commitinterest($tagids($n)) {run refill_reflist}
6322 foreach n [array names otherrefids] {
6323 if {[string match $reflistfilter $n]} {
6324 if {[info exists commitrow($curview,$otherrefids($n))]} {
6325 lappend refs [list $n o]
6326 } else {
6327 set commitinterest($otherrefids($n)) {run refill_reflist}
6331 set refs [lsort -index 0 $refs]
6332 if {$refs eq $reflist} return
6334 # Update the contents of $showrefstop.list according to the
6335 # differences between $reflist (old) and $refs (new)
6336 $showrefstop.list conf -state normal
6337 $showrefstop.list insert end "\n"
6338 set i 0
6339 set j 0
6340 while {$i < [llength $reflist] || $j < [llength $refs]} {
6341 if {$i < [llength $reflist]} {
6342 if {$j < [llength $refs]} {
6343 set cmp [string compare [lindex $reflist $i 0] \
6344 [lindex $refs $j 0]]
6345 if {$cmp == 0} {
6346 set cmp [string compare [lindex $reflist $i 1] \
6347 [lindex $refs $j 1]]
6349 } else {
6350 set cmp -1
6352 } else {
6353 set cmp 1
6355 switch -- $cmp {
6356 -1 {
6357 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6358 incr i
6361 incr i
6362 incr j
6365 set l [expr {$j + 1}]
6366 $showrefstop.list image create $l.0 -align baseline \
6367 -image reficon-[lindex $refs $j 1] -padx 2
6368 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6369 incr j
6373 set reflist $refs
6374 # delete last newline
6375 $showrefstop.list delete end-2c end-1c
6376 $showrefstop.list conf -state disabled
6379 # Stuff for finding nearby tags
6380 proc getallcommits {} {
6381 global allcommits allids nbmp nextarc seeds
6383 if {![info exists allcommits]} {
6384 set allids {}
6385 set nbmp 0
6386 set nextarc 0
6387 set allcommits 0
6388 set seeds {}
6391 set cmd [concat | git rev-list --all --parents]
6392 foreach id $seeds {
6393 lappend cmd "^$id"
6395 set fd [open $cmd r]
6396 fconfigure $fd -blocking 0
6397 incr allcommits
6398 nowbusy allcommits
6399 filerun $fd [list getallclines $fd]
6402 # Since most commits have 1 parent and 1 child, we group strings of
6403 # such commits into "arcs" joining branch/merge points (BMPs), which
6404 # are commits that either don't have 1 parent or don't have 1 child.
6406 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6407 # arcout(id) - outgoing arcs for BMP
6408 # arcids(a) - list of IDs on arc including end but not start
6409 # arcstart(a) - BMP ID at start of arc
6410 # arcend(a) - BMP ID at end of arc
6411 # growing(a) - arc a is still growing
6412 # arctags(a) - IDs out of arcids (excluding end) that have tags
6413 # archeads(a) - IDs out of arcids (excluding end) that have heads
6414 # The start of an arc is at the descendent end, so "incoming" means
6415 # coming from descendents, and "outgoing" means going towards ancestors.
6417 proc getallclines {fd} {
6418 global allids allparents allchildren idtags idheads nextarc nbmp
6419 global arcnos arcids arctags arcout arcend arcstart archeads growing
6420 global seeds allcommits
6422 set nid 0
6423 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6424 set id [lindex $line 0]
6425 if {[info exists allparents($id)]} {
6426 # seen it already
6427 continue
6429 lappend allids $id
6430 set olds [lrange $line 1 end]
6431 set allparents($id) $olds
6432 if {![info exists allchildren($id)]} {
6433 set allchildren($id) {}
6434 set arcnos($id) {}
6435 lappend seeds $id
6436 } else {
6437 set a $arcnos($id)
6438 if {[llength $olds] == 1 && [llength $a] == 1} {
6439 lappend arcids($a) $id
6440 if {[info exists idtags($id)]} {
6441 lappend arctags($a) $id
6443 if {[info exists idheads($id)]} {
6444 lappend archeads($a) $id
6446 if {[info exists allparents($olds)]} {
6447 # seen parent already
6448 if {![info exists arcout($olds)]} {
6449 splitarc $olds
6451 lappend arcids($a) $olds
6452 set arcend($a) $olds
6453 unset growing($a)
6455 lappend allchildren($olds) $id
6456 lappend arcnos($olds) $a
6457 continue
6460 incr nbmp
6461 foreach a $arcnos($id) {
6462 lappend arcids($a) $id
6463 set arcend($a) $id
6464 unset growing($a)
6467 set ao {}
6468 foreach p $olds {
6469 lappend allchildren($p) $id
6470 set a [incr nextarc]
6471 set arcstart($a) $id
6472 set archeads($a) {}
6473 set arctags($a) {}
6474 set archeads($a) {}
6475 set arcids($a) {}
6476 lappend ao $a
6477 set growing($a) 1
6478 if {[info exists allparents($p)]} {
6479 # seen it already, may need to make a new branch
6480 if {![info exists arcout($p)]} {
6481 splitarc $p
6483 lappend arcids($a) $p
6484 set arcend($a) $p
6485 unset growing($a)
6487 lappend arcnos($p) $a
6489 set arcout($id) $ao
6491 if {$nid > 0} {
6492 global cached_dheads cached_dtags cached_atags
6493 catch {unset cached_dheads}
6494 catch {unset cached_dtags}
6495 catch {unset cached_atags}
6497 if {![eof $fd]} {
6498 return [expr {$nid >= 1000? 2: 1}]
6500 close $fd
6501 if {[incr allcommits -1] == 0} {
6502 notbusy allcommits
6504 dispneartags 0
6505 return 0
6508 proc recalcarc {a} {
6509 global arctags archeads arcids idtags idheads
6511 set at {}
6512 set ah {}
6513 foreach id [lrange $arcids($a) 0 end-1] {
6514 if {[info exists idtags($id)]} {
6515 lappend at $id
6517 if {[info exists idheads($id)]} {
6518 lappend ah $id
6521 set arctags($a) $at
6522 set archeads($a) $ah
6525 proc splitarc {p} {
6526 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6527 global arcstart arcend arcout allparents growing
6529 set a $arcnos($p)
6530 if {[llength $a] != 1} {
6531 puts "oops splitarc called but [llength $a] arcs already"
6532 return
6534 set a [lindex $a 0]
6535 set i [lsearch -exact $arcids($a) $p]
6536 if {$i < 0} {
6537 puts "oops splitarc $p not in arc $a"
6538 return
6540 set na [incr nextarc]
6541 if {[info exists arcend($a)]} {
6542 set arcend($na) $arcend($a)
6543 } else {
6544 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6545 set j [lsearch -exact $arcnos($l) $a]
6546 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6548 set tail [lrange $arcids($a) [expr {$i+1}] end]
6549 set arcids($a) [lrange $arcids($a) 0 $i]
6550 set arcend($a) $p
6551 set arcstart($na) $p
6552 set arcout($p) $na
6553 set arcids($na) $tail
6554 if {[info exists growing($a)]} {
6555 set growing($na) 1
6556 unset growing($a)
6558 incr nbmp
6560 foreach id $tail {
6561 if {[llength $arcnos($id)] == 1} {
6562 set arcnos($id) $na
6563 } else {
6564 set j [lsearch -exact $arcnos($id) $a]
6565 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6569 # reconstruct tags and heads lists
6570 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6571 recalcarc $a
6572 recalcarc $na
6573 } else {
6574 set arctags($na) {}
6575 set archeads($na) {}
6579 # Update things for a new commit added that is a child of one
6580 # existing commit. Used when cherry-picking.
6581 proc addnewchild {id p} {
6582 global allids allparents allchildren idtags nextarc nbmp
6583 global arcnos arcids arctags arcout arcend arcstart archeads growing
6584 global seeds
6586 lappend allids $id
6587 set allparents($id) [list $p]
6588 set allchildren($id) {}
6589 set arcnos($id) {}
6590 lappend seeds $id
6591 incr nbmp
6592 lappend allchildren($p) $id
6593 set a [incr nextarc]
6594 set arcstart($a) $id
6595 set archeads($a) {}
6596 set arctags($a) {}
6597 set arcids($a) [list $p]
6598 set arcend($a) $p
6599 if {![info exists arcout($p)]} {
6600 splitarc $p
6602 lappend arcnos($p) $a
6603 set arcout($id) [list $a]
6606 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6607 # or 0 if neither is true.
6608 proc anc_or_desc {a b} {
6609 global arcout arcstart arcend arcnos cached_isanc
6611 if {$arcnos($a) eq $arcnos($b)} {
6612 # Both are on the same arc(s); either both are the same BMP,
6613 # or if one is not a BMP, the other is also not a BMP or is
6614 # the BMP at end of the arc (and it only has 1 incoming arc).
6615 # Or both can be BMPs with no incoming arcs.
6616 if {$a eq $b || $arcnos($a) eq {}} {
6617 return 0
6619 # assert {[llength $arcnos($a)] == 1}
6620 set arc [lindex $arcnos($a) 0]
6621 set i [lsearch -exact $arcids($arc) $a]
6622 set j [lsearch -exact $arcids($arc) $b]
6623 if {$i < 0 || $i > $j} {
6624 return 1
6625 } else {
6626 return -1
6630 if {![info exists arcout($a)]} {
6631 set arc [lindex $arcnos($a) 0]
6632 if {[info exists arcend($arc)]} {
6633 set aend $arcend($arc)
6634 } else {
6635 set aend {}
6637 set a $arcstart($arc)
6638 } else {
6639 set aend $a
6641 if {![info exists arcout($b)]} {
6642 set arc [lindex $arcnos($b) 0]
6643 if {[info exists arcend($arc)]} {
6644 set bend $arcend($arc)
6645 } else {
6646 set bend {}
6648 set b $arcstart($arc)
6649 } else {
6650 set bend $b
6652 if {$a eq $bend} {
6653 return 1
6655 if {$b eq $aend} {
6656 return -1
6658 if {[info exists cached_isanc($a,$bend)]} {
6659 if {$cached_isanc($a,$bend)} {
6660 return 1
6663 if {[info exists cached_isanc($b,$aend)]} {
6664 if {$cached_isanc($b,$aend)} {
6665 return -1
6667 if {[info exists cached_isanc($a,$bend)]} {
6668 return 0
6672 set todo [list $a $b]
6673 set anc($a) a
6674 set anc($b) b
6675 for {set i 0} {$i < [llength $todo]} {incr i} {
6676 set x [lindex $todo $i]
6677 if {$anc($x) eq {}} {
6678 continue
6680 foreach arc $arcnos($x) {
6681 set xd $arcstart($arc)
6682 if {$xd eq $bend} {
6683 set cached_isanc($a,$bend) 1
6684 set cached_isanc($b,$aend) 0
6685 return 1
6686 } elseif {$xd eq $aend} {
6687 set cached_isanc($b,$aend) 1
6688 set cached_isanc($a,$bend) 0
6689 return -1
6691 if {![info exists anc($xd)]} {
6692 set anc($xd) $anc($x)
6693 lappend todo $xd
6694 } elseif {$anc($xd) ne $anc($x)} {
6695 set anc($xd) {}
6699 set cached_isanc($a,$bend) 0
6700 set cached_isanc($b,$aend) 0
6701 return 0
6704 # This identifies whether $desc has an ancestor that is
6705 # a growing tip of the graph and which is not an ancestor of $anc
6706 # and returns 0 if so and 1 if not.
6707 # If we subsequently discover a tag on such a growing tip, and that
6708 # turns out to be a descendent of $anc (which it could, since we
6709 # don't necessarily see children before parents), then $desc
6710 # isn't a good choice to display as a descendent tag of
6711 # $anc (since it is the descendent of another tag which is
6712 # a descendent of $anc). Similarly, $anc isn't a good choice to
6713 # display as a ancestor tag of $desc.
6715 proc is_certain {desc anc} {
6716 global arcnos arcout arcstart arcend growing problems
6718 set certain {}
6719 if {[llength $arcnos($anc)] == 1} {
6720 # tags on the same arc are certain
6721 if {$arcnos($desc) eq $arcnos($anc)} {
6722 return 1
6724 if {![info exists arcout($anc)]} {
6725 # if $anc is partway along an arc, use the start of the arc instead
6726 set a [lindex $arcnos($anc) 0]
6727 set anc $arcstart($a)
6730 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6731 set x $desc
6732 } else {
6733 set a [lindex $arcnos($desc) 0]
6734 set x $arcend($a)
6736 if {$x == $anc} {
6737 return 1
6739 set anclist [list $x]
6740 set dl($x) 1
6741 set nnh 1
6742 set ngrowanc 0
6743 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6744 set x [lindex $anclist $i]
6745 if {$dl($x)} {
6746 incr nnh -1
6748 set done($x) 1
6749 foreach a $arcout($x) {
6750 if {[info exists growing($a)]} {
6751 if {![info exists growanc($x)] && $dl($x)} {
6752 set growanc($x) 1
6753 incr ngrowanc
6755 } else {
6756 set y $arcend($a)
6757 if {[info exists dl($y)]} {
6758 if {$dl($y)} {
6759 if {!$dl($x)} {
6760 set dl($y) 0
6761 if {![info exists done($y)]} {
6762 incr nnh -1
6764 if {[info exists growanc($x)]} {
6765 incr ngrowanc -1
6767 set xl [list $y]
6768 for {set k 0} {$k < [llength $xl]} {incr k} {
6769 set z [lindex $xl $k]
6770 foreach c $arcout($z) {
6771 if {[info exists arcend($c)]} {
6772 set v $arcend($c)
6773 if {[info exists dl($v)] && $dl($v)} {
6774 set dl($v) 0
6775 if {![info exists done($v)]} {
6776 incr nnh -1
6778 if {[info exists growanc($v)]} {
6779 incr ngrowanc -1
6781 lappend xl $v
6788 } elseif {$y eq $anc || !$dl($x)} {
6789 set dl($y) 0
6790 lappend anclist $y
6791 } else {
6792 set dl($y) 1
6793 lappend anclist $y
6794 incr nnh
6799 foreach x [array names growanc] {
6800 if {$dl($x)} {
6801 return 0
6803 return 0
6805 return 1
6808 proc validate_arctags {a} {
6809 global arctags idtags
6811 set i -1
6812 set na $arctags($a)
6813 foreach id $arctags($a) {
6814 incr i
6815 if {![info exists idtags($id)]} {
6816 set na [lreplace $na $i $i]
6817 incr i -1
6820 set arctags($a) $na
6823 proc validate_archeads {a} {
6824 global archeads idheads
6826 set i -1
6827 set na $archeads($a)
6828 foreach id $archeads($a) {
6829 incr i
6830 if {![info exists idheads($id)]} {
6831 set na [lreplace $na $i $i]
6832 incr i -1
6835 set archeads($a) $na
6838 # Return the list of IDs that have tags that are descendents of id,
6839 # ignoring IDs that are descendents of IDs already reported.
6840 proc desctags {id} {
6841 global arcnos arcstart arcids arctags idtags allparents
6842 global growing cached_dtags
6844 if {![info exists allparents($id)]} {
6845 return {}
6847 set t1 [clock clicks -milliseconds]
6848 set argid $id
6849 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6850 # part-way along an arc; check that arc first
6851 set a [lindex $arcnos($id) 0]
6852 if {$arctags($a) ne {}} {
6853 validate_arctags $a
6854 set i [lsearch -exact $arcids($a) $id]
6855 set tid {}
6856 foreach t $arctags($a) {
6857 set j [lsearch -exact $arcids($a) $t]
6858 if {$j >= $i} break
6859 set tid $t
6861 if {$tid ne {}} {
6862 return $tid
6865 set id $arcstart($a)
6866 if {[info exists idtags($id)]} {
6867 return $id
6870 if {[info exists cached_dtags($id)]} {
6871 return $cached_dtags($id)
6874 set origid $id
6875 set todo [list $id]
6876 set queued($id) 1
6877 set nc 1
6878 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6879 set id [lindex $todo $i]
6880 set done($id) 1
6881 set ta [info exists hastaggedancestor($id)]
6882 if {!$ta} {
6883 incr nc -1
6885 # ignore tags on starting node
6886 if {!$ta && $i > 0} {
6887 if {[info exists idtags($id)]} {
6888 set tagloc($id) $id
6889 set ta 1
6890 } elseif {[info exists cached_dtags($id)]} {
6891 set tagloc($id) $cached_dtags($id)
6892 set ta 1
6895 foreach a $arcnos($id) {
6896 set d $arcstart($a)
6897 if {!$ta && $arctags($a) ne {}} {
6898 validate_arctags $a
6899 if {$arctags($a) ne {}} {
6900 lappend tagloc($id) [lindex $arctags($a) end]
6903 if {$ta || $arctags($a) ne {}} {
6904 set tomark [list $d]
6905 for {set j 0} {$j < [llength $tomark]} {incr j} {
6906 set dd [lindex $tomark $j]
6907 if {![info exists hastaggedancestor($dd)]} {
6908 if {[info exists done($dd)]} {
6909 foreach b $arcnos($dd) {
6910 lappend tomark $arcstart($b)
6912 if {[info exists tagloc($dd)]} {
6913 unset tagloc($dd)
6915 } elseif {[info exists queued($dd)]} {
6916 incr nc -1
6918 set hastaggedancestor($dd) 1
6922 if {![info exists queued($d)]} {
6923 lappend todo $d
6924 set queued($d) 1
6925 if {![info exists hastaggedancestor($d)]} {
6926 incr nc
6931 set tags {}
6932 foreach id [array names tagloc] {
6933 if {![info exists hastaggedancestor($id)]} {
6934 foreach t $tagloc($id) {
6935 if {[lsearch -exact $tags $t] < 0} {
6936 lappend tags $t
6941 set t2 [clock clicks -milliseconds]
6942 set loopix $i
6944 # remove tags that are descendents of other tags
6945 for {set i 0} {$i < [llength $tags]} {incr i} {
6946 set a [lindex $tags $i]
6947 for {set j 0} {$j < $i} {incr j} {
6948 set b [lindex $tags $j]
6949 set r [anc_or_desc $a $b]
6950 if {$r == 1} {
6951 set tags [lreplace $tags $j $j]
6952 incr j -1
6953 incr i -1
6954 } elseif {$r == -1} {
6955 set tags [lreplace $tags $i $i]
6956 incr i -1
6957 break
6962 if {[array names growing] ne {}} {
6963 # graph isn't finished, need to check if any tag could get
6964 # eclipsed by another tag coming later. Simply ignore any
6965 # tags that could later get eclipsed.
6966 set ctags {}
6967 foreach t $tags {
6968 if {[is_certain $t $origid]} {
6969 lappend ctags $t
6972 if {$tags eq $ctags} {
6973 set cached_dtags($origid) $tags
6974 } else {
6975 set tags $ctags
6977 } else {
6978 set cached_dtags($origid) $tags
6980 set t3 [clock clicks -milliseconds]
6981 if {0 && $t3 - $t1 >= 100} {
6982 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6983 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6985 return $tags
6988 proc anctags {id} {
6989 global arcnos arcids arcout arcend arctags idtags allparents
6990 global growing cached_atags
6992 if {![info exists allparents($id)]} {
6993 return {}
6995 set t1 [clock clicks -milliseconds]
6996 set argid $id
6997 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6998 # part-way along an arc; check that arc first
6999 set a [lindex $arcnos($id) 0]
7000 if {$arctags($a) ne {}} {
7001 validate_arctags $a
7002 set i [lsearch -exact $arcids($a) $id]
7003 foreach t $arctags($a) {
7004 set j [lsearch -exact $arcids($a) $t]
7005 if {$j > $i} {
7006 return $t
7010 if {![info exists arcend($a)]} {
7011 return {}
7013 set id $arcend($a)
7014 if {[info exists idtags($id)]} {
7015 return $id
7018 if {[info exists cached_atags($id)]} {
7019 return $cached_atags($id)
7022 set origid $id
7023 set todo [list $id]
7024 set queued($id) 1
7025 set taglist {}
7026 set nc 1
7027 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7028 set id [lindex $todo $i]
7029 set done($id) 1
7030 set td [info exists hastaggeddescendent($id)]
7031 if {!$td} {
7032 incr nc -1
7034 # ignore tags on starting node
7035 if {!$td && $i > 0} {
7036 if {[info exists idtags($id)]} {
7037 set tagloc($id) $id
7038 set td 1
7039 } elseif {[info exists cached_atags($id)]} {
7040 set tagloc($id) $cached_atags($id)
7041 set td 1
7044 foreach a $arcout($id) {
7045 if {!$td && $arctags($a) ne {}} {
7046 validate_arctags $a
7047 if {$arctags($a) ne {}} {
7048 lappend tagloc($id) [lindex $arctags($a) 0]
7051 if {![info exists arcend($a)]} continue
7052 set d $arcend($a)
7053 if {$td || $arctags($a) ne {}} {
7054 set tomark [list $d]
7055 for {set j 0} {$j < [llength $tomark]} {incr j} {
7056 set dd [lindex $tomark $j]
7057 if {![info exists hastaggeddescendent($dd)]} {
7058 if {[info exists done($dd)]} {
7059 foreach b $arcout($dd) {
7060 if {[info exists arcend($b)]} {
7061 lappend tomark $arcend($b)
7064 if {[info exists tagloc($dd)]} {
7065 unset tagloc($dd)
7067 } elseif {[info exists queued($dd)]} {
7068 incr nc -1
7070 set hastaggeddescendent($dd) 1
7074 if {![info exists queued($d)]} {
7075 lappend todo $d
7076 set queued($d) 1
7077 if {![info exists hastaggeddescendent($d)]} {
7078 incr nc
7083 set t2 [clock clicks -milliseconds]
7084 set loopix $i
7085 set tags {}
7086 foreach id [array names tagloc] {
7087 if {![info exists hastaggeddescendent($id)]} {
7088 foreach t $tagloc($id) {
7089 if {[lsearch -exact $tags $t] < 0} {
7090 lappend tags $t
7096 # remove tags that are ancestors of other tags
7097 for {set i 0} {$i < [llength $tags]} {incr i} {
7098 set a [lindex $tags $i]
7099 for {set j 0} {$j < $i} {incr j} {
7100 set b [lindex $tags $j]
7101 set r [anc_or_desc $a $b]
7102 if {$r == -1} {
7103 set tags [lreplace $tags $j $j]
7104 incr j -1
7105 incr i -1
7106 } elseif {$r == 1} {
7107 set tags [lreplace $tags $i $i]
7108 incr i -1
7109 break
7114 if {[array names growing] ne {}} {
7115 # graph isn't finished, need to check if any tag could get
7116 # eclipsed by another tag coming later. Simply ignore any
7117 # tags that could later get eclipsed.
7118 set ctags {}
7119 foreach t $tags {
7120 if {[is_certain $origid $t]} {
7121 lappend ctags $t
7124 if {$tags eq $ctags} {
7125 set cached_atags($origid) $tags
7126 } else {
7127 set tags $ctags
7129 } else {
7130 set cached_atags($origid) $tags
7132 set t3 [clock clicks -milliseconds]
7133 if {0 && $t3 - $t1 >= 100} {
7134 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7135 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7137 return $tags
7140 # Return the list of IDs that have heads that are descendents of id,
7141 # including id itself if it has a head.
7142 proc descheads {id} {
7143 global arcnos arcstart arcids archeads idheads cached_dheads
7144 global allparents
7146 if {![info exists allparents($id)]} {
7147 return {}
7149 set aret {}
7150 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7151 # part-way along an arc; check it first
7152 set a [lindex $arcnos($id) 0]
7153 if {$archeads($a) ne {}} {
7154 validate_archeads $a
7155 set i [lsearch -exact $arcids($a) $id]
7156 foreach t $archeads($a) {
7157 set j [lsearch -exact $arcids($a) $t]
7158 if {$j > $i} break
7159 lappend aret $t
7162 set id $arcstart($a)
7164 set origid $id
7165 set todo [list $id]
7166 set seen($id) 1
7167 set ret {}
7168 for {set i 0} {$i < [llength $todo]} {incr i} {
7169 set id [lindex $todo $i]
7170 if {[info exists cached_dheads($id)]} {
7171 set ret [concat $ret $cached_dheads($id)]
7172 } else {
7173 if {[info exists idheads($id)]} {
7174 lappend ret $id
7176 foreach a $arcnos($id) {
7177 if {$archeads($a) ne {}} {
7178 validate_archeads $a
7179 if {$archeads($a) ne {}} {
7180 set ret [concat $ret $archeads($a)]
7183 set d $arcstart($a)
7184 if {![info exists seen($d)]} {
7185 lappend todo $d
7186 set seen($d) 1
7191 set ret [lsort -unique $ret]
7192 set cached_dheads($origid) $ret
7193 return [concat $ret $aret]
7196 proc addedtag {id} {
7197 global arcnos arcout cached_dtags cached_atags
7199 if {![info exists arcnos($id)]} return
7200 if {![info exists arcout($id)]} {
7201 recalcarc [lindex $arcnos($id) 0]
7203 catch {unset cached_dtags}
7204 catch {unset cached_atags}
7207 proc addedhead {hid head} {
7208 global arcnos arcout cached_dheads
7210 if {![info exists arcnos($hid)]} return
7211 if {![info exists arcout($hid)]} {
7212 recalcarc [lindex $arcnos($hid) 0]
7214 catch {unset cached_dheads}
7217 proc removedhead {hid head} {
7218 global cached_dheads
7220 catch {unset cached_dheads}
7223 proc movedhead {hid head} {
7224 global arcnos arcout cached_dheads
7226 if {![info exists arcnos($hid)]} return
7227 if {![info exists arcout($hid)]} {
7228 recalcarc [lindex $arcnos($hid) 0]
7230 catch {unset cached_dheads}
7233 proc changedrefs {} {
7234 global cached_dheads cached_dtags cached_atags
7235 global arctags archeads arcnos arcout idheads idtags
7237 foreach id [concat [array names idheads] [array names idtags]] {
7238 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7239 set a [lindex $arcnos($id) 0]
7240 if {![info exists donearc($a)]} {
7241 recalcarc $a
7242 set donearc($a) 1
7246 catch {unset cached_dtags}
7247 catch {unset cached_atags}
7248 catch {unset cached_dheads}
7251 proc rereadrefs {} {
7252 global idtags idheads idotherrefs mainhead
7254 set refids [concat [array names idtags] \
7255 [array names idheads] [array names idotherrefs]]
7256 foreach id $refids {
7257 if {![info exists ref($id)]} {
7258 set ref($id) [listrefs $id]
7261 set oldmainhead $mainhead
7262 readrefs
7263 changedrefs
7264 set refids [lsort -unique [concat $refids [array names idtags] \
7265 [array names idheads] [array names idotherrefs]]]
7266 foreach id $refids {
7267 set v [listrefs $id]
7268 if {![info exists ref($id)] || $ref($id) != $v ||
7269 ($id eq $oldmainhead && $id ne $mainhead) ||
7270 ($id eq $mainhead && $id ne $oldmainhead)} {
7271 redrawtags $id
7274 run refill_reflist
7277 proc listrefs {id} {
7278 global idtags idheads idotherrefs
7280 set x {}
7281 if {[info exists idtags($id)]} {
7282 set x $idtags($id)
7284 set y {}
7285 if {[info exists idheads($id)]} {
7286 set y $idheads($id)
7288 set z {}
7289 if {[info exists idotherrefs($id)]} {
7290 set z $idotherrefs($id)
7292 return [list $x $y $z]
7295 proc showtag {tag isnew} {
7296 global ctext tagcontents tagids linknum tagobjid
7298 if {$isnew} {
7299 addtohistory [list showtag $tag 0]
7301 $ctext conf -state normal
7302 clear_ctext
7303 set linknum 0
7304 if {![info exists tagcontents($tag)]} {
7305 catch {
7306 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7309 if {[info exists tagcontents($tag)]} {
7310 set text $tagcontents($tag)
7311 } else {
7312 set text "Tag: $tag\nId: $tagids($tag)"
7314 appendwithlinks $text {}
7315 $ctext conf -state disabled
7316 init_flist {}
7319 proc doquit {} {
7320 global stopped
7321 set stopped 100
7322 savestuff .
7323 destroy .
7326 proc doprefs {} {
7327 global maxwidth maxgraphpct diffopts
7328 global oldprefs prefstop showneartags showlocalchanges
7329 global bgcolor fgcolor ctext diffcolors selectbgcolor
7330 global uifont tabstop
7332 set top .gitkprefs
7333 set prefstop $top
7334 if {[winfo exists $top]} {
7335 raise $top
7336 return
7338 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7339 set oldprefs($v) [set $v]
7341 toplevel $top
7342 wm title $top "Gitk preferences"
7343 label $top.ldisp -text "Commit list display options"
7344 $top.ldisp configure -font $uifont
7345 grid $top.ldisp - -sticky w -pady 10
7346 label $top.spacer -text " "
7347 label $top.maxwidthl -text "Maximum graph width (lines)" \
7348 -font optionfont
7349 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7350 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7351 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7352 -font optionfont
7353 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7354 grid x $top.maxpctl $top.maxpct -sticky w
7355 frame $top.showlocal
7356 label $top.showlocal.l -text "Show local changes" -font optionfont
7357 checkbutton $top.showlocal.b -variable showlocalchanges
7358 pack $top.showlocal.b $top.showlocal.l -side left
7359 grid x $top.showlocal -sticky w
7361 label $top.ddisp -text "Diff display options"
7362 $top.ddisp configure -font $uifont
7363 grid $top.ddisp - -sticky w -pady 10
7364 label $top.diffoptl -text "Options for diff program" \
7365 -font optionfont
7366 entry $top.diffopt -width 20 -textvariable diffopts
7367 grid x $top.diffoptl $top.diffopt -sticky w
7368 frame $top.ntag
7369 label $top.ntag.l -text "Display nearby tags" -font optionfont
7370 checkbutton $top.ntag.b -variable showneartags
7371 pack $top.ntag.b $top.ntag.l -side left
7372 grid x $top.ntag -sticky w
7373 label $top.tabstopl -text "tabstop" -font optionfont
7374 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7375 grid x $top.tabstopl $top.tabstop -sticky w
7377 label $top.cdisp -text "Colors: press to choose"
7378 $top.cdisp configure -font $uifont
7379 grid $top.cdisp - -sticky w -pady 10
7380 label $top.bg -padx 40 -relief sunk -background $bgcolor
7381 button $top.bgbut -text "Background" -font optionfont \
7382 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7383 grid x $top.bgbut $top.bg -sticky w
7384 label $top.fg -padx 40 -relief sunk -background $fgcolor
7385 button $top.fgbut -text "Foreground" -font optionfont \
7386 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7387 grid x $top.fgbut $top.fg -sticky w
7388 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7389 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7390 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7391 [list $ctext tag conf d0 -foreground]]
7392 grid x $top.diffoldbut $top.diffold -sticky w
7393 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7394 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7395 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7396 [list $ctext tag conf d1 -foreground]]
7397 grid x $top.diffnewbut $top.diffnew -sticky w
7398 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7399 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7400 -command [list choosecolor diffcolors 2 $top.hunksep \
7401 "diff hunk header" \
7402 [list $ctext tag conf hunksep -foreground]]
7403 grid x $top.hunksepbut $top.hunksep -sticky w
7404 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7405 button $top.selbgbut -text "Select bg" -font optionfont \
7406 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7407 grid x $top.selbgbut $top.selbgsep -sticky w
7409 frame $top.buts
7410 button $top.buts.ok -text "OK" -command prefsok -default active
7411 $top.buts.ok configure -font $uifont
7412 button $top.buts.can -text "Cancel" -command prefscan -default normal
7413 $top.buts.can configure -font $uifont
7414 grid $top.buts.ok $top.buts.can
7415 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7416 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7417 grid $top.buts - - -pady 10 -sticky ew
7418 bind $top <Visibility> "focus $top.buts.ok"
7421 proc choosecolor {v vi w x cmd} {
7422 global $v
7424 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7425 -title "Gitk: choose color for $x"]
7426 if {$c eq {}} return
7427 $w conf -background $c
7428 lset $v $vi $c
7429 eval $cmd $c
7432 proc setselbg {c} {
7433 global bglist cflist
7434 foreach w $bglist {
7435 $w configure -selectbackground $c
7437 $cflist tag configure highlight \
7438 -background [$cflist cget -selectbackground]
7439 allcanvs itemconf secsel -fill $c
7442 proc setbg {c} {
7443 global bglist
7445 foreach w $bglist {
7446 $w conf -background $c
7450 proc setfg {c} {
7451 global fglist canv
7453 foreach w $fglist {
7454 $w conf -foreground $c
7456 allcanvs itemconf text -fill $c
7457 $canv itemconf circle -outline $c
7460 proc prefscan {} {
7461 global maxwidth maxgraphpct diffopts
7462 global oldprefs prefstop showneartags showlocalchanges
7464 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7465 set $v $oldprefs($v)
7467 catch {destroy $prefstop}
7468 unset prefstop
7471 proc prefsok {} {
7472 global maxwidth maxgraphpct
7473 global oldprefs prefstop showneartags showlocalchanges
7474 global charspc ctext tabstop
7476 catch {destroy $prefstop}
7477 unset prefstop
7478 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7479 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7480 if {$showlocalchanges} {
7481 doshowlocalchanges
7482 } else {
7483 dohidelocalchanges
7486 if {$maxwidth != $oldprefs(maxwidth)
7487 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7488 redisplay
7489 } elseif {$showneartags != $oldprefs(showneartags)} {
7490 reselectline
7494 proc formatdate {d} {
7495 global datetimeformat
7496 if {$d ne {}} {
7497 set d [clock format $d -format $datetimeformat]
7499 return $d
7502 # This list of encoding names and aliases is distilled from
7503 # http://www.iana.org/assignments/character-sets.
7504 # Not all of them are supported by Tcl.
7505 set encoding_aliases {
7506 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7507 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7508 { ISO-10646-UTF-1 csISO10646UTF1 }
7509 { ISO_646.basic:1983 ref csISO646basic1983 }
7510 { INVARIANT csINVARIANT }
7511 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7512 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7513 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7514 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7515 { NATS-DANO iso-ir-9-1 csNATSDANO }
7516 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7517 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7518 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7519 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7520 { ISO-2022-KR csISO2022KR }
7521 { EUC-KR csEUCKR }
7522 { ISO-2022-JP csISO2022JP }
7523 { ISO-2022-JP-2 csISO2022JP2 }
7524 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7525 csISO13JISC6220jp }
7526 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7527 { IT iso-ir-15 ISO646-IT csISO15Italian }
7528 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7529 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7530 { greek7-old iso-ir-18 csISO18Greek7Old }
7531 { latin-greek iso-ir-19 csISO19LatinGreek }
7532 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7533 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7534 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7535 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7536 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7537 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7538 { INIS iso-ir-49 csISO49INIS }
7539 { INIS-8 iso-ir-50 csISO50INIS8 }
7540 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7541 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7542 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7543 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7544 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7545 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7546 csISO60Norwegian1 }
7547 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7548 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7549 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7550 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7551 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7552 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7553 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7554 { greek7 iso-ir-88 csISO88Greek7 }
7555 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7556 { iso-ir-90 csISO90 }
7557 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7558 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7559 csISO92JISC62991984b }
7560 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7561 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7562 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7563 csISO95JIS62291984handadd }
7564 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7565 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7566 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7567 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7568 CP819 csISOLatin1 }
7569 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7570 { T.61-7bit iso-ir-102 csISO102T617bit }
7571 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7572 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7573 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7574 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7575 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7576 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7577 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7578 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7579 arabic csISOLatinArabic }
7580 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7581 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7582 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7583 greek greek8 csISOLatinGreek }
7584 { T.101-G2 iso-ir-128 csISO128T101G2 }
7585 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7586 csISOLatinHebrew }
7587 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7588 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7589 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7590 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7591 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7592 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7593 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7594 csISOLatinCyrillic }
7595 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7596 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7597 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7598 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7599 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7600 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7601 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7602 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7603 { ISO_10367-box iso-ir-155 csISO10367Box }
7604 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7605 { latin-lap lap iso-ir-158 csISO158Lap }
7606 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7607 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7608 { us-dk csUSDK }
7609 { dk-us csDKUS }
7610 { JIS_X0201 X0201 csHalfWidthKatakana }
7611 { KSC5636 ISO646-KR csKSC5636 }
7612 { ISO-10646-UCS-2 csUnicode }
7613 { ISO-10646-UCS-4 csUCS4 }
7614 { DEC-MCS dec csDECMCS }
7615 { hp-roman8 roman8 r8 csHPRoman8 }
7616 { macintosh mac csMacintosh }
7617 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7618 csIBM037 }
7619 { IBM038 EBCDIC-INT cp038 csIBM038 }
7620 { IBM273 CP273 csIBM273 }
7621 { IBM274 EBCDIC-BE CP274 csIBM274 }
7622 { IBM275 EBCDIC-BR cp275 csIBM275 }
7623 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7624 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7625 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7626 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7627 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7628 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7629 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7630 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7631 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7632 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7633 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7634 { IBM437 cp437 437 csPC8CodePage437 }
7635 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7636 { IBM775 cp775 csPC775Baltic }
7637 { IBM850 cp850 850 csPC850Multilingual }
7638 { IBM851 cp851 851 csIBM851 }
7639 { IBM852 cp852 852 csPCp852 }
7640 { IBM855 cp855 855 csIBM855 }
7641 { IBM857 cp857 857 csIBM857 }
7642 { IBM860 cp860 860 csIBM860 }
7643 { IBM861 cp861 861 cp-is csIBM861 }
7644 { IBM862 cp862 862 csPC862LatinHebrew }
7645 { IBM863 cp863 863 csIBM863 }
7646 { IBM864 cp864 csIBM864 }
7647 { IBM865 cp865 865 csIBM865 }
7648 { IBM866 cp866 866 csIBM866 }
7649 { IBM868 CP868 cp-ar csIBM868 }
7650 { IBM869 cp869 869 cp-gr csIBM869 }
7651 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7652 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7653 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7654 { IBM891 cp891 csIBM891 }
7655 { IBM903 cp903 csIBM903 }
7656 { IBM904 cp904 904 csIBBM904 }
7657 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7658 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7659 { IBM1026 CP1026 csIBM1026 }
7660 { EBCDIC-AT-DE csIBMEBCDICATDE }
7661 { EBCDIC-AT-DE-A csEBCDICATDEA }
7662 { EBCDIC-CA-FR csEBCDICCAFR }
7663 { EBCDIC-DK-NO csEBCDICDKNO }
7664 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7665 { EBCDIC-FI-SE csEBCDICFISE }
7666 { EBCDIC-FI-SE-A csEBCDICFISEA }
7667 { EBCDIC-FR csEBCDICFR }
7668 { EBCDIC-IT csEBCDICIT }
7669 { EBCDIC-PT csEBCDICPT }
7670 { EBCDIC-ES csEBCDICES }
7671 { EBCDIC-ES-A csEBCDICESA }
7672 { EBCDIC-ES-S csEBCDICESS }
7673 { EBCDIC-UK csEBCDICUK }
7674 { EBCDIC-US csEBCDICUS }
7675 { UNKNOWN-8BIT csUnknown8BiT }
7676 { MNEMONIC csMnemonic }
7677 { MNEM csMnem }
7678 { VISCII csVISCII }
7679 { VIQR csVIQR }
7680 { KOI8-R csKOI8R }
7681 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7682 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7683 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7684 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7685 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7686 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7687 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7688 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7689 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7690 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7691 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7692 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7693 { IBM1047 IBM-1047 }
7694 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7695 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7696 { UNICODE-1-1 csUnicode11 }
7697 { CESU-8 csCESU-8 }
7698 { BOCU-1 csBOCU-1 }
7699 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7700 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7701 l8 }
7702 { ISO-8859-15 ISO_8859-15 Latin-9 }
7703 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7704 { GBK CP936 MS936 windows-936 }
7705 { JIS_Encoding csJISEncoding }
7706 { Shift_JIS MS_Kanji csShiftJIS }
7707 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7708 EUC-JP }
7709 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7710 { ISO-10646-UCS-Basic csUnicodeASCII }
7711 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7712 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7713 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7714 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7715 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7716 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7717 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7718 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7719 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7720 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7721 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7722 { Ventura-US csVenturaUS }
7723 { Ventura-International csVenturaInternational }
7724 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7725 { PC8-Turkish csPC8Turkish }
7726 { IBM-Symbols csIBMSymbols }
7727 { IBM-Thai csIBMThai }
7728 { HP-Legal csHPLegal }
7729 { HP-Pi-font csHPPiFont }
7730 { HP-Math8 csHPMath8 }
7731 { Adobe-Symbol-Encoding csHPPSMath }
7732 { HP-DeskTop csHPDesktop }
7733 { Ventura-Math csVenturaMath }
7734 { Microsoft-Publishing csMicrosoftPublishing }
7735 { Windows-31J csWindows31J }
7736 { GB2312 csGB2312 }
7737 { Big5 csBig5 }
7740 proc tcl_encoding {enc} {
7741 global encoding_aliases
7742 set names [encoding names]
7743 set lcnames [string tolower $names]
7744 set enc [string tolower $enc]
7745 set i [lsearch -exact $lcnames $enc]
7746 if {$i < 0} {
7747 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7748 if {[regsub {^iso[-_]} $enc iso encx]} {
7749 set i [lsearch -exact $lcnames $encx]
7752 if {$i < 0} {
7753 foreach l $encoding_aliases {
7754 set ll [string tolower $l]
7755 if {[lsearch -exact $ll $enc] < 0} continue
7756 # look through the aliases for one that tcl knows about
7757 foreach e $ll {
7758 set i [lsearch -exact $lcnames $e]
7759 if {$i < 0} {
7760 if {[regsub {^iso[-_]} $e iso ex]} {
7761 set i [lsearch -exact $lcnames $ex]
7764 if {$i >= 0} break
7766 break
7769 if {$i >= 0} {
7770 return [lindex $names $i]
7772 return {}
7775 # defaults...
7776 set datemode 0
7777 set diffopts "-U 5 -p"
7778 set wrcomcmd "git diff-tree --stdin -p --pretty"
7780 set gitencoding {}
7781 catch {
7782 set gitencoding [exec git config --get i18n.commitencoding]
7784 if {$gitencoding == ""} {
7785 set gitencoding "utf-8"
7787 set tclencoding [tcl_encoding $gitencoding]
7788 if {$tclencoding == {}} {
7789 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7792 set mainfont {Helvetica 9}
7793 set textfont {Courier 9}
7794 set uifont {Helvetica 9 bold}
7795 set tabstop 8
7796 set findmergefiles 0
7797 set maxgraphpct 50
7798 set maxwidth 16
7799 set revlistorder 0
7800 set fastdate 0
7801 set uparrowlen 5
7802 set downarrowlen 5
7803 set mingaplen 100
7804 set cmitmode "patch"
7805 set wrapcomment "none"
7806 set showneartags 1
7807 set maxrefs 20
7808 set maxlinelen 200
7809 set showlocalchanges 1
7810 set datetimeformat "%Y-%m-%d %H:%M:%S"
7812 set colors {green red blue magenta darkgrey brown orange}
7813 set bgcolor white
7814 set fgcolor black
7815 set diffcolors {red "#00a000" blue}
7816 set diffcontext 3
7817 set selectbgcolor gray85
7819 catch {source ~/.gitk}
7821 font create optionfont -family sans-serif -size -12
7823 # check that we can find a .git directory somewhere...
7824 if {[catch {set gitdir [gitdir]}]} {
7825 show_error {} . "Cannot find a git repository here."
7826 exit 1
7828 if {![file isdirectory $gitdir]} {
7829 show_error {} . "Cannot find the git directory \"$gitdir\"."
7830 exit 1
7833 set revtreeargs {}
7834 set cmdline_files {}
7835 set i 0
7836 foreach arg $argv {
7837 switch -- $arg {
7838 "" { }
7839 "-d" { set datemode 1 }
7840 "--" {
7841 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7842 break
7844 default {
7845 lappend revtreeargs $arg
7848 incr i
7851 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7852 # no -- on command line, but some arguments (other than -d)
7853 if {[catch {
7854 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7855 set cmdline_files [split $f "\n"]
7856 set n [llength $cmdline_files]
7857 set revtreeargs [lrange $revtreeargs 0 end-$n]
7858 # Unfortunately git rev-parse doesn't produce an error when
7859 # something is both a revision and a filename. To be consistent
7860 # with git log and git rev-list, check revtreeargs for filenames.
7861 foreach arg $revtreeargs {
7862 if {[file exists $arg]} {
7863 show_error {} . "Ambiguous argument '$arg': both revision\
7864 and filename"
7865 exit 1
7868 } err]} {
7869 # unfortunately we get both stdout and stderr in $err,
7870 # so look for "fatal:".
7871 set i [string first "fatal:" $err]
7872 if {$i > 0} {
7873 set err [string range $err [expr {$i + 6}] end]
7875 show_error {} . "Bad arguments to gitk:\n$err"
7876 exit 1
7880 set nullid "0000000000000000000000000000000000000000"
7881 set nullid2 "0000000000000000000000000000000000000001"
7884 set runq {}
7885 set history {}
7886 set historyindex 0
7887 set fh_serial 0
7888 set nhl_names {}
7889 set highlight_paths {}
7890 set searchdirn -forwards
7891 set boldrows {}
7892 set boldnamerows {}
7893 set diffelide {0 0}
7894 set markingmatches 0
7896 set optim_delay 16
7898 set nextviewnum 1
7899 set curview 0
7900 set selectedview 0
7901 set selectedhlview None
7902 set viewfiles(0) {}
7903 set viewperm(0) 0
7904 set viewargs(0) {}
7906 set cmdlineok 0
7907 set stopped 0
7908 set stuffsaved 0
7909 set patchnum 0
7910 set lookingforhead 0
7911 set localirow -1
7912 set localfrow -1
7913 set lserial 0
7914 setcoords
7915 makewindow
7916 # wait for the window to become visible
7917 tkwait visibility .
7918 wm title . "[file tail $argv0]: [file tail [pwd]]"
7919 readrefs
7921 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7922 # create a view for the files/dirs specified on the command line
7923 set curview 1
7924 set selectedview 1
7925 set nextviewnum 2
7926 set viewname(1) "Command line"
7927 set viewfiles(1) $cmdline_files
7928 set viewargs(1) $revtreeargs
7929 set viewperm(1) 0
7930 addviewmenu 1
7931 .bar.view entryconf Edit* -state normal
7932 .bar.view entryconf Delete* -state normal
7935 if {[info exists permviews]} {
7936 foreach v $permviews {
7937 set n $nextviewnum
7938 incr nextviewnum
7939 set viewname($n) [lindex $v 0]
7940 set viewfiles($n) [lindex $v 1]
7941 set viewargs($n) [lindex $v 2]
7942 set viewperm($n) 1
7943 addviewmenu $n
7946 getcommits