libgit-thin: Update QUESTIONS file
[git/libgit-gsoc.git] / gitk
blobf74ce513795bb90fe3a96dd7da0dc98a2e6e1aa6
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc dorunq {} {
51 global isonrunq runq
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
76 if {$runq ne {}} {
77 after idle dorunq
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set order "--topo-order"
91 if {$datemode} {
92 set order "--date-order"
94 if {[catch {
95 set fd [open [concat | git log -z --pretty=raw $order --parents \
96 --boundary $viewargs($view) "--" $viewfiles($view)] r]
97 } err]} {
98 error_popup "Error executing git rev-list: $err"
99 exit 1
101 set commfd($view) $fd
102 set leftover($view) {}
103 set lookingforhead $showlocalchanges
104 fconfigure $fd -blocking 0 -translation lf -eofchar {}
105 if {$tclencoding != {}} {
106 fconfigure $fd -encoding $tclencoding
108 filerun $fd [list getcommitlines $fd $view]
109 nowbusy $view
112 proc stop_rev_list {} {
113 global commfd curview
115 if {![info exists commfd($curview)]} return
116 set fd $commfd($curview)
117 catch {
118 set pid [pid $fd]
119 exec kill $pid
121 catch {close $fd}
122 unset commfd($curview)
125 proc getcommits {} {
126 global phase canv mainfont curview
128 set phase getcommits
129 initlayout
130 start_rev_list $curview
131 show_status "Reading commits..."
134 proc getcommitlines {fd view} {
135 global commitlisted
136 global leftover commfd
137 global displayorder commitidx commitrow commitdata
138 global parentlist children curview hlview
139 global vparentlist vdisporder vcmitlisted
141 set stuff [read $fd 500000]
142 # git log doesn't terminate the last commit with a null...
143 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
144 set stuff "\0"
146 if {$stuff == {}} {
147 if {![eof $fd]} {
148 return 1
150 global viewname
151 unset commfd($view)
152 notbusy $view
153 # set it blocking so we wait for the process to terminate
154 fconfigure $fd -blocking 1
155 if {[catch {close $fd} err]} {
156 set fv {}
157 if {$view != $curview} {
158 set fv " for the \"$viewname($view)\" view"
160 if {[string range $err 0 4] == "usage"} {
161 set err "Gitk: error reading commits$fv:\
162 bad arguments to git rev-list."
163 if {$viewname($view) eq "Command line"} {
164 append err \
165 " (Note: arguments to gitk are passed to git rev-list\
166 to allow selection of commits to be displayed.)"
168 } else {
169 set err "Error reading commits$fv: $err"
171 error_popup $err
173 if {$view == $curview} {
174 run chewcommits $view
176 return 0
178 set start 0
179 set gotsome 0
180 while 1 {
181 set i [string first "\0" $stuff $start]
182 if {$i < 0} {
183 append leftover($view) [string range $stuff $start end]
184 break
186 if {$start == 0} {
187 set cmit $leftover($view)
188 append cmit [string range $stuff 0 [expr {$i - 1}]]
189 set leftover($view) {}
190 } else {
191 set cmit [string range $stuff $start [expr {$i - 1}]]
193 set start [expr {$i + 1}]
194 set j [string first "\n" $cmit]
195 set ok 0
196 set listed 1
197 if {$j >= 0 && [string match "commit *" $cmit]} {
198 set ids [string range $cmit 7 [expr {$j - 1}]]
199 if {[string match {[-<>]*} $ids]} {
200 switch -- [string index $ids 0] {
201 "-" {set listed 0}
202 "<" {set listed 2}
203 ">" {set listed 3}
205 set ids [string range $ids 1 end]
207 set ok 1
208 foreach id $ids {
209 if {[string length $id] != 40} {
210 set ok 0
211 break
215 if {!$ok} {
216 set shortcmit $cmit
217 if {[string length $shortcmit] > 80} {
218 set shortcmit "[string range $shortcmit 0 80]..."
220 error_popup "Can't parse git log output: {$shortcmit}"
221 exit 1
223 set id [lindex $ids 0]
224 if {$listed} {
225 set olds [lrange $ids 1 end]
226 set i 0
227 foreach p $olds {
228 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
229 lappend children($view,$p) $id
231 incr i
233 } else {
234 set olds {}
236 if {![info exists children($view,$id)]} {
237 set children($view,$id) {}
239 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
240 set commitrow($view,$id) $commitidx($view)
241 incr commitidx($view)
242 if {$view == $curview} {
243 lappend parentlist $olds
244 lappend displayorder $id
245 lappend commitlisted $listed
246 } else {
247 lappend vparentlist($view) $olds
248 lappend vdisporder($view) $id
249 lappend vcmitlisted($view) $listed
251 set gotsome 1
253 if {$gotsome} {
254 run chewcommits $view
256 return 2
259 proc chewcommits {view} {
260 global curview hlview commfd
261 global selectedline pending_select
263 set more 0
264 if {$view == $curview} {
265 set allread [expr {![info exists commfd($view)]}]
266 set tlimit [expr {[clock clicks -milliseconds] + 50}]
267 set more [layoutmore $tlimit $allread]
268 if {$allread && !$more} {
269 global displayorder commitidx phase
270 global numcommits startmsecs
272 if {[info exists pending_select]} {
273 set row [first_real_row]
274 selectline $row 1
276 if {$commitidx($curview) > 0} {
277 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
278 #puts "overall $ms ms for $numcommits commits"
279 } else {
280 show_status "No commits selected"
282 notbusy layout
283 set phase {}
286 if {[info exists hlview] && $view == $hlview} {
287 vhighlightmore
289 return $more
292 proc readcommit {id} {
293 if {[catch {set contents [exec git cat-file commit $id]}]} return
294 parsecommit $id $contents 0
297 proc updatecommits {} {
298 global viewdata curview phase displayorder
299 global children commitrow selectedline thickerline
301 if {$phase ne {}} {
302 stop_rev_list
303 set phase {}
305 set n $curview
306 foreach id $displayorder {
307 catch {unset children($n,$id)}
308 catch {unset commitrow($n,$id)}
310 set curview -1
311 catch {unset selectedline}
312 catch {unset thickerline}
313 catch {unset viewdata($n)}
314 readrefs
315 changedrefs
316 regetallcommits
317 showview $n
320 proc parsecommit {id contents listed} {
321 global commitinfo cdate
323 set inhdr 1
324 set comment {}
325 set headline {}
326 set auname {}
327 set audate {}
328 set comname {}
329 set comdate {}
330 set hdrend [string first "\n\n" $contents]
331 if {$hdrend < 0} {
332 # should never happen...
333 set hdrend [string length $contents]
335 set header [string range $contents 0 [expr {$hdrend - 1}]]
336 set comment [string range $contents [expr {$hdrend + 2}] end]
337 foreach line [split $header "\n"] {
338 set tag [lindex $line 0]
339 if {$tag == "author"} {
340 set audate [lindex $line end-1]
341 set auname [lrange $line 1 end-2]
342 } elseif {$tag == "committer"} {
343 set comdate [lindex $line end-1]
344 set comname [lrange $line 1 end-2]
347 set headline {}
348 # take the first non-blank line of the comment as the headline
349 set headline [string trimleft $comment]
350 set i [string first "\n" $headline]
351 if {$i >= 0} {
352 set headline [string range $headline 0 $i]
354 set headline [string trimright $headline]
355 set i [string first "\r" $headline]
356 if {$i >= 0} {
357 set headline [string trimright [string range $headline 0 $i]]
359 if {!$listed} {
360 # git rev-list indents the comment by 4 spaces;
361 # if we got this via git cat-file, add the indentation
362 set newcomment {}
363 foreach line [split $comment "\n"] {
364 append newcomment " "
365 append newcomment $line
366 append newcomment "\n"
368 set comment $newcomment
370 if {$comdate != {}} {
371 set cdate($id) $comdate
373 set commitinfo($id) [list $headline $auname $audate \
374 $comname $comdate $comment]
377 proc getcommit {id} {
378 global commitdata commitinfo
380 if {[info exists commitdata($id)]} {
381 parsecommit $id $commitdata($id) 1
382 } else {
383 readcommit $id
384 if {![info exists commitinfo($id)]} {
385 set commitinfo($id) {"No commit information available"}
388 return 1
391 proc readrefs {} {
392 global tagids idtags headids idheads tagobjid
393 global otherrefids idotherrefs mainhead mainheadid
395 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
396 catch {unset $v}
398 set refd [open [list | git show-ref -d] r]
399 while {[gets $refd line] >= 0} {
400 if {[string index $line 40] ne " "} continue
401 set id [string range $line 0 39]
402 set ref [string range $line 41 end]
403 if {![string match "refs/*" $ref]} continue
404 set name [string range $ref 5 end]
405 if {[string match "remotes/*" $name]} {
406 if {![string match "*/HEAD" $name]} {
407 set headids($name) $id
408 lappend idheads($id) $name
410 } elseif {[string match "heads/*" $name]} {
411 set name [string range $name 6 end]
412 set headids($name) $id
413 lappend idheads($id) $name
414 } elseif {[string match "tags/*" $name]} {
415 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
416 # which is what we want since the former is the commit ID
417 set name [string range $name 5 end]
418 if {[string match "*^{}" $name]} {
419 set name [string range $name 0 end-3]
420 } else {
421 set tagobjid($name) $id
423 set tagids($name) $id
424 lappend idtags($id) $name
425 } else {
426 set otherrefids($name) $id
427 lappend idotherrefs($id) $name
430 close $refd
431 set mainhead {}
432 set mainheadid {}
433 catch {
434 set thehead [exec git symbolic-ref HEAD]
435 if {[string match "refs/heads/*" $thehead]} {
436 set mainhead [string range $thehead 11 end]
437 if {[info exists headids($mainhead)]} {
438 set mainheadid $headids($mainhead)
444 # skip over fake commits
445 proc first_real_row {} {
446 global nullid nullid2 displayorder numcommits
448 for {set row 0} {$row < $numcommits} {incr row} {
449 set id [lindex $displayorder $row]
450 if {$id ne $nullid && $id ne $nullid2} {
451 break
454 return $row
457 # update things for a head moved to a child of its previous location
458 proc movehead {id name} {
459 global headids idheads
461 removehead $headids($name) $name
462 set headids($name) $id
463 lappend idheads($id) $name
466 # update things when a head has been removed
467 proc removehead {id name} {
468 global headids idheads
470 if {$idheads($id) eq $name} {
471 unset idheads($id)
472 } else {
473 set i [lsearch -exact $idheads($id) $name]
474 if {$i >= 0} {
475 set idheads($id) [lreplace $idheads($id) $i $i]
478 unset headids($name)
481 proc show_error {w top msg} {
482 message $w.m -text $msg -justify center -aspect 400
483 pack $w.m -side top -fill x -padx 20 -pady 20
484 button $w.ok -text OK -command "destroy $top"
485 pack $w.ok -side bottom -fill x
486 bind $top <Visibility> "grab $top; focus $top"
487 bind $top <Key-Return> "destroy $top"
488 tkwait window $top
491 proc error_popup msg {
492 set w .error
493 toplevel $w
494 wm transient $w .
495 show_error $w $w $msg
498 proc confirm_popup msg {
499 global confirm_ok
500 set confirm_ok 0
501 set w .confirm
502 toplevel $w
503 wm transient $w .
504 message $w.m -text $msg -justify center -aspect 400
505 pack $w.m -side top -fill x -padx 20 -pady 20
506 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
507 pack $w.ok -side left -fill x
508 button $w.cancel -text Cancel -command "destroy $w"
509 pack $w.cancel -side right -fill x
510 bind $w <Visibility> "grab $w; focus $w"
511 tkwait window $w
512 return $confirm_ok
515 proc makewindow {} {
516 global canv canv2 canv3 linespc charspc ctext cflist
517 global textfont mainfont uifont tabstop
518 global findtype findtypemenu findloc findstring fstring geometry
519 global entries sha1entry sha1string sha1but
520 global maincursor textcursor curtextcursor
521 global rowctxmenu fakerowmenu mergemax wrapcomment
522 global highlight_files gdttype
523 global searchstring sstring
524 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
525 global headctxmenu
527 menu .bar
528 .bar add cascade -label "File" -menu .bar.file
529 .bar configure -font $uifont
530 menu .bar.file
531 .bar.file add command -label "Update" -command updatecommits
532 .bar.file add command -label "Reread references" -command rereadrefs
533 .bar.file add command -label "Quit" -command doquit
534 .bar.file configure -font $uifont
535 menu .bar.edit
536 .bar add cascade -label "Edit" -menu .bar.edit
537 .bar.edit add command -label "Preferences" -command doprefs
538 .bar.edit configure -font $uifont
540 menu .bar.view -font $uifont
541 .bar add cascade -label "View" -menu .bar.view
542 .bar.view add command -label "New view..." -command {newview 0}
543 .bar.view add command -label "Edit view..." -command editview \
544 -state disabled
545 .bar.view add command -label "Delete view" -command delview -state disabled
546 .bar.view add separator
547 .bar.view add radiobutton -label "All files" -command {showview 0} \
548 -variable selectedview -value 0
550 menu .bar.help
551 .bar add cascade -label "Help" -menu .bar.help
552 .bar.help add command -label "About gitk" -command about
553 .bar.help add command -label "Key bindings" -command keys
554 .bar.help configure -font $uifont
555 . configure -menu .bar
557 # the gui has upper and lower half, parts of a paned window.
558 panedwindow .ctop -orient vertical
560 # possibly use assumed geometry
561 if {![info exists geometry(pwsash0)]} {
562 set geometry(topheight) [expr {15 * $linespc}]
563 set geometry(topwidth) [expr {80 * $charspc}]
564 set geometry(botheight) [expr {15 * $linespc}]
565 set geometry(botwidth) [expr {50 * $charspc}]
566 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
567 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
570 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
571 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
572 frame .tf.histframe
573 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
575 # create three canvases
576 set cscroll .tf.histframe.csb
577 set canv .tf.histframe.pwclist.canv
578 canvas $canv \
579 -selectbackground $selectbgcolor \
580 -background $bgcolor -bd 0 \
581 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
582 .tf.histframe.pwclist add $canv
583 set canv2 .tf.histframe.pwclist.canv2
584 canvas $canv2 \
585 -selectbackground $selectbgcolor \
586 -background $bgcolor -bd 0 -yscrollincr $linespc
587 .tf.histframe.pwclist add $canv2
588 set canv3 .tf.histframe.pwclist.canv3
589 canvas $canv3 \
590 -selectbackground $selectbgcolor \
591 -background $bgcolor -bd 0 -yscrollincr $linespc
592 .tf.histframe.pwclist add $canv3
593 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
594 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
596 # a scroll bar to rule them
597 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
598 pack $cscroll -side right -fill y
599 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
600 lappend bglist $canv $canv2 $canv3
601 pack .tf.histframe.pwclist -fill both -expand 1 -side left
603 # we have two button bars at bottom of top frame. Bar 1
604 frame .tf.bar
605 frame .tf.lbar -height 15
607 set sha1entry .tf.bar.sha1
608 set entries $sha1entry
609 set sha1but .tf.bar.sha1label
610 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
611 -command gotocommit -width 8 -font $uifont
612 $sha1but conf -disabledforeground [$sha1but cget -foreground]
613 pack .tf.bar.sha1label -side left
614 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
615 trace add variable sha1string write sha1change
616 pack $sha1entry -side left -pady 2
618 image create bitmap bm-left -data {
619 #define left_width 16
620 #define left_height 16
621 static unsigned char left_bits[] = {
622 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
623 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
624 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
626 image create bitmap bm-right -data {
627 #define right_width 16
628 #define right_height 16
629 static unsigned char right_bits[] = {
630 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
631 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
632 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
634 button .tf.bar.leftbut -image bm-left -command goback \
635 -state disabled -width 26
636 pack .tf.bar.leftbut -side left -fill y
637 button .tf.bar.rightbut -image bm-right -command goforw \
638 -state disabled -width 26
639 pack .tf.bar.rightbut -side left -fill y
641 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
642 pack .tf.bar.findbut -side left
643 set findstring {}
644 set fstring .tf.bar.findstring
645 lappend entries $fstring
646 entry $fstring -width 30 -font $textfont -textvariable findstring
647 trace add variable findstring write find_change
648 pack $fstring -side left -expand 1 -fill x -in .tf.bar
649 set findtype Exact
650 set findtypemenu [tk_optionMenu .tf.bar.findtype \
651 findtype Exact IgnCase Regexp]
652 trace add variable findtype write find_change
653 .tf.bar.findtype configure -font $uifont
654 .tf.bar.findtype.menu configure -font $uifont
655 set findloc "All fields"
656 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
657 Comments Author Committer
658 trace add variable findloc write find_change
659 .tf.bar.findloc configure -font $uifont
660 .tf.bar.findloc.menu configure -font $uifont
661 pack .tf.bar.findloc -side right
662 pack .tf.bar.findtype -side right
664 # build up the bottom bar of upper window
665 label .tf.lbar.flabel -text "Highlight: Commits " \
666 -font $uifont
667 pack .tf.lbar.flabel -side left -fill y
668 set gdttype "touching paths:"
669 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
670 "adding/removing string:"]
671 trace add variable gdttype write hfiles_change
672 $gm conf -font $uifont
673 .tf.lbar.gdttype conf -font $uifont
674 pack .tf.lbar.gdttype -side left -fill y
675 entry .tf.lbar.fent -width 25 -font $textfont \
676 -textvariable highlight_files
677 trace add variable highlight_files write hfiles_change
678 lappend entries .tf.lbar.fent
679 pack .tf.lbar.fent -side left -fill x -expand 1
680 label .tf.lbar.vlabel -text " OR in view" -font $uifont
681 pack .tf.lbar.vlabel -side left -fill y
682 global viewhlmenu selectedhlview
683 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
684 $viewhlmenu entryconf None -command delvhighlight
685 $viewhlmenu conf -font $uifont
686 .tf.lbar.vhl conf -font $uifont
687 pack .tf.lbar.vhl -side left -fill y
688 label .tf.lbar.rlabel -text " OR " -font $uifont
689 pack .tf.lbar.rlabel -side left -fill y
690 global highlight_related
691 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
692 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
693 $m conf -font $uifont
694 .tf.lbar.relm conf -font $uifont
695 trace add variable highlight_related write vrel_change
696 pack .tf.lbar.relm -side left -fill y
698 # Finish putting the upper half of the viewer together
699 pack .tf.lbar -in .tf -side bottom -fill x
700 pack .tf.bar -in .tf -side bottom -fill x
701 pack .tf.histframe -fill both -side top -expand 1
702 .ctop add .tf
703 .ctop paneconfigure .tf -height $geometry(topheight)
704 .ctop paneconfigure .tf -width $geometry(topwidth)
706 # now build up the bottom
707 panedwindow .pwbottom -orient horizontal
709 # lower left, a text box over search bar, scroll bar to the right
710 # if we know window height, then that will set the lower text height, otherwise
711 # we set lower text height which will drive window height
712 if {[info exists geometry(main)]} {
713 frame .bleft -width $geometry(botwidth)
714 } else {
715 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
717 frame .bleft.top
718 frame .bleft.mid
720 button .bleft.top.search -text "Search" -command dosearch \
721 -font $uifont
722 pack .bleft.top.search -side left -padx 5
723 set sstring .bleft.top.sstring
724 entry $sstring -width 20 -font $textfont -textvariable searchstring
725 lappend entries $sstring
726 trace add variable searchstring write incrsearch
727 pack $sstring -side left -expand 1 -fill x
728 radiobutton .bleft.mid.diff -text "Diff" \
729 -command changediffdisp -variable diffelide -value {0 0}
730 radiobutton .bleft.mid.old -text "Old version" \
731 -command changediffdisp -variable diffelide -value {0 1}
732 radiobutton .bleft.mid.new -text "New version" \
733 -command changediffdisp -variable diffelide -value {1 0}
734 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
735 set ctext .bleft.ctext
736 text $ctext -background $bgcolor -foreground $fgcolor \
737 -tabs "[expr {$tabstop * $charspc}]" \
738 -state disabled -font $textfont \
739 -yscrollcommand scrolltext -wrap none
740 scrollbar .bleft.sb -command "$ctext yview"
741 pack .bleft.top -side top -fill x
742 pack .bleft.mid -side top -fill x
743 pack .bleft.sb -side right -fill y
744 pack $ctext -side left -fill both -expand 1
745 lappend bglist $ctext
746 lappend fglist $ctext
748 $ctext tag conf comment -wrap $wrapcomment
749 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
750 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
751 $ctext tag conf d0 -fore [lindex $diffcolors 0]
752 $ctext tag conf d1 -fore [lindex $diffcolors 1]
753 $ctext tag conf m0 -fore red
754 $ctext tag conf m1 -fore blue
755 $ctext tag conf m2 -fore green
756 $ctext tag conf m3 -fore purple
757 $ctext tag conf m4 -fore brown
758 $ctext tag conf m5 -fore "#009090"
759 $ctext tag conf m6 -fore magenta
760 $ctext tag conf m7 -fore "#808000"
761 $ctext tag conf m8 -fore "#009000"
762 $ctext tag conf m9 -fore "#ff0080"
763 $ctext tag conf m10 -fore cyan
764 $ctext tag conf m11 -fore "#b07070"
765 $ctext tag conf m12 -fore "#70b0f0"
766 $ctext tag conf m13 -fore "#70f0b0"
767 $ctext tag conf m14 -fore "#f0b070"
768 $ctext tag conf m15 -fore "#ff70b0"
769 $ctext tag conf mmax -fore darkgrey
770 set mergemax 16
771 $ctext tag conf mresult -font [concat $textfont bold]
772 $ctext tag conf msep -font [concat $textfont bold]
773 $ctext tag conf found -back yellow
775 .pwbottom add .bleft
776 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
778 # lower right
779 frame .bright
780 frame .bright.mode
781 radiobutton .bright.mode.patch -text "Patch" \
782 -command reselectline -variable cmitmode -value "patch"
783 .bright.mode.patch configure -font $uifont
784 radiobutton .bright.mode.tree -text "Tree" \
785 -command reselectline -variable cmitmode -value "tree"
786 .bright.mode.tree configure -font $uifont
787 grid .bright.mode.patch .bright.mode.tree -sticky ew
788 pack .bright.mode -side top -fill x
789 set cflist .bright.cfiles
790 set indent [font measure $mainfont "nn"]
791 text $cflist \
792 -selectbackground $selectbgcolor \
793 -background $bgcolor -foreground $fgcolor \
794 -font $mainfont \
795 -tabs [list $indent [expr {2 * $indent}]] \
796 -yscrollcommand ".bright.sb set" \
797 -cursor [. cget -cursor] \
798 -spacing1 1 -spacing3 1
799 lappend bglist $cflist
800 lappend fglist $cflist
801 scrollbar .bright.sb -command "$cflist yview"
802 pack .bright.sb -side right -fill y
803 pack $cflist -side left -fill both -expand 1
804 $cflist tag configure highlight \
805 -background [$cflist cget -selectbackground]
806 $cflist tag configure bold -font [concat $mainfont bold]
808 .pwbottom add .bright
809 .ctop add .pwbottom
811 # restore window position if known
812 if {[info exists geometry(main)]} {
813 wm geometry . "$geometry(main)"
816 if {[tk windowingsystem] eq {aqua}} {
817 set M1B M1
818 } else {
819 set M1B Control
822 bind .pwbottom <Configure> {resizecdetpanes %W %w}
823 pack .ctop -fill both -expand 1
824 bindall <1> {selcanvline %W %x %y}
825 #bindall <B1-Motion> {selcanvline %W %x %y}
826 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
827 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
828 bindall <2> "canvscan mark %W %x %y"
829 bindall <B2-Motion> "canvscan dragto %W %x %y"
830 bindkey <Home> selfirstline
831 bindkey <End> sellastline
832 bind . <Key-Up> "selnextline -1"
833 bind . <Key-Down> "selnextline 1"
834 bind . <Shift-Key-Up> "next_highlight -1"
835 bind . <Shift-Key-Down> "next_highlight 1"
836 bindkey <Key-Right> "goforw"
837 bindkey <Key-Left> "goback"
838 bind . <Key-Prior> "selnextpage -1"
839 bind . <Key-Next> "selnextpage 1"
840 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
841 bind . <$M1B-End> "allcanvs yview moveto 1.0"
842 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
843 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
844 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
845 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
846 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
847 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
848 bindkey <Key-space> "$ctext yview scroll 1 pages"
849 bindkey p "selnextline -1"
850 bindkey n "selnextline 1"
851 bindkey z "goback"
852 bindkey x "goforw"
853 bindkey i "selnextline -1"
854 bindkey k "selnextline 1"
855 bindkey j "goback"
856 bindkey l "goforw"
857 bindkey b "$ctext yview scroll -1 pages"
858 bindkey d "$ctext yview scroll 18 units"
859 bindkey u "$ctext yview scroll -18 units"
860 bindkey / {findnext 1}
861 bindkey <Key-Return> {findnext 0}
862 bindkey ? findprev
863 bindkey f nextfile
864 bindkey <F5> updatecommits
865 bind . <$M1B-q> doquit
866 bind . <$M1B-f> dofind
867 bind . <$M1B-g> {findnext 0}
868 bind . <$M1B-r> dosearchback
869 bind . <$M1B-s> dosearch
870 bind . <$M1B-equal> {incrfont 1}
871 bind . <$M1B-KP_Add> {incrfont 1}
872 bind . <$M1B-minus> {incrfont -1}
873 bind . <$M1B-KP_Subtract> {incrfont -1}
874 wm protocol . WM_DELETE_WINDOW doquit
875 bind . <Button-1> "click %W"
876 bind $fstring <Key-Return> dofind
877 bind $sha1entry <Key-Return> gotocommit
878 bind $sha1entry <<PasteSelection>> clearsha1
879 bind $cflist <1> {sel_flist %W %x %y; break}
880 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
881 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
883 set maincursor [. cget -cursor]
884 set textcursor [$ctext cget -cursor]
885 set curtextcursor $textcursor
887 set rowctxmenu .rowctxmenu
888 menu $rowctxmenu -tearoff 0
889 $rowctxmenu add command -label "Diff this -> selected" \
890 -command {diffvssel 0}
891 $rowctxmenu add command -label "Diff selected -> this" \
892 -command {diffvssel 1}
893 $rowctxmenu add command -label "Make patch" -command mkpatch
894 $rowctxmenu add command -label "Create tag" -command mktag
895 $rowctxmenu add command -label "Write commit to file" -command writecommit
896 $rowctxmenu add command -label "Create new branch" -command mkbranch
897 $rowctxmenu add command -label "Cherry-pick this commit" \
898 -command cherrypick
899 $rowctxmenu add command -label "Reset HEAD branch to here" \
900 -command resethead
902 set fakerowmenu .fakerowmenu
903 menu $fakerowmenu -tearoff 0
904 $fakerowmenu add command -label "Diff this -> selected" \
905 -command {diffvssel 0}
906 $fakerowmenu add command -label "Diff selected -> this" \
907 -command {diffvssel 1}
908 $fakerowmenu add command -label "Make patch" -command mkpatch
909 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
910 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
911 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
913 set headctxmenu .headctxmenu
914 menu $headctxmenu -tearoff 0
915 $headctxmenu add command -label "Check out this branch" \
916 -command cobranch
917 $headctxmenu add command -label "Remove this branch" \
918 -command rmbranch
921 # mouse-2 makes all windows scan vertically, but only the one
922 # the cursor is in scans horizontally
923 proc canvscan {op w x y} {
924 global canv canv2 canv3
925 foreach c [list $canv $canv2 $canv3] {
926 if {$c == $w} {
927 $c scan $op $x $y
928 } else {
929 $c scan $op 0 $y
934 proc scrollcanv {cscroll f0 f1} {
935 $cscroll set $f0 $f1
936 drawfrac $f0 $f1
937 flushhighlights
940 # when we make a key binding for the toplevel, make sure
941 # it doesn't get triggered when that key is pressed in the
942 # find string entry widget.
943 proc bindkey {ev script} {
944 global entries
945 bind . $ev $script
946 set escript [bind Entry $ev]
947 if {$escript == {}} {
948 set escript [bind Entry <Key>]
950 foreach e $entries {
951 bind $e $ev "$escript; break"
955 # set the focus back to the toplevel for any click outside
956 # the entry widgets
957 proc click {w} {
958 global entries
959 foreach e $entries {
960 if {$w == $e} return
962 focus .
965 proc savestuff {w} {
966 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
967 global stuffsaved findmergefiles maxgraphpct
968 global maxwidth showneartags showlocalchanges
969 global viewname viewfiles viewargs viewperm nextviewnum
970 global cmitmode wrapcomment
971 global colors bgcolor fgcolor diffcolors selectbgcolor
973 if {$stuffsaved} return
974 if {![winfo viewable .]} return
975 catch {
976 set f [open "~/.gitk-new" w]
977 puts $f [list set mainfont $mainfont]
978 puts $f [list set textfont $textfont]
979 puts $f [list set uifont $uifont]
980 puts $f [list set tabstop $tabstop]
981 puts $f [list set findmergefiles $findmergefiles]
982 puts $f [list set maxgraphpct $maxgraphpct]
983 puts $f [list set maxwidth $maxwidth]
984 puts $f [list set cmitmode $cmitmode]
985 puts $f [list set wrapcomment $wrapcomment]
986 puts $f [list set showneartags $showneartags]
987 puts $f [list set showlocalchanges $showlocalchanges]
988 puts $f [list set bgcolor $bgcolor]
989 puts $f [list set fgcolor $fgcolor]
990 puts $f [list set colors $colors]
991 puts $f [list set diffcolors $diffcolors]
992 puts $f [list set selectbgcolor $selectbgcolor]
994 puts $f "set geometry(main) [wm geometry .]"
995 puts $f "set geometry(topwidth) [winfo width .tf]"
996 puts $f "set geometry(topheight) [winfo height .tf]"
997 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
998 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
999 puts $f "set geometry(botwidth) [winfo width .bleft]"
1000 puts $f "set geometry(botheight) [winfo height .bleft]"
1002 puts -nonewline $f "set permviews {"
1003 for {set v 0} {$v < $nextviewnum} {incr v} {
1004 if {$viewperm($v)} {
1005 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1008 puts $f "}"
1009 close $f
1010 file rename -force "~/.gitk-new" "~/.gitk"
1012 set stuffsaved 1
1015 proc resizeclistpanes {win w} {
1016 global oldwidth
1017 if {[info exists oldwidth($win)]} {
1018 set s0 [$win sash coord 0]
1019 set s1 [$win sash coord 1]
1020 if {$w < 60} {
1021 set sash0 [expr {int($w/2 - 2)}]
1022 set sash1 [expr {int($w*5/6 - 2)}]
1023 } else {
1024 set factor [expr {1.0 * $w / $oldwidth($win)}]
1025 set sash0 [expr {int($factor * [lindex $s0 0])}]
1026 set sash1 [expr {int($factor * [lindex $s1 0])}]
1027 if {$sash0 < 30} {
1028 set sash0 30
1030 if {$sash1 < $sash0 + 20} {
1031 set sash1 [expr {$sash0 + 20}]
1033 if {$sash1 > $w - 10} {
1034 set sash1 [expr {$w - 10}]
1035 if {$sash0 > $sash1 - 20} {
1036 set sash0 [expr {$sash1 - 20}]
1040 $win sash place 0 $sash0 [lindex $s0 1]
1041 $win sash place 1 $sash1 [lindex $s1 1]
1043 set oldwidth($win) $w
1046 proc resizecdetpanes {win w} {
1047 global oldwidth
1048 if {[info exists oldwidth($win)]} {
1049 set s0 [$win sash coord 0]
1050 if {$w < 60} {
1051 set sash0 [expr {int($w*3/4 - 2)}]
1052 } else {
1053 set factor [expr {1.0 * $w / $oldwidth($win)}]
1054 set sash0 [expr {int($factor * [lindex $s0 0])}]
1055 if {$sash0 < 45} {
1056 set sash0 45
1058 if {$sash0 > $w - 15} {
1059 set sash0 [expr {$w - 15}]
1062 $win sash place 0 $sash0 [lindex $s0 1]
1064 set oldwidth($win) $w
1067 proc allcanvs args {
1068 global canv canv2 canv3
1069 eval $canv $args
1070 eval $canv2 $args
1071 eval $canv3 $args
1074 proc bindall {event action} {
1075 global canv canv2 canv3
1076 bind $canv $event $action
1077 bind $canv2 $event $action
1078 bind $canv3 $event $action
1081 proc about {} {
1082 global uifont
1083 set w .about
1084 if {[winfo exists $w]} {
1085 raise $w
1086 return
1088 toplevel $w
1089 wm title $w "About gitk"
1090 message $w.m -text {
1091 Gitk - a commit viewer for git
1093 Copyright © 2005-2006 Paul Mackerras
1095 Use and redistribute under the terms of the GNU General Public License} \
1096 -justify center -aspect 400 -border 2 -bg white -relief groove
1097 pack $w.m -side top -fill x -padx 2 -pady 2
1098 $w.m configure -font $uifont
1099 button $w.ok -text Close -command "destroy $w" -default active
1100 pack $w.ok -side bottom
1101 $w.ok configure -font $uifont
1102 bind $w <Visibility> "focus $w.ok"
1103 bind $w <Key-Escape> "destroy $w"
1104 bind $w <Key-Return> "destroy $w"
1107 proc keys {} {
1108 global uifont
1109 set w .keys
1110 if {[winfo exists $w]} {
1111 raise $w
1112 return
1114 if {[tk windowingsystem] eq {aqua}} {
1115 set M1T Cmd
1116 } else {
1117 set M1T Ctrl
1119 toplevel $w
1120 wm title $w "Gitk key bindings"
1121 message $w.m -text "
1122 Gitk key bindings:
1124 <$M1T-Q> Quit
1125 <Home> Move to first commit
1126 <End> Move to last commit
1127 <Up>, p, i Move up one commit
1128 <Down>, n, k Move down one commit
1129 <Left>, z, j Go back in history list
1130 <Right>, x, l Go forward in history list
1131 <PageUp> Move up one page in commit list
1132 <PageDown> Move down one page in commit list
1133 <$M1T-Home> Scroll to top of commit list
1134 <$M1T-End> Scroll to bottom of commit list
1135 <$M1T-Up> Scroll commit list up one line
1136 <$M1T-Down> Scroll commit list down one line
1137 <$M1T-PageUp> Scroll commit list up one page
1138 <$M1T-PageDown> Scroll commit list down one page
1139 <Shift-Up> Move to previous highlighted line
1140 <Shift-Down> Move to next highlighted line
1141 <Delete>, b Scroll diff view up one page
1142 <Backspace> Scroll diff view up one page
1143 <Space> Scroll diff view down one page
1144 u Scroll diff view up 18 lines
1145 d Scroll diff view down 18 lines
1146 <$M1T-F> Find
1147 <$M1T-G> Move to next find hit
1148 <Return> Move to next find hit
1149 / Move to next find hit, or redo find
1150 ? Move to previous find hit
1151 f Scroll diff view to next file
1152 <$M1T-S> Search for next hit in diff view
1153 <$M1T-R> Search for previous hit in diff view
1154 <$M1T-KP+> Increase font size
1155 <$M1T-plus> Increase font size
1156 <$M1T-KP-> Decrease font size
1157 <$M1T-minus> Decrease font size
1158 <F5> Update
1160 -justify left -bg white -border 2 -relief groove
1161 pack $w.m -side top -fill both -padx 2 -pady 2
1162 $w.m configure -font $uifont
1163 button $w.ok -text Close -command "destroy $w" -default active
1164 pack $w.ok -side bottom
1165 $w.ok configure -font $uifont
1166 bind $w <Visibility> "focus $w.ok"
1167 bind $w <Key-Escape> "destroy $w"
1168 bind $w <Key-Return> "destroy $w"
1171 # Procedures for manipulating the file list window at the
1172 # bottom right of the overall window.
1174 proc treeview {w l openlevs} {
1175 global treecontents treediropen treeheight treeparent treeindex
1177 set ix 0
1178 set treeindex() 0
1179 set lev 0
1180 set prefix {}
1181 set prefixend -1
1182 set prefendstack {}
1183 set htstack {}
1184 set ht 0
1185 set treecontents() {}
1186 $w conf -state normal
1187 foreach f $l {
1188 while {[string range $f 0 $prefixend] ne $prefix} {
1189 if {$lev <= $openlevs} {
1190 $w mark set e:$treeindex($prefix) "end -1c"
1191 $w mark gravity e:$treeindex($prefix) left
1193 set treeheight($prefix) $ht
1194 incr ht [lindex $htstack end]
1195 set htstack [lreplace $htstack end end]
1196 set prefixend [lindex $prefendstack end]
1197 set prefendstack [lreplace $prefendstack end end]
1198 set prefix [string range $prefix 0 $prefixend]
1199 incr lev -1
1201 set tail [string range $f [expr {$prefixend+1}] end]
1202 while {[set slash [string first "/" $tail]] >= 0} {
1203 lappend htstack $ht
1204 set ht 0
1205 lappend prefendstack $prefixend
1206 incr prefixend [expr {$slash + 1}]
1207 set d [string range $tail 0 $slash]
1208 lappend treecontents($prefix) $d
1209 set oldprefix $prefix
1210 append prefix $d
1211 set treecontents($prefix) {}
1212 set treeindex($prefix) [incr ix]
1213 set treeparent($prefix) $oldprefix
1214 set tail [string range $tail [expr {$slash+1}] end]
1215 if {$lev <= $openlevs} {
1216 set ht 1
1217 set treediropen($prefix) [expr {$lev < $openlevs}]
1218 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1219 $w mark set d:$ix "end -1c"
1220 $w mark gravity d:$ix left
1221 set str "\n"
1222 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1223 $w insert end $str
1224 $w image create end -align center -image $bm -padx 1 \
1225 -name a:$ix
1226 $w insert end $d [highlight_tag $prefix]
1227 $w mark set s:$ix "end -1c"
1228 $w mark gravity s:$ix left
1230 incr lev
1232 if {$tail ne {}} {
1233 if {$lev <= $openlevs} {
1234 incr ht
1235 set str "\n"
1236 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1237 $w insert end $str
1238 $w insert end $tail [highlight_tag $f]
1240 lappend treecontents($prefix) $tail
1243 while {$htstack ne {}} {
1244 set treeheight($prefix) $ht
1245 incr ht [lindex $htstack end]
1246 set htstack [lreplace $htstack end end]
1247 set prefixend [lindex $prefendstack end]
1248 set prefendstack [lreplace $prefendstack end end]
1249 set prefix [string range $prefix 0 $prefixend]
1251 $w conf -state disabled
1254 proc linetoelt {l} {
1255 global treeheight treecontents
1257 set y 2
1258 set prefix {}
1259 while {1} {
1260 foreach e $treecontents($prefix) {
1261 if {$y == $l} {
1262 return "$prefix$e"
1264 set n 1
1265 if {[string index $e end] eq "/"} {
1266 set n $treeheight($prefix$e)
1267 if {$y + $n > $l} {
1268 append prefix $e
1269 incr y
1270 break
1273 incr y $n
1278 proc highlight_tree {y prefix} {
1279 global treeheight treecontents cflist
1281 foreach e $treecontents($prefix) {
1282 set path $prefix$e
1283 if {[highlight_tag $path] ne {}} {
1284 $cflist tag add bold $y.0 "$y.0 lineend"
1286 incr y
1287 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1288 set y [highlight_tree $y $path]
1291 return $y
1294 proc treeclosedir {w dir} {
1295 global treediropen treeheight treeparent treeindex
1297 set ix $treeindex($dir)
1298 $w conf -state normal
1299 $w delete s:$ix e:$ix
1300 set treediropen($dir) 0
1301 $w image configure a:$ix -image tri-rt
1302 $w conf -state disabled
1303 set n [expr {1 - $treeheight($dir)}]
1304 while {$dir ne {}} {
1305 incr treeheight($dir) $n
1306 set dir $treeparent($dir)
1310 proc treeopendir {w dir} {
1311 global treediropen treeheight treeparent treecontents treeindex
1313 set ix $treeindex($dir)
1314 $w conf -state normal
1315 $w image configure a:$ix -image tri-dn
1316 $w mark set e:$ix s:$ix
1317 $w mark gravity e:$ix right
1318 set lev 0
1319 set str "\n"
1320 set n [llength $treecontents($dir)]
1321 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1322 incr lev
1323 append str "\t"
1324 incr treeheight($x) $n
1326 foreach e $treecontents($dir) {
1327 set de $dir$e
1328 if {[string index $e end] eq "/"} {
1329 set iy $treeindex($de)
1330 $w mark set d:$iy e:$ix
1331 $w mark gravity d:$iy left
1332 $w insert e:$ix $str
1333 set treediropen($de) 0
1334 $w image create e:$ix -align center -image tri-rt -padx 1 \
1335 -name a:$iy
1336 $w insert e:$ix $e [highlight_tag $de]
1337 $w mark set s:$iy e:$ix
1338 $w mark gravity s:$iy left
1339 set treeheight($de) 1
1340 } else {
1341 $w insert e:$ix $str
1342 $w insert e:$ix $e [highlight_tag $de]
1345 $w mark gravity e:$ix left
1346 $w conf -state disabled
1347 set treediropen($dir) 1
1348 set top [lindex [split [$w index @0,0] .] 0]
1349 set ht [$w cget -height]
1350 set l [lindex [split [$w index s:$ix] .] 0]
1351 if {$l < $top} {
1352 $w yview $l.0
1353 } elseif {$l + $n + 1 > $top + $ht} {
1354 set top [expr {$l + $n + 2 - $ht}]
1355 if {$l < $top} {
1356 set top $l
1358 $w yview $top.0
1362 proc treeclick {w x y} {
1363 global treediropen cmitmode ctext cflist cflist_top
1365 if {$cmitmode ne "tree"} return
1366 if {![info exists cflist_top]} return
1367 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1368 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1369 $cflist tag add highlight $l.0 "$l.0 lineend"
1370 set cflist_top $l
1371 if {$l == 1} {
1372 $ctext yview 1.0
1373 return
1375 set e [linetoelt $l]
1376 if {[string index $e end] ne "/"} {
1377 showfile $e
1378 } elseif {$treediropen($e)} {
1379 treeclosedir $w $e
1380 } else {
1381 treeopendir $w $e
1385 proc setfilelist {id} {
1386 global treefilelist cflist
1388 treeview $cflist $treefilelist($id) 0
1391 image create bitmap tri-rt -background black -foreground blue -data {
1392 #define tri-rt_width 13
1393 #define tri-rt_height 13
1394 static unsigned char tri-rt_bits[] = {
1395 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1396 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1397 0x00, 0x00};
1398 } -maskdata {
1399 #define tri-rt-mask_width 13
1400 #define tri-rt-mask_height 13
1401 static unsigned char tri-rt-mask_bits[] = {
1402 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1403 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1404 0x08, 0x00};
1406 image create bitmap tri-dn -background black -foreground blue -data {
1407 #define tri-dn_width 13
1408 #define tri-dn_height 13
1409 static unsigned char tri-dn_bits[] = {
1410 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1411 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1412 0x00, 0x00};
1413 } -maskdata {
1414 #define tri-dn-mask_width 13
1415 #define tri-dn-mask_height 13
1416 static unsigned char tri-dn-mask_bits[] = {
1417 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1418 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1419 0x00, 0x00};
1422 proc init_flist {first} {
1423 global cflist cflist_top selectedline difffilestart
1425 $cflist conf -state normal
1426 $cflist delete 0.0 end
1427 if {$first ne {}} {
1428 $cflist insert end $first
1429 set cflist_top 1
1430 $cflist tag add highlight 1.0 "1.0 lineend"
1431 } else {
1432 catch {unset cflist_top}
1434 $cflist conf -state disabled
1435 set difffilestart {}
1438 proc highlight_tag {f} {
1439 global highlight_paths
1441 foreach p $highlight_paths {
1442 if {[string match $p $f]} {
1443 return "bold"
1446 return {}
1449 proc highlight_filelist {} {
1450 global cmitmode cflist
1452 $cflist conf -state normal
1453 if {$cmitmode ne "tree"} {
1454 set end [lindex [split [$cflist index end] .] 0]
1455 for {set l 2} {$l < $end} {incr l} {
1456 set line [$cflist get $l.0 "$l.0 lineend"]
1457 if {[highlight_tag $line] ne {}} {
1458 $cflist tag add bold $l.0 "$l.0 lineend"
1461 } else {
1462 highlight_tree 2 {}
1464 $cflist conf -state disabled
1467 proc unhighlight_filelist {} {
1468 global cflist
1470 $cflist conf -state normal
1471 $cflist tag remove bold 1.0 end
1472 $cflist conf -state disabled
1475 proc add_flist {fl} {
1476 global cflist
1478 $cflist conf -state normal
1479 foreach f $fl {
1480 $cflist insert end "\n"
1481 $cflist insert end $f [highlight_tag $f]
1483 $cflist conf -state disabled
1486 proc sel_flist {w x y} {
1487 global ctext difffilestart cflist cflist_top cmitmode
1489 if {$cmitmode eq "tree"} return
1490 if {![info exists cflist_top]} return
1491 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1492 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1493 $cflist tag add highlight $l.0 "$l.0 lineend"
1494 set cflist_top $l
1495 if {$l == 1} {
1496 $ctext yview 1.0
1497 } else {
1498 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1502 # Functions for adding and removing shell-type quoting
1504 proc shellquote {str} {
1505 if {![string match "*\['\"\\ \t]*" $str]} {
1506 return $str
1508 if {![string match "*\['\"\\]*" $str]} {
1509 return "\"$str\""
1511 if {![string match "*'*" $str]} {
1512 return "'$str'"
1514 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1517 proc shellarglist {l} {
1518 set str {}
1519 foreach a $l {
1520 if {$str ne {}} {
1521 append str " "
1523 append str [shellquote $a]
1525 return $str
1528 proc shelldequote {str} {
1529 set ret {}
1530 set used -1
1531 while {1} {
1532 incr used
1533 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1534 append ret [string range $str $used end]
1535 set used [string length $str]
1536 break
1538 set first [lindex $first 0]
1539 set ch [string index $str $first]
1540 if {$first > $used} {
1541 append ret [string range $str $used [expr {$first - 1}]]
1542 set used $first
1544 if {$ch eq " " || $ch eq "\t"} break
1545 incr used
1546 if {$ch eq "'"} {
1547 set first [string first "'" $str $used]
1548 if {$first < 0} {
1549 error "unmatched single-quote"
1551 append ret [string range $str $used [expr {$first - 1}]]
1552 set used $first
1553 continue
1555 if {$ch eq "\\"} {
1556 if {$used >= [string length $str]} {
1557 error "trailing backslash"
1559 append ret [string index $str $used]
1560 continue
1562 # here ch == "\""
1563 while {1} {
1564 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1565 error "unmatched double-quote"
1567 set first [lindex $first 0]
1568 set ch [string index $str $first]
1569 if {$first > $used} {
1570 append ret [string range $str $used [expr {$first - 1}]]
1571 set used $first
1573 if {$ch eq "\""} break
1574 incr used
1575 append ret [string index $str $used]
1576 incr used
1579 return [list $used $ret]
1582 proc shellsplit {str} {
1583 set l {}
1584 while {1} {
1585 set str [string trimleft $str]
1586 if {$str eq {}} break
1587 set dq [shelldequote $str]
1588 set n [lindex $dq 0]
1589 set word [lindex $dq 1]
1590 set str [string range $str $n end]
1591 lappend l $word
1593 return $l
1596 # Code to implement multiple views
1598 proc newview {ishighlight} {
1599 global nextviewnum newviewname newviewperm uifont newishighlight
1600 global newviewargs revtreeargs
1602 set newishighlight $ishighlight
1603 set top .gitkview
1604 if {[winfo exists $top]} {
1605 raise $top
1606 return
1608 set newviewname($nextviewnum) "View $nextviewnum"
1609 set newviewperm($nextviewnum) 0
1610 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1611 vieweditor $top $nextviewnum "Gitk view definition"
1614 proc editview {} {
1615 global curview
1616 global viewname viewperm newviewname newviewperm
1617 global viewargs newviewargs
1619 set top .gitkvedit-$curview
1620 if {[winfo exists $top]} {
1621 raise $top
1622 return
1624 set newviewname($curview) $viewname($curview)
1625 set newviewperm($curview) $viewperm($curview)
1626 set newviewargs($curview) [shellarglist $viewargs($curview)]
1627 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1630 proc vieweditor {top n title} {
1631 global newviewname newviewperm viewfiles
1632 global uifont
1634 toplevel $top
1635 wm title $top $title
1636 label $top.nl -text "Name" -font $uifont
1637 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1638 grid $top.nl $top.name -sticky w -pady 5
1639 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1640 -font $uifont
1641 grid $top.perm - -pady 5 -sticky w
1642 message $top.al -aspect 1000 -font $uifont \
1643 -text "Commits to include (arguments to git rev-list):"
1644 grid $top.al - -sticky w -pady 5
1645 entry $top.args -width 50 -textvariable newviewargs($n) \
1646 -background white -font $uifont
1647 grid $top.args - -sticky ew -padx 5
1648 message $top.l -aspect 1000 -font $uifont \
1649 -text "Enter files and directories to include, one per line:"
1650 grid $top.l - -sticky w
1651 text $top.t -width 40 -height 10 -background white -font $uifont
1652 if {[info exists viewfiles($n)]} {
1653 foreach f $viewfiles($n) {
1654 $top.t insert end $f
1655 $top.t insert end "\n"
1657 $top.t delete {end - 1c} end
1658 $top.t mark set insert 0.0
1660 grid $top.t - -sticky ew -padx 5
1661 frame $top.buts
1662 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1663 -font $uifont
1664 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1665 -font $uifont
1666 grid $top.buts.ok $top.buts.can
1667 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1668 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1669 grid $top.buts - -pady 10 -sticky ew
1670 focus $top.t
1673 proc doviewmenu {m first cmd op argv} {
1674 set nmenu [$m index end]
1675 for {set i $first} {$i <= $nmenu} {incr i} {
1676 if {[$m entrycget $i -command] eq $cmd} {
1677 eval $m $op $i $argv
1678 break
1683 proc allviewmenus {n op args} {
1684 global viewhlmenu
1686 doviewmenu .bar.view 5 [list showview $n] $op $args
1687 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1690 proc newviewok {top n} {
1691 global nextviewnum newviewperm newviewname newishighlight
1692 global viewname viewfiles viewperm selectedview curview
1693 global viewargs newviewargs viewhlmenu
1695 if {[catch {
1696 set newargs [shellsplit $newviewargs($n)]
1697 } err]} {
1698 error_popup "Error in commit selection arguments: $err"
1699 wm raise $top
1700 focus $top
1701 return
1703 set files {}
1704 foreach f [split [$top.t get 0.0 end] "\n"] {
1705 set ft [string trim $f]
1706 if {$ft ne {}} {
1707 lappend files $ft
1710 if {![info exists viewfiles($n)]} {
1711 # creating a new view
1712 incr nextviewnum
1713 set viewname($n) $newviewname($n)
1714 set viewperm($n) $newviewperm($n)
1715 set viewfiles($n) $files
1716 set viewargs($n) $newargs
1717 addviewmenu $n
1718 if {!$newishighlight} {
1719 run showview $n
1720 } else {
1721 run addvhighlight $n
1723 } else {
1724 # editing an existing view
1725 set viewperm($n) $newviewperm($n)
1726 if {$newviewname($n) ne $viewname($n)} {
1727 set viewname($n) $newviewname($n)
1728 doviewmenu .bar.view 5 [list showview $n] \
1729 entryconf [list -label $viewname($n)]
1730 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1731 entryconf [list -label $viewname($n) -value $viewname($n)]
1733 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1734 set viewfiles($n) $files
1735 set viewargs($n) $newargs
1736 if {$curview == $n} {
1737 run updatecommits
1741 catch {destroy $top}
1744 proc delview {} {
1745 global curview viewdata viewperm hlview selectedhlview
1747 if {$curview == 0} return
1748 if {[info exists hlview] && $hlview == $curview} {
1749 set selectedhlview None
1750 unset hlview
1752 allviewmenus $curview delete
1753 set viewdata($curview) {}
1754 set viewperm($curview) 0
1755 showview 0
1758 proc addviewmenu {n} {
1759 global viewname viewhlmenu
1761 .bar.view add radiobutton -label $viewname($n) \
1762 -command [list showview $n] -variable selectedview -value $n
1763 $viewhlmenu add radiobutton -label $viewname($n) \
1764 -command [list addvhighlight $n] -variable selectedhlview
1767 proc flatten {var} {
1768 global $var
1770 set ret {}
1771 foreach i [array names $var] {
1772 lappend ret $i [set $var\($i\)]
1774 return $ret
1777 proc unflatten {var l} {
1778 global $var
1780 catch {unset $var}
1781 foreach {i v} $l {
1782 set $var\($i\) $v
1786 proc showview {n} {
1787 global curview viewdata viewfiles
1788 global displayorder parentlist rowidlist rowoffsets
1789 global colormap rowtextx commitrow nextcolor canvxmax
1790 global numcommits rowrangelist commitlisted idrowranges rowchk
1791 global selectedline currentid canv canvy0
1792 global treediffs
1793 global pending_select phase
1794 global commitidx rowlaidout rowoptim
1795 global commfd
1796 global selectedview selectfirst
1797 global vparentlist vdisporder vcmitlisted
1798 global hlview selectedhlview
1800 if {$n == $curview} return
1801 set selid {}
1802 if {[info exists selectedline]} {
1803 set selid $currentid
1804 set y [yc $selectedline]
1805 set ymax [lindex [$canv cget -scrollregion] 3]
1806 set span [$canv yview]
1807 set ytop [expr {[lindex $span 0] * $ymax}]
1808 set ybot [expr {[lindex $span 1] * $ymax}]
1809 if {$ytop < $y && $y < $ybot} {
1810 set yscreen [expr {$y - $ytop}]
1811 } else {
1812 set yscreen [expr {($ybot - $ytop) / 2}]
1814 } elseif {[info exists pending_select]} {
1815 set selid $pending_select
1816 unset pending_select
1818 unselectline
1819 normalline
1820 if {$curview >= 0} {
1821 set vparentlist($curview) $parentlist
1822 set vdisporder($curview) $displayorder
1823 set vcmitlisted($curview) $commitlisted
1824 if {$phase ne {}} {
1825 set viewdata($curview) \
1826 [list $phase $rowidlist $rowoffsets $rowrangelist \
1827 [flatten idrowranges] [flatten idinlist] \
1828 $rowlaidout $rowoptim $numcommits]
1829 } elseif {![info exists viewdata($curview)]
1830 || [lindex $viewdata($curview) 0] ne {}} {
1831 set viewdata($curview) \
1832 [list {} $rowidlist $rowoffsets $rowrangelist]
1835 catch {unset treediffs}
1836 clear_display
1837 if {[info exists hlview] && $hlview == $n} {
1838 unset hlview
1839 set selectedhlview None
1842 set curview $n
1843 set selectedview $n
1844 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1845 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1847 if {![info exists viewdata($n)]} {
1848 if {$selid ne {}} {
1849 set pending_select $selid
1851 getcommits
1852 return
1855 set v $viewdata($n)
1856 set phase [lindex $v 0]
1857 set displayorder $vdisporder($n)
1858 set parentlist $vparentlist($n)
1859 set commitlisted $vcmitlisted($n)
1860 set rowidlist [lindex $v 1]
1861 set rowoffsets [lindex $v 2]
1862 set rowrangelist [lindex $v 3]
1863 if {$phase eq {}} {
1864 set numcommits [llength $displayorder]
1865 catch {unset idrowranges}
1866 } else {
1867 unflatten idrowranges [lindex $v 4]
1868 unflatten idinlist [lindex $v 5]
1869 set rowlaidout [lindex $v 6]
1870 set rowoptim [lindex $v 7]
1871 set numcommits [lindex $v 8]
1872 catch {unset rowchk}
1875 catch {unset colormap}
1876 catch {unset rowtextx}
1877 set nextcolor 0
1878 set canvxmax [$canv cget -width]
1879 set curview $n
1880 set row 0
1881 setcanvscroll
1882 set yf 0
1883 set row {}
1884 set selectfirst 0
1885 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1886 set row $commitrow($n,$selid)
1887 # try to get the selected row in the same position on the screen
1888 set ymax [lindex [$canv cget -scrollregion] 3]
1889 set ytop [expr {[yc $row] - $yscreen}]
1890 if {$ytop < 0} {
1891 set ytop 0
1893 set yf [expr {$ytop * 1.0 / $ymax}]
1895 allcanvs yview moveto $yf
1896 drawvisible
1897 if {$row ne {}} {
1898 selectline $row 0
1899 } elseif {$selid ne {}} {
1900 set pending_select $selid
1901 } else {
1902 set row [first_real_row]
1903 if {$row < $numcommits} {
1904 selectline $row 0
1905 } else {
1906 set selectfirst 1
1909 if {$phase ne {}} {
1910 if {$phase eq "getcommits"} {
1911 show_status "Reading commits..."
1913 run chewcommits $n
1914 } elseif {$numcommits == 0} {
1915 show_status "No commits selected"
1919 # Stuff relating to the highlighting facility
1921 proc ishighlighted {row} {
1922 global vhighlights fhighlights nhighlights rhighlights
1924 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1925 return $nhighlights($row)
1927 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1928 return $vhighlights($row)
1930 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1931 return $fhighlights($row)
1933 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1934 return $rhighlights($row)
1936 return 0
1939 proc bolden {row font} {
1940 global canv linehtag selectedline boldrows
1942 lappend boldrows $row
1943 $canv itemconf $linehtag($row) -font $font
1944 if {[info exists selectedline] && $row == $selectedline} {
1945 $canv delete secsel
1946 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1947 -outline {{}} -tags secsel \
1948 -fill [$canv cget -selectbackground]]
1949 $canv lower $t
1953 proc bolden_name {row font} {
1954 global canv2 linentag selectedline boldnamerows
1956 lappend boldnamerows $row
1957 $canv2 itemconf $linentag($row) -font $font
1958 if {[info exists selectedline] && $row == $selectedline} {
1959 $canv2 delete secsel
1960 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1961 -outline {{}} -tags secsel \
1962 -fill [$canv2 cget -selectbackground]]
1963 $canv2 lower $t
1967 proc unbolden {} {
1968 global mainfont boldrows
1970 set stillbold {}
1971 foreach row $boldrows {
1972 if {![ishighlighted $row]} {
1973 bolden $row $mainfont
1974 } else {
1975 lappend stillbold $row
1978 set boldrows $stillbold
1981 proc addvhighlight {n} {
1982 global hlview curview viewdata vhl_done vhighlights commitidx
1984 if {[info exists hlview]} {
1985 delvhighlight
1987 set hlview $n
1988 if {$n != $curview && ![info exists viewdata($n)]} {
1989 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1990 set vparentlist($n) {}
1991 set vdisporder($n) {}
1992 set vcmitlisted($n) {}
1993 start_rev_list $n
1995 set vhl_done $commitidx($hlview)
1996 if {$vhl_done > 0} {
1997 drawvisible
2001 proc delvhighlight {} {
2002 global hlview vhighlights
2004 if {![info exists hlview]} return
2005 unset hlview
2006 catch {unset vhighlights}
2007 unbolden
2010 proc vhighlightmore {} {
2011 global hlview vhl_done commitidx vhighlights
2012 global displayorder vdisporder curview mainfont
2014 set font [concat $mainfont bold]
2015 set max $commitidx($hlview)
2016 if {$hlview == $curview} {
2017 set disp $displayorder
2018 } else {
2019 set disp $vdisporder($hlview)
2021 set vr [visiblerows]
2022 set r0 [lindex $vr 0]
2023 set r1 [lindex $vr 1]
2024 for {set i $vhl_done} {$i < $max} {incr i} {
2025 set id [lindex $disp $i]
2026 if {[info exists commitrow($curview,$id)]} {
2027 set row $commitrow($curview,$id)
2028 if {$r0 <= $row && $row <= $r1} {
2029 if {![highlighted $row]} {
2030 bolden $row $font
2032 set vhighlights($row) 1
2036 set vhl_done $max
2039 proc askvhighlight {row id} {
2040 global hlview vhighlights commitrow iddrawn mainfont
2042 if {[info exists commitrow($hlview,$id)]} {
2043 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2044 bolden $row [concat $mainfont bold]
2046 set vhighlights($row) 1
2047 } else {
2048 set vhighlights($row) 0
2052 proc hfiles_change {name ix op} {
2053 global highlight_files filehighlight fhighlights fh_serial
2054 global mainfont highlight_paths
2056 if {[info exists filehighlight]} {
2057 # delete previous highlights
2058 catch {close $filehighlight}
2059 unset filehighlight
2060 catch {unset fhighlights}
2061 unbolden
2062 unhighlight_filelist
2064 set highlight_paths {}
2065 after cancel do_file_hl $fh_serial
2066 incr fh_serial
2067 if {$highlight_files ne {}} {
2068 after 300 do_file_hl $fh_serial
2072 proc makepatterns {l} {
2073 set ret {}
2074 foreach e $l {
2075 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2076 if {[string index $ee end] eq "/"} {
2077 lappend ret "$ee*"
2078 } else {
2079 lappend ret $ee
2080 lappend ret "$ee/*"
2083 return $ret
2086 proc do_file_hl {serial} {
2087 global highlight_files filehighlight highlight_paths gdttype fhl_list
2089 if {$gdttype eq "touching paths:"} {
2090 if {[catch {set paths [shellsplit $highlight_files]}]} return
2091 set highlight_paths [makepatterns $paths]
2092 highlight_filelist
2093 set gdtargs [concat -- $paths]
2094 } else {
2095 set gdtargs [list "-S$highlight_files"]
2097 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2098 set filehighlight [open $cmd r+]
2099 fconfigure $filehighlight -blocking 0
2100 filerun $filehighlight readfhighlight
2101 set fhl_list {}
2102 drawvisible
2103 flushhighlights
2106 proc flushhighlights {} {
2107 global filehighlight fhl_list
2109 if {[info exists filehighlight]} {
2110 lappend fhl_list {}
2111 puts $filehighlight ""
2112 flush $filehighlight
2116 proc askfilehighlight {row id} {
2117 global filehighlight fhighlights fhl_list
2119 lappend fhl_list $id
2120 set fhighlights($row) -1
2121 puts $filehighlight $id
2124 proc readfhighlight {} {
2125 global filehighlight fhighlights commitrow curview mainfont iddrawn
2126 global fhl_list
2128 if {![info exists filehighlight]} {
2129 return 0
2131 set nr 0
2132 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2133 set line [string trim $line]
2134 set i [lsearch -exact $fhl_list $line]
2135 if {$i < 0} continue
2136 for {set j 0} {$j < $i} {incr j} {
2137 set id [lindex $fhl_list $j]
2138 if {[info exists commitrow($curview,$id)]} {
2139 set fhighlights($commitrow($curview,$id)) 0
2142 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2143 if {$line eq {}} continue
2144 if {![info exists commitrow($curview,$line)]} continue
2145 set row $commitrow($curview,$line)
2146 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2147 bolden $row [concat $mainfont bold]
2149 set fhighlights($row) 1
2151 if {[eof $filehighlight]} {
2152 # strange...
2153 puts "oops, git diff-tree died"
2154 catch {close $filehighlight}
2155 unset filehighlight
2156 return 0
2158 next_hlcont
2159 return 1
2162 proc find_change {name ix op} {
2163 global nhighlights mainfont boldnamerows
2164 global findstring findpattern findtype
2166 # delete previous highlights, if any
2167 foreach row $boldnamerows {
2168 bolden_name $row $mainfont
2170 set boldnamerows {}
2171 catch {unset nhighlights}
2172 unbolden
2173 unmarkmatches
2174 if {$findtype ne "Regexp"} {
2175 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2176 $findstring]
2177 set findpattern "*$e*"
2179 drawvisible
2182 proc doesmatch {f} {
2183 global findtype findstring findpattern
2185 if {$findtype eq "Regexp"} {
2186 return [regexp $findstring $f]
2187 } elseif {$findtype eq "IgnCase"} {
2188 return [string match -nocase $findpattern $f]
2189 } else {
2190 return [string match $findpattern $f]
2194 proc askfindhighlight {row id} {
2195 global nhighlights commitinfo iddrawn mainfont
2196 global findloc
2197 global markingmatches
2199 if {![info exists commitinfo($id)]} {
2200 getcommit $id
2202 set info $commitinfo($id)
2203 set isbold 0
2204 set fldtypes {Headline Author Date Committer CDate Comments}
2205 foreach f $info ty $fldtypes {
2206 if {($findloc eq "All fields" || $findloc eq $ty) &&
2207 [doesmatch $f]} {
2208 if {$ty eq "Author"} {
2209 set isbold 2
2210 break
2212 set isbold 1
2215 if {$isbold && [info exists iddrawn($id)]} {
2216 set f [concat $mainfont bold]
2217 if {![ishighlighted $row]} {
2218 bolden $row $f
2219 if {$isbold > 1} {
2220 bolden_name $row $f
2223 if {$markingmatches} {
2224 markrowmatches $row $id
2227 set nhighlights($row) $isbold
2230 proc markrowmatches {row id} {
2231 global canv canv2 linehtag linentag commitinfo findloc
2233 set headline [lindex $commitinfo($id) 0]
2234 set author [lindex $commitinfo($id) 1]
2235 $canv delete match$row
2236 $canv2 delete match$row
2237 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2238 set m [findmatches $headline]
2239 if {$m ne {}} {
2240 markmatches $canv $row $headline $linehtag($row) $m \
2241 [$canv itemcget $linehtag($row) -font] $row
2244 if {$findloc eq "All fields" || $findloc eq "Author"} {
2245 set m [findmatches $author]
2246 if {$m ne {}} {
2247 markmatches $canv2 $row $author $linentag($row) $m \
2248 [$canv2 itemcget $linentag($row) -font] $row
2253 proc vrel_change {name ix op} {
2254 global highlight_related
2256 rhighlight_none
2257 if {$highlight_related ne "None"} {
2258 run drawvisible
2262 # prepare for testing whether commits are descendents or ancestors of a
2263 proc rhighlight_sel {a} {
2264 global descendent desc_todo ancestor anc_todo
2265 global highlight_related rhighlights
2267 catch {unset descendent}
2268 set desc_todo [list $a]
2269 catch {unset ancestor}
2270 set anc_todo [list $a]
2271 if {$highlight_related ne "None"} {
2272 rhighlight_none
2273 run drawvisible
2277 proc rhighlight_none {} {
2278 global rhighlights
2280 catch {unset rhighlights}
2281 unbolden
2284 proc is_descendent {a} {
2285 global curview children commitrow descendent desc_todo
2287 set v $curview
2288 set la $commitrow($v,$a)
2289 set todo $desc_todo
2290 set leftover {}
2291 set done 0
2292 for {set i 0} {$i < [llength $todo]} {incr i} {
2293 set do [lindex $todo $i]
2294 if {$commitrow($v,$do) < $la} {
2295 lappend leftover $do
2296 continue
2298 foreach nk $children($v,$do) {
2299 if {![info exists descendent($nk)]} {
2300 set descendent($nk) 1
2301 lappend todo $nk
2302 if {$nk eq $a} {
2303 set done 1
2307 if {$done} {
2308 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2309 return
2312 set descendent($a) 0
2313 set desc_todo $leftover
2316 proc is_ancestor {a} {
2317 global curview parentlist commitrow ancestor anc_todo
2319 set v $curview
2320 set la $commitrow($v,$a)
2321 set todo $anc_todo
2322 set leftover {}
2323 set done 0
2324 for {set i 0} {$i < [llength $todo]} {incr i} {
2325 set do [lindex $todo $i]
2326 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2327 lappend leftover $do
2328 continue
2330 foreach np [lindex $parentlist $commitrow($v,$do)] {
2331 if {![info exists ancestor($np)]} {
2332 set ancestor($np) 1
2333 lappend todo $np
2334 if {$np eq $a} {
2335 set done 1
2339 if {$done} {
2340 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2341 return
2344 set ancestor($a) 0
2345 set anc_todo $leftover
2348 proc askrelhighlight {row id} {
2349 global descendent highlight_related iddrawn mainfont rhighlights
2350 global selectedline ancestor
2352 if {![info exists selectedline]} return
2353 set isbold 0
2354 if {$highlight_related eq "Descendent" ||
2355 $highlight_related eq "Not descendent"} {
2356 if {![info exists descendent($id)]} {
2357 is_descendent $id
2359 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2360 set isbold 1
2362 } elseif {$highlight_related eq "Ancestor" ||
2363 $highlight_related eq "Not ancestor"} {
2364 if {![info exists ancestor($id)]} {
2365 is_ancestor $id
2367 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2368 set isbold 1
2371 if {[info exists iddrawn($id)]} {
2372 if {$isbold && ![ishighlighted $row]} {
2373 bolden $row [concat $mainfont bold]
2376 set rhighlights($row) $isbold
2379 proc next_hlcont {} {
2380 global fhl_row fhl_dirn displayorder numcommits
2381 global vhighlights fhighlights nhighlights rhighlights
2382 global hlview filehighlight findstring highlight_related
2384 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2385 set row $fhl_row
2386 while {1} {
2387 if {$row < 0 || $row >= $numcommits} {
2388 bell
2389 set fhl_dirn 0
2390 return
2392 set id [lindex $displayorder $row]
2393 if {[info exists hlview]} {
2394 if {![info exists vhighlights($row)]} {
2395 askvhighlight $row $id
2397 if {$vhighlights($row) > 0} break
2399 if {$findstring ne {}} {
2400 if {![info exists nhighlights($row)]} {
2401 askfindhighlight $row $id
2403 if {$nhighlights($row) > 0} break
2405 if {$highlight_related ne "None"} {
2406 if {![info exists rhighlights($row)]} {
2407 askrelhighlight $row $id
2409 if {$rhighlights($row) > 0} break
2411 if {[info exists filehighlight]} {
2412 if {![info exists fhighlights($row)]} {
2413 # ask for a few more while we're at it...
2414 set r $row
2415 for {set n 0} {$n < 100} {incr n} {
2416 if {![info exists fhighlights($r)]} {
2417 askfilehighlight $r [lindex $displayorder $r]
2419 incr r $fhl_dirn
2420 if {$r < 0 || $r >= $numcommits} break
2422 flushhighlights
2424 if {$fhighlights($row) < 0} {
2425 set fhl_row $row
2426 return
2428 if {$fhighlights($row) > 0} break
2430 incr row $fhl_dirn
2432 set fhl_dirn 0
2433 selectline $row 1
2436 proc next_highlight {dirn} {
2437 global selectedline fhl_row fhl_dirn
2438 global hlview filehighlight findstring highlight_related
2440 if {![info exists selectedline]} return
2441 if {!([info exists hlview] || $findstring ne {} ||
2442 $highlight_related ne "None" || [info exists filehighlight])} return
2443 set fhl_row [expr {$selectedline + $dirn}]
2444 set fhl_dirn $dirn
2445 next_hlcont
2448 proc cancel_next_highlight {} {
2449 global fhl_dirn
2451 set fhl_dirn 0
2454 # Graph layout functions
2456 proc shortids {ids} {
2457 set res {}
2458 foreach id $ids {
2459 if {[llength $id] > 1} {
2460 lappend res [shortids $id]
2461 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2462 lappend res [string range $id 0 7]
2463 } else {
2464 lappend res $id
2467 return $res
2470 proc incrange {l x o} {
2471 set n [llength $l]
2472 while {$x < $n} {
2473 set e [lindex $l $x]
2474 if {$e ne {}} {
2475 lset l $x [expr {$e + $o}]
2477 incr x
2479 return $l
2482 proc ntimes {n o} {
2483 set ret {}
2484 for {} {$n > 0} {incr n -1} {
2485 lappend ret $o
2487 return $ret
2490 proc usedinrange {id l1 l2} {
2491 global children commitrow curview
2493 if {[info exists commitrow($curview,$id)]} {
2494 set r $commitrow($curview,$id)
2495 if {$l1 <= $r && $r <= $l2} {
2496 return [expr {$r - $l1 + 1}]
2499 set kids $children($curview,$id)
2500 foreach c $kids {
2501 set r $commitrow($curview,$c)
2502 if {$l1 <= $r && $r <= $l2} {
2503 return [expr {$r - $l1 + 1}]
2506 return 0
2509 proc sanity {row {full 0}} {
2510 global rowidlist rowoffsets
2512 set col -1
2513 set ids [lindex $rowidlist $row]
2514 foreach id $ids {
2515 incr col
2516 if {$id eq {}} continue
2517 if {$col < [llength $ids] - 1 &&
2518 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2519 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2521 set o [lindex $rowoffsets $row $col]
2522 set y $row
2523 set x $col
2524 while {$o ne {}} {
2525 incr y -1
2526 incr x $o
2527 if {[lindex $rowidlist $y $x] != $id} {
2528 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2529 puts " id=[shortids $id] check started at row $row"
2530 for {set i $row} {$i >= $y} {incr i -1} {
2531 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2533 break
2535 if {!$full} break
2536 set o [lindex $rowoffsets $y $x]
2541 proc makeuparrow {oid x y z} {
2542 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2544 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2545 incr y -1
2546 incr x $z
2547 set off0 [lindex $rowoffsets $y]
2548 for {set x0 $x} {1} {incr x0} {
2549 if {$x0 >= [llength $off0]} {
2550 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2551 break
2553 set z [lindex $off0 $x0]
2554 if {$z ne {}} {
2555 incr x0 $z
2556 break
2559 set z [expr {$x0 - $x}]
2560 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2561 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2563 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2564 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2565 lappend idrowranges($oid) [lindex $displayorder $y]
2568 proc initlayout {} {
2569 global rowidlist rowoffsets displayorder commitlisted
2570 global rowlaidout rowoptim
2571 global idinlist rowchk rowrangelist idrowranges
2572 global numcommits canvxmax canv
2573 global nextcolor
2574 global parentlist
2575 global colormap rowtextx
2576 global selectfirst
2578 set numcommits 0
2579 set displayorder {}
2580 set commitlisted {}
2581 set parentlist {}
2582 set rowrangelist {}
2583 set nextcolor 0
2584 set rowidlist {{}}
2585 set rowoffsets {{}}
2586 catch {unset idinlist}
2587 catch {unset rowchk}
2588 set rowlaidout 0
2589 set rowoptim 0
2590 set canvxmax [$canv cget -width]
2591 catch {unset colormap}
2592 catch {unset rowtextx}
2593 catch {unset idrowranges}
2594 set selectfirst 1
2597 proc setcanvscroll {} {
2598 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2600 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2601 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2602 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2603 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2606 proc visiblerows {} {
2607 global canv numcommits linespc
2609 set ymax [lindex [$canv cget -scrollregion] 3]
2610 if {$ymax eq {} || $ymax == 0} return
2611 set f [$canv yview]
2612 set y0 [expr {int([lindex $f 0] * $ymax)}]
2613 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2614 if {$r0 < 0} {
2615 set r0 0
2617 set y1 [expr {int([lindex $f 1] * $ymax)}]
2618 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2619 if {$r1 >= $numcommits} {
2620 set r1 [expr {$numcommits - 1}]
2622 return [list $r0 $r1]
2625 proc layoutmore {tmax allread} {
2626 global rowlaidout rowoptim commitidx numcommits optim_delay
2627 global uparrowlen curview rowidlist idinlist
2629 set showlast 0
2630 set showdelay $optim_delay
2631 set optdelay [expr {$uparrowlen + 1}]
2632 while {1} {
2633 if {$rowoptim - $showdelay > $numcommits} {
2634 showstuff [expr {$rowoptim - $showdelay}] $showlast
2635 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2636 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2637 if {$nr > 100} {
2638 set nr 100
2640 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2641 incr rowoptim $nr
2642 } elseif {$commitidx($curview) > $rowlaidout} {
2643 set nr [expr {$commitidx($curview) - $rowlaidout}]
2644 # may need to increase this threshold if uparrowlen or
2645 # mingaplen are increased...
2646 if {$nr > 150} {
2647 set nr 150
2649 set row $rowlaidout
2650 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2651 if {$rowlaidout == $row} {
2652 return 0
2654 } elseif {$allread} {
2655 set optdelay 0
2656 set nrows $commitidx($curview)
2657 if {[lindex $rowidlist $nrows] ne {} ||
2658 [array names idinlist] ne {}} {
2659 layouttail
2660 set rowlaidout $commitidx($curview)
2661 } elseif {$rowoptim == $nrows} {
2662 set showdelay 0
2663 set showlast 1
2664 if {$numcommits == $nrows} {
2665 return 0
2668 } else {
2669 return 0
2671 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2672 return 1
2677 proc showstuff {canshow last} {
2678 global numcommits commitrow pending_select selectedline curview
2679 global lookingforhead mainheadid displayorder selectfirst
2680 global lastscrollset
2682 if {$numcommits == 0} {
2683 global phase
2684 set phase "incrdraw"
2685 allcanvs delete all
2687 set r0 $numcommits
2688 set prev $numcommits
2689 set numcommits $canshow
2690 set t [clock clicks -milliseconds]
2691 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2692 set lastscrollset $t
2693 setcanvscroll
2695 set rows [visiblerows]
2696 set r1 [lindex $rows 1]
2697 if {$r1 >= $canshow} {
2698 set r1 [expr {$canshow - 1}]
2700 if {$r0 <= $r1} {
2701 drawcommits $r0 $r1
2703 if {[info exists pending_select] &&
2704 [info exists commitrow($curview,$pending_select)] &&
2705 $commitrow($curview,$pending_select) < $numcommits} {
2706 selectline $commitrow($curview,$pending_select) 1
2708 if {$selectfirst} {
2709 if {[info exists selectedline] || [info exists pending_select]} {
2710 set selectfirst 0
2711 } else {
2712 set l [first_real_row]
2713 selectline $l 1
2714 set selectfirst 0
2717 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2718 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2719 set lookingforhead 0
2720 dodiffindex
2724 proc doshowlocalchanges {} {
2725 global lookingforhead curview mainheadid phase commitrow
2727 if {[info exists commitrow($curview,$mainheadid)] &&
2728 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2729 dodiffindex
2730 } elseif {$phase ne {}} {
2731 set lookingforhead 1
2735 proc dohidelocalchanges {} {
2736 global lookingforhead localfrow localirow lserial
2738 set lookingforhead 0
2739 if {$localfrow >= 0} {
2740 removerow $localfrow
2741 set localfrow -1
2742 if {$localirow > 0} {
2743 incr localirow -1
2746 if {$localirow >= 0} {
2747 removerow $localirow
2748 set localirow -1
2750 incr lserial
2753 # spawn off a process to do git diff-index --cached HEAD
2754 proc dodiffindex {} {
2755 global localirow localfrow lserial
2757 incr lserial
2758 set localfrow -1
2759 set localirow -1
2760 set fd [open "|git diff-index --cached HEAD" r]
2761 fconfigure $fd -blocking 0
2762 filerun $fd [list readdiffindex $fd $lserial]
2765 proc readdiffindex {fd serial} {
2766 global localirow commitrow mainheadid nullid2 curview
2767 global commitinfo commitdata lserial
2769 set isdiff 1
2770 if {[gets $fd line] < 0} {
2771 if {![eof $fd]} {
2772 return 1
2774 set isdiff 0
2776 # we only need to see one line and we don't really care what it says...
2777 close $fd
2779 # now see if there are any local changes not checked in to the index
2780 if {$serial == $lserial} {
2781 set fd [open "|git diff-files" r]
2782 fconfigure $fd -blocking 0
2783 filerun $fd [list readdifffiles $fd $serial]
2786 if {$isdiff && $serial == $lserial && $localirow == -1} {
2787 # add the line for the changes in the index to the graph
2788 set localirow $commitrow($curview,$mainheadid)
2789 set hl "Local changes checked in to index but not committed"
2790 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2791 set commitdata($nullid2) "\n $hl\n"
2792 insertrow $localirow $nullid2
2794 return 0
2797 proc readdifffiles {fd serial} {
2798 global localirow localfrow commitrow mainheadid nullid curview
2799 global commitinfo commitdata lserial
2801 set isdiff 1
2802 if {[gets $fd line] < 0} {
2803 if {![eof $fd]} {
2804 return 1
2806 set isdiff 0
2808 # we only need to see one line and we don't really care what it says...
2809 close $fd
2811 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2812 # add the line for the local diff to the graph
2813 if {$localirow >= 0} {
2814 set localfrow $localirow
2815 incr localirow
2816 } else {
2817 set localfrow $commitrow($curview,$mainheadid)
2819 set hl "Local uncommitted changes, not checked in to index"
2820 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2821 set commitdata($nullid) "\n $hl\n"
2822 insertrow $localfrow $nullid
2824 return 0
2827 proc layoutrows {row endrow last} {
2828 global rowidlist rowoffsets displayorder
2829 global uparrowlen downarrowlen maxwidth mingaplen
2830 global children parentlist
2831 global idrowranges
2832 global commitidx curview
2833 global idinlist rowchk rowrangelist
2835 set idlist [lindex $rowidlist $row]
2836 set offs [lindex $rowoffsets $row]
2837 while {$row < $endrow} {
2838 set id [lindex $displayorder $row]
2839 set oldolds {}
2840 set newolds {}
2841 foreach p [lindex $parentlist $row] {
2842 if {![info exists idinlist($p)]} {
2843 lappend newolds $p
2844 } elseif {!$idinlist($p)} {
2845 lappend oldolds $p
2848 set nev [expr {[llength $idlist] + [llength $newolds]
2849 + [llength $oldolds] - $maxwidth + 1}]
2850 if {$nev > 0} {
2851 if {!$last &&
2852 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2853 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2854 set i [lindex $idlist $x]
2855 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2856 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2857 [expr {$row + $uparrowlen + $mingaplen}]]
2858 if {$r == 0} {
2859 set idlist [lreplace $idlist $x $x]
2860 set offs [lreplace $offs $x $x]
2861 set offs [incrange $offs $x 1]
2862 set idinlist($i) 0
2863 set rm1 [expr {$row - 1}]
2864 lappend idrowranges($i) [lindex $displayorder $rm1]
2865 if {[incr nev -1] <= 0} break
2866 continue
2868 set rowchk($id) [expr {$row + $r}]
2871 lset rowidlist $row $idlist
2872 lset rowoffsets $row $offs
2874 set col [lsearch -exact $idlist $id]
2875 if {$col < 0} {
2876 set col [llength $idlist]
2877 lappend idlist $id
2878 lset rowidlist $row $idlist
2879 set z {}
2880 if {$children($curview,$id) ne {}} {
2881 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2882 unset idinlist($id)
2884 lappend offs $z
2885 lset rowoffsets $row $offs
2886 if {$z ne {}} {
2887 makeuparrow $id $col $row $z
2889 } else {
2890 unset idinlist($id)
2892 set ranges {}
2893 if {[info exists idrowranges($id)]} {
2894 set ranges $idrowranges($id)
2895 lappend ranges $id
2896 unset idrowranges($id)
2898 lappend rowrangelist $ranges
2899 incr row
2900 set offs [ntimes [llength $idlist] 0]
2901 set l [llength $newolds]
2902 set idlist [eval lreplace \$idlist $col $col $newolds]
2903 set o 0
2904 if {$l != 1} {
2905 set offs [lrange $offs 0 [expr {$col - 1}]]
2906 foreach x $newolds {
2907 lappend offs {}
2908 incr o -1
2910 incr o
2911 set tmp [expr {[llength $idlist] - [llength $offs]}]
2912 if {$tmp > 0} {
2913 set offs [concat $offs [ntimes $tmp $o]]
2915 } else {
2916 lset offs $col {}
2918 foreach i $newolds {
2919 set idinlist($i) 1
2920 set idrowranges($i) $id
2922 incr col $l
2923 foreach oid $oldolds {
2924 set idinlist($oid) 1
2925 set idlist [linsert $idlist $col $oid]
2926 set offs [linsert $offs $col $o]
2927 makeuparrow $oid $col $row $o
2928 incr col
2930 lappend rowidlist $idlist
2931 lappend rowoffsets $offs
2933 return $row
2936 proc addextraid {id row} {
2937 global displayorder commitrow commitinfo
2938 global commitidx commitlisted
2939 global parentlist children curview
2941 incr commitidx($curview)
2942 lappend displayorder $id
2943 lappend commitlisted 0
2944 lappend parentlist {}
2945 set commitrow($curview,$id) $row
2946 readcommit $id
2947 if {![info exists commitinfo($id)]} {
2948 set commitinfo($id) {"No commit information available"}
2950 if {![info exists children($curview,$id)]} {
2951 set children($curview,$id) {}
2955 proc layouttail {} {
2956 global rowidlist rowoffsets idinlist commitidx curview
2957 global idrowranges rowrangelist
2959 set row $commitidx($curview)
2960 set idlist [lindex $rowidlist $row]
2961 while {$idlist ne {}} {
2962 set col [expr {[llength $idlist] - 1}]
2963 set id [lindex $idlist $col]
2964 addextraid $id $row
2965 unset idinlist($id)
2966 lappend idrowranges($id) $id
2967 lappend rowrangelist $idrowranges($id)
2968 unset idrowranges($id)
2969 incr row
2970 set offs [ntimes $col 0]
2971 set idlist [lreplace $idlist $col $col]
2972 lappend rowidlist $idlist
2973 lappend rowoffsets $offs
2976 foreach id [array names idinlist] {
2977 unset idinlist($id)
2978 addextraid $id $row
2979 lset rowidlist $row [list $id]
2980 lset rowoffsets $row 0
2981 makeuparrow $id 0 $row 0
2982 lappend idrowranges($id) $id
2983 lappend rowrangelist $idrowranges($id)
2984 unset idrowranges($id)
2985 incr row
2986 lappend rowidlist {}
2987 lappend rowoffsets {}
2991 proc insert_pad {row col npad} {
2992 global rowidlist rowoffsets
2994 set pad [ntimes $npad {}]
2995 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2996 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2997 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
3000 proc optimize_rows {row col endrow} {
3001 global rowidlist rowoffsets displayorder
3003 for {} {$row < $endrow} {incr row} {
3004 set idlist [lindex $rowidlist $row]
3005 set offs [lindex $rowoffsets $row]
3006 set haspad 0
3007 for {} {$col < [llength $offs]} {incr col} {
3008 if {[lindex $idlist $col] eq {}} {
3009 set haspad 1
3010 continue
3012 set z [lindex $offs $col]
3013 if {$z eq {}} continue
3014 set isarrow 0
3015 set x0 [expr {$col + $z}]
3016 set y0 [expr {$row - 1}]
3017 set z0 [lindex $rowoffsets $y0 $x0]
3018 if {$z0 eq {}} {
3019 set id [lindex $idlist $col]
3020 set ranges [rowranges $id]
3021 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3022 set isarrow 1
3025 # Looking at lines from this row to the previous row,
3026 # make them go straight up if they end in an arrow on
3027 # the previous row; otherwise make them go straight up
3028 # or at 45 degrees.
3029 if {$z < -1 || ($z < 0 && $isarrow)} {
3030 # Line currently goes left too much;
3031 # insert pads in the previous row, then optimize it
3032 set npad [expr {-1 - $z + $isarrow}]
3033 set offs [incrange $offs $col $npad]
3034 insert_pad $y0 $x0 $npad
3035 if {$y0 > 0} {
3036 optimize_rows $y0 $x0 $row
3038 set z [lindex $offs $col]
3039 set x0 [expr {$col + $z}]
3040 set z0 [lindex $rowoffsets $y0 $x0]
3041 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3042 # Line currently goes right too much;
3043 # insert pads in this line and adjust the next's rowoffsets
3044 set npad [expr {$z - 1 + $isarrow}]
3045 set y1 [expr {$row + 1}]
3046 set offs2 [lindex $rowoffsets $y1]
3047 set x1 -1
3048 foreach z $offs2 {
3049 incr x1
3050 if {$z eq {} || $x1 + $z < $col} continue
3051 if {$x1 + $z > $col} {
3052 incr npad
3054 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3055 break
3057 set pad [ntimes $npad {}]
3058 set idlist [eval linsert \$idlist $col $pad]
3059 set tmp [eval linsert \$offs $col $pad]
3060 incr col $npad
3061 set offs [incrange $tmp $col [expr {-$npad}]]
3062 set z [lindex $offs $col]
3063 set haspad 1
3065 if {$z0 eq {} && !$isarrow} {
3066 # this line links to its first child on row $row-2
3067 set rm2 [expr {$row - 2}]
3068 set id [lindex $displayorder $rm2]
3069 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3070 if {$xc >= 0} {
3071 set z0 [expr {$xc - $x0}]
3074 # avoid lines jigging left then immediately right
3075 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3076 insert_pad $y0 $x0 1
3077 set offs [incrange $offs $col 1]
3078 optimize_rows $y0 [expr {$x0 + 1}] $row
3081 if {!$haspad} {
3082 set o {}
3083 # Find the first column that doesn't have a line going right
3084 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3085 set o [lindex $offs $col]
3086 if {$o eq {}} {
3087 # check if this is the link to the first child
3088 set id [lindex $idlist $col]
3089 set ranges [rowranges $id]
3090 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3091 # it is, work out offset to child
3092 set y0 [expr {$row - 1}]
3093 set id [lindex $displayorder $y0]
3094 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3095 if {$x0 >= 0} {
3096 set o [expr {$x0 - $col}]
3100 if {$o eq {} || $o <= 0} break
3102 # Insert a pad at that column as long as it has a line and
3103 # isn't the last column, and adjust the next row' offsets
3104 if {$o ne {} && [incr col] < [llength $idlist]} {
3105 set y1 [expr {$row + 1}]
3106 set offs2 [lindex $rowoffsets $y1]
3107 set x1 -1
3108 foreach z $offs2 {
3109 incr x1
3110 if {$z eq {} || $x1 + $z < $col} continue
3111 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3112 break
3114 set idlist [linsert $idlist $col {}]
3115 set tmp [linsert $offs $col {}]
3116 incr col
3117 set offs [incrange $tmp $col -1]
3120 lset rowidlist $row $idlist
3121 lset rowoffsets $row $offs
3122 set col 0
3126 proc xc {row col} {
3127 global canvx0 linespc
3128 return [expr {$canvx0 + $col * $linespc}]
3131 proc yc {row} {
3132 global canvy0 linespc
3133 return [expr {$canvy0 + $row * $linespc}]
3136 proc linewidth {id} {
3137 global thickerline lthickness
3139 set wid $lthickness
3140 if {[info exists thickerline] && $id eq $thickerline} {
3141 set wid [expr {2 * $lthickness}]
3143 return $wid
3146 proc rowranges {id} {
3147 global phase idrowranges commitrow rowlaidout rowrangelist curview
3149 set ranges {}
3150 if {$phase eq {} ||
3151 ([info exists commitrow($curview,$id)]
3152 && $commitrow($curview,$id) < $rowlaidout)} {
3153 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3154 } elseif {[info exists idrowranges($id)]} {
3155 set ranges $idrowranges($id)
3157 set linenos {}
3158 foreach rid $ranges {
3159 lappend linenos $commitrow($curview,$rid)
3161 if {$linenos ne {}} {
3162 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3164 return $linenos
3167 # work around tk8.4 refusal to draw arrows on diagonal segments
3168 proc adjarrowhigh {coords} {
3169 global linespc
3171 set x0 [lindex $coords 0]
3172 set x1 [lindex $coords 2]
3173 if {$x0 != $x1} {
3174 set y0 [lindex $coords 1]
3175 set y1 [lindex $coords 3]
3176 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3177 # we have a nearby vertical segment, just trim off the diag bit
3178 set coords [lrange $coords 2 end]
3179 } else {
3180 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3181 set xi [expr {$x0 - $slope * $linespc / 2}]
3182 set yi [expr {$y0 - $linespc / 2}]
3183 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3186 return $coords
3189 proc drawlineseg {id row endrow arrowlow} {
3190 global rowidlist displayorder iddrawn linesegs
3191 global canv colormap linespc curview maxlinelen
3193 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3194 set le [expr {$row + 1}]
3195 set arrowhigh 1
3196 while {1} {
3197 set c [lsearch -exact [lindex $rowidlist $le] $id]
3198 if {$c < 0} {
3199 incr le -1
3200 break
3202 lappend cols $c
3203 set x [lindex $displayorder $le]
3204 if {$x eq $id} {
3205 set arrowhigh 0
3206 break
3208 if {[info exists iddrawn($x)] || $le == $endrow} {
3209 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3210 if {$c >= 0} {
3211 lappend cols $c
3212 set arrowhigh 0
3214 break
3216 incr le
3218 if {$le <= $row} {
3219 return $row
3222 set lines {}
3223 set i 0
3224 set joinhigh 0
3225 if {[info exists linesegs($id)]} {
3226 set lines $linesegs($id)
3227 foreach li $lines {
3228 set r0 [lindex $li 0]
3229 if {$r0 > $row} {
3230 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3231 set joinhigh 1
3233 break
3235 incr i
3238 set joinlow 0
3239 if {$i > 0} {
3240 set li [lindex $lines [expr {$i-1}]]
3241 set r1 [lindex $li 1]
3242 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3243 set joinlow 1
3247 set x [lindex $cols [expr {$le - $row}]]
3248 set xp [lindex $cols [expr {$le - 1 - $row}]]
3249 set dir [expr {$xp - $x}]
3250 if {$joinhigh} {
3251 set ith [lindex $lines $i 2]
3252 set coords [$canv coords $ith]
3253 set ah [$canv itemcget $ith -arrow]
3254 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3255 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3256 if {$x2 ne {} && $x - $x2 == $dir} {
3257 set coords [lrange $coords 0 end-2]
3259 } else {
3260 set coords [list [xc $le $x] [yc $le]]
3262 if {$joinlow} {
3263 set itl [lindex $lines [expr {$i-1}] 2]
3264 set al [$canv itemcget $itl -arrow]
3265 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3266 } elseif {$arrowlow &&
3267 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3268 set arrowlow 0
3270 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3271 for {set y $le} {[incr y -1] > $row} {} {
3272 set x $xp
3273 set xp [lindex $cols [expr {$y - 1 - $row}]]
3274 set ndir [expr {$xp - $x}]
3275 if {$dir != $ndir || $xp < 0} {
3276 lappend coords [xc $y $x] [yc $y]
3278 set dir $ndir
3280 if {!$joinlow} {
3281 if {$xp < 0} {
3282 # join parent line to first child
3283 set ch [lindex $displayorder $row]
3284 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3285 if {$xc < 0} {
3286 puts "oops: drawlineseg: child $ch not on row $row"
3287 } else {
3288 if {$xc < $x - 1} {
3289 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3290 } elseif {$xc > $x + 1} {
3291 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3293 set x $xc
3295 lappend coords [xc $row $x] [yc $row]
3296 } else {
3297 set xn [xc $row $xp]
3298 set yn [yc $row]
3299 # work around tk8.4 refusal to draw arrows on diagonal segments
3300 if {$arrowlow && $xn != [lindex $coords end-1]} {
3301 if {[llength $coords] < 4 ||
3302 [lindex $coords end-3] != [lindex $coords end-1] ||
3303 [lindex $coords end] - $yn > 2 * $linespc} {
3304 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3305 set yo [yc [expr {$row + 0.5}]]
3306 lappend coords $xn $yo $xn $yn
3308 } else {
3309 lappend coords $xn $yn
3312 if {!$joinhigh} {
3313 if {$arrowhigh} {
3314 set coords [adjarrowhigh $coords]
3316 assigncolor $id
3317 set t [$canv create line $coords -width [linewidth $id] \
3318 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3319 $canv lower $t
3320 bindline $t $id
3321 set lines [linsert $lines $i [list $row $le $t]]
3322 } else {
3323 $canv coords $ith $coords
3324 if {$arrow ne $ah} {
3325 $canv itemconf $ith -arrow $arrow
3327 lset lines $i 0 $row
3329 } else {
3330 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3331 set ndir [expr {$xo - $xp}]
3332 set clow [$canv coords $itl]
3333 if {$dir == $ndir} {
3334 set clow [lrange $clow 2 end]
3336 set coords [concat $coords $clow]
3337 if {!$joinhigh} {
3338 lset lines [expr {$i-1}] 1 $le
3339 if {$arrowhigh} {
3340 set coords [adjarrowhigh $coords]
3342 } else {
3343 # coalesce two pieces
3344 $canv delete $ith
3345 set b [lindex $lines [expr {$i-1}] 0]
3346 set e [lindex $lines $i 1]
3347 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3349 $canv coords $itl $coords
3350 if {$arrow ne $al} {
3351 $canv itemconf $itl -arrow $arrow
3355 set linesegs($id) $lines
3356 return $le
3359 proc drawparentlinks {id row} {
3360 global rowidlist canv colormap curview parentlist
3361 global idpos
3363 set rowids [lindex $rowidlist $row]
3364 set col [lsearch -exact $rowids $id]
3365 if {$col < 0} return
3366 set olds [lindex $parentlist $row]
3367 set row2 [expr {$row + 1}]
3368 set x [xc $row $col]
3369 set y [yc $row]
3370 set y2 [yc $row2]
3371 set ids [lindex $rowidlist $row2]
3372 # rmx = right-most X coord used
3373 set rmx 0
3374 foreach p $olds {
3375 set i [lsearch -exact $ids $p]
3376 if {$i < 0} {
3377 puts "oops, parent $p of $id not in list"
3378 continue
3380 set x2 [xc $row2 $i]
3381 if {$x2 > $rmx} {
3382 set rmx $x2
3384 if {[lsearch -exact $rowids $p] < 0} {
3385 # drawlineseg will do this one for us
3386 continue
3388 assigncolor $p
3389 # should handle duplicated parents here...
3390 set coords [list $x $y]
3391 if {$i < $col - 1} {
3392 lappend coords [xc $row [expr {$i + 1}]] $y
3393 } elseif {$i > $col + 1} {
3394 lappend coords [xc $row [expr {$i - 1}]] $y
3396 lappend coords $x2 $y2
3397 set t [$canv create line $coords -width [linewidth $p] \
3398 -fill $colormap($p) -tags lines.$p]
3399 $canv lower $t
3400 bindline $t $p
3402 if {$rmx > [lindex $idpos($id) 1]} {
3403 lset idpos($id) 1 $rmx
3404 redrawtags $id
3408 proc drawlines {id} {
3409 global canv
3411 $canv itemconf lines.$id -width [linewidth $id]
3414 proc drawcmittext {id row col} {
3415 global linespc canv canv2 canv3 canvy0 fgcolor curview
3416 global commitlisted commitinfo rowidlist parentlist
3417 global rowtextx idpos idtags idheads idotherrefs
3418 global linehtag linentag linedtag
3419 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3421 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3422 set listed [lindex $commitlisted $row]
3423 if {$id eq $nullid} {
3424 set ofill red
3425 } elseif {$id eq $nullid2} {
3426 set ofill green
3427 } else {
3428 set ofill [expr {$listed != 0? "blue": "white"}]
3430 set x [xc $row $col]
3431 set y [yc $row]
3432 set orad [expr {$linespc / 3}]
3433 if {$listed <= 1} {
3434 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3435 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3436 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3437 } elseif {$listed == 2} {
3438 # triangle pointing left for left-side commits
3439 set t [$canv create polygon \
3440 [expr {$x - $orad}] $y \
3441 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3442 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3443 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3444 } else {
3445 # triangle pointing right for right-side commits
3446 set t [$canv create polygon \
3447 [expr {$x + $orad - 1}] $y \
3448 [expr {$x - $orad}] [expr {$y - $orad}] \
3449 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3450 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3452 $canv raise $t
3453 $canv bind $t <1> {selcanvline {} %x %y}
3454 set rmx [llength [lindex $rowidlist $row]]
3455 set olds [lindex $parentlist $row]
3456 if {$olds ne {}} {
3457 set nextids [lindex $rowidlist [expr {$row + 1}]]
3458 foreach p $olds {
3459 set i [lsearch -exact $nextids $p]
3460 if {$i > $rmx} {
3461 set rmx $i
3465 set xt [xc $row $rmx]
3466 set rowtextx($row) $xt
3467 set idpos($id) [list $x $xt $y]
3468 if {[info exists idtags($id)] || [info exists idheads($id)]
3469 || [info exists idotherrefs($id)]} {
3470 set xt [drawtags $id $x $xt $y]
3472 set headline [lindex $commitinfo($id) 0]
3473 set name [lindex $commitinfo($id) 1]
3474 set date [lindex $commitinfo($id) 2]
3475 set date [formatdate $date]
3476 set font $mainfont
3477 set nfont $mainfont
3478 set isbold [ishighlighted $row]
3479 if {$isbold > 0} {
3480 lappend boldrows $row
3481 lappend font bold
3482 if {$isbold > 1} {
3483 lappend boldnamerows $row
3484 lappend nfont bold
3487 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3488 -text $headline -font $font -tags text]
3489 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3490 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3491 -text $name -font $nfont -tags text]
3492 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3493 -text $date -font $mainfont -tags text]
3494 set xr [expr {$xt + [font measure $mainfont $headline]}]
3495 if {$xr > $canvxmax} {
3496 set canvxmax $xr
3497 setcanvscroll
3501 proc drawcmitrow {row} {
3502 global displayorder rowidlist
3503 global iddrawn markingmatches
3504 global commitinfo parentlist numcommits
3505 global filehighlight fhighlights findstring nhighlights
3506 global hlview vhighlights
3507 global highlight_related rhighlights
3509 if {$row >= $numcommits} return
3511 set id [lindex $displayorder $row]
3512 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3513 askvhighlight $row $id
3515 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3516 askfilehighlight $row $id
3518 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3519 askfindhighlight $row $id
3521 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3522 askrelhighlight $row $id
3524 if {![info exists iddrawn($id)]} {
3525 set col [lsearch -exact [lindex $rowidlist $row] $id]
3526 if {$col < 0} {
3527 puts "oops, row $row id $id not in list"
3528 return
3530 if {![info exists commitinfo($id)]} {
3531 getcommit $id
3533 assigncolor $id
3534 drawcmittext $id $row $col
3535 set iddrawn($id) 1
3537 if {$markingmatches} {
3538 markrowmatches $row $id
3542 proc drawcommits {row {endrow {}}} {
3543 global numcommits iddrawn displayorder curview
3544 global parentlist rowidlist
3546 if {$row < 0} {
3547 set row 0
3549 if {$endrow eq {}} {
3550 set endrow $row
3552 if {$endrow >= $numcommits} {
3553 set endrow [expr {$numcommits - 1}]
3556 # make the lines join to already-drawn rows either side
3557 set r [expr {$row - 1}]
3558 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3559 set r $row
3561 set er [expr {$endrow + 1}]
3562 if {$er >= $numcommits ||
3563 ![info exists iddrawn([lindex $displayorder $er])]} {
3564 set er $endrow
3566 for {} {$r <= $er} {incr r} {
3567 set id [lindex $displayorder $r]
3568 set wasdrawn [info exists iddrawn($id)]
3569 drawcmitrow $r
3570 if {$r == $er} break
3571 set nextid [lindex $displayorder [expr {$r + 1}]]
3572 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3573 catch {unset prevlines}
3574 continue
3576 drawparentlinks $id $r
3578 if {[info exists lineends($r)]} {
3579 foreach lid $lineends($r) {
3580 unset prevlines($lid)
3583 set rowids [lindex $rowidlist $r]
3584 foreach lid $rowids {
3585 if {$lid eq {}} continue
3586 if {$lid eq $id} {
3587 # see if this is the first child of any of its parents
3588 foreach p [lindex $parentlist $r] {
3589 if {[lsearch -exact $rowids $p] < 0} {
3590 # make this line extend up to the child
3591 set le [drawlineseg $p $r $er 0]
3592 lappend lineends($le) $p
3593 set prevlines($p) 1
3596 } elseif {![info exists prevlines($lid)]} {
3597 set le [drawlineseg $lid $r $er 1]
3598 lappend lineends($le) $lid
3599 set prevlines($lid) 1
3605 proc drawfrac {f0 f1} {
3606 global canv linespc
3608 set ymax [lindex [$canv cget -scrollregion] 3]
3609 if {$ymax eq {} || $ymax == 0} return
3610 set y0 [expr {int($f0 * $ymax)}]
3611 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3612 set y1 [expr {int($f1 * $ymax)}]
3613 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3614 drawcommits $row $endrow
3617 proc drawvisible {} {
3618 global canv
3619 eval drawfrac [$canv yview]
3622 proc clear_display {} {
3623 global iddrawn linesegs
3624 global vhighlights fhighlights nhighlights rhighlights
3626 allcanvs delete all
3627 catch {unset iddrawn}
3628 catch {unset linesegs}
3629 catch {unset vhighlights}
3630 catch {unset fhighlights}
3631 catch {unset nhighlights}
3632 catch {unset rhighlights}
3635 proc findcrossings {id} {
3636 global rowidlist parentlist numcommits rowoffsets displayorder
3638 set cross {}
3639 set ccross {}
3640 foreach {s e} [rowranges $id] {
3641 if {$e >= $numcommits} {
3642 set e [expr {$numcommits - 1}]
3644 if {$e <= $s} continue
3645 set x [lsearch -exact [lindex $rowidlist $e] $id]
3646 if {$x < 0} {
3647 puts "findcrossings: oops, no [shortids $id] in row $e"
3648 continue
3650 for {set row $e} {[incr row -1] >= $s} {} {
3651 set olds [lindex $parentlist $row]
3652 set kid [lindex $displayorder $row]
3653 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3654 if {$kidx < 0} continue
3655 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3656 foreach p $olds {
3657 set px [lsearch -exact $nextrow $p]
3658 if {$px < 0} continue
3659 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3660 if {[lsearch -exact $ccross $p] >= 0} continue
3661 if {$x == $px + ($kidx < $px? -1: 1)} {
3662 lappend ccross $p
3663 } elseif {[lsearch -exact $cross $p] < 0} {
3664 lappend cross $p
3668 set inc [lindex $rowoffsets $row $x]
3669 if {$inc eq {}} break
3670 incr x $inc
3673 return [concat $ccross {{}} $cross]
3676 proc assigncolor {id} {
3677 global colormap colors nextcolor
3678 global commitrow parentlist children children curview
3680 if {[info exists colormap($id)]} return
3681 set ncolors [llength $colors]
3682 if {[info exists children($curview,$id)]} {
3683 set kids $children($curview,$id)
3684 } else {
3685 set kids {}
3687 if {[llength $kids] == 1} {
3688 set child [lindex $kids 0]
3689 if {[info exists colormap($child)]
3690 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3691 set colormap($id) $colormap($child)
3692 return
3695 set badcolors {}
3696 set origbad {}
3697 foreach x [findcrossings $id] {
3698 if {$x eq {}} {
3699 # delimiter between corner crossings and other crossings
3700 if {[llength $badcolors] >= $ncolors - 1} break
3701 set origbad $badcolors
3703 if {[info exists colormap($x)]
3704 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3705 lappend badcolors $colormap($x)
3708 if {[llength $badcolors] >= $ncolors} {
3709 set badcolors $origbad
3711 set origbad $badcolors
3712 if {[llength $badcolors] < $ncolors - 1} {
3713 foreach child $kids {
3714 if {[info exists colormap($child)]
3715 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3716 lappend badcolors $colormap($child)
3718 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3719 if {[info exists colormap($p)]
3720 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3721 lappend badcolors $colormap($p)
3725 if {[llength $badcolors] >= $ncolors} {
3726 set badcolors $origbad
3729 for {set i 0} {$i <= $ncolors} {incr i} {
3730 set c [lindex $colors $nextcolor]
3731 if {[incr nextcolor] >= $ncolors} {
3732 set nextcolor 0
3734 if {[lsearch -exact $badcolors $c]} break
3736 set colormap($id) $c
3739 proc bindline {t id} {
3740 global canv
3742 $canv bind $t <Enter> "lineenter %x %y $id"
3743 $canv bind $t <Motion> "linemotion %x %y $id"
3744 $canv bind $t <Leave> "lineleave $id"
3745 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3748 proc drawtags {id x xt y1} {
3749 global idtags idheads idotherrefs mainhead
3750 global linespc lthickness
3751 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3753 set marks {}
3754 set ntags 0
3755 set nheads 0
3756 if {[info exists idtags($id)]} {
3757 set marks $idtags($id)
3758 set ntags [llength $marks]
3760 if {[info exists idheads($id)]} {
3761 set marks [concat $marks $idheads($id)]
3762 set nheads [llength $idheads($id)]
3764 if {[info exists idotherrefs($id)]} {
3765 set marks [concat $marks $idotherrefs($id)]
3767 if {$marks eq {}} {
3768 return $xt
3771 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3772 set yt [expr {$y1 - 0.5 * $linespc}]
3773 set yb [expr {$yt + $linespc - 1}]
3774 set xvals {}
3775 set wvals {}
3776 set i -1
3777 foreach tag $marks {
3778 incr i
3779 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3780 set wid [font measure [concat $mainfont bold] $tag]
3781 } else {
3782 set wid [font measure $mainfont $tag]
3784 lappend xvals $xt
3785 lappend wvals $wid
3786 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3788 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3789 -width $lthickness -fill black -tags tag.$id]
3790 $canv lower $t
3791 foreach tag $marks x $xvals wid $wvals {
3792 set xl [expr {$x + $delta}]
3793 set xr [expr {$x + $delta + $wid + $lthickness}]
3794 set font $mainfont
3795 if {[incr ntags -1] >= 0} {
3796 # draw a tag
3797 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3798 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3799 -width 1 -outline black -fill yellow -tags tag.$id]
3800 $canv bind $t <1> [list showtag $tag 1]
3801 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3802 } else {
3803 # draw a head or other ref
3804 if {[incr nheads -1] >= 0} {
3805 set col green
3806 if {$tag eq $mainhead} {
3807 lappend font bold
3809 } else {
3810 set col "#ddddff"
3812 set xl [expr {$xl - $delta/2}]
3813 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3814 -width 1 -outline black -fill $col -tags tag.$id
3815 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3816 set rwid [font measure $mainfont $remoteprefix]
3817 set xi [expr {$x + 1}]
3818 set yti [expr {$yt + 1}]
3819 set xri [expr {$x + $rwid}]
3820 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3821 -width 0 -fill "#ffddaa" -tags tag.$id
3824 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3825 -font $font -tags [list tag.$id text]]
3826 if {$ntags >= 0} {
3827 $canv bind $t <1> [list showtag $tag 1]
3828 } elseif {$nheads >= 0} {
3829 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3832 return $xt
3835 proc xcoord {i level ln} {
3836 global canvx0 xspc1 xspc2
3838 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3839 if {$i > 0 && $i == $level} {
3840 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3841 } elseif {$i > $level} {
3842 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3844 return $x
3847 proc show_status {msg} {
3848 global canv mainfont fgcolor
3850 clear_display
3851 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3852 -tags text -fill $fgcolor
3855 # Insert a new commit as the child of the commit on row $row.
3856 # The new commit will be displayed on row $row and the commits
3857 # on that row and below will move down one row.
3858 proc insertrow {row newcmit} {
3859 global displayorder parentlist commitlisted children
3860 global commitrow curview rowidlist rowoffsets numcommits
3861 global rowrangelist rowlaidout rowoptim numcommits
3862 global selectedline rowchk commitidx
3864 if {$row >= $numcommits} {
3865 puts "oops, inserting new row $row but only have $numcommits rows"
3866 return
3868 set p [lindex $displayorder $row]
3869 set displayorder [linsert $displayorder $row $newcmit]
3870 set parentlist [linsert $parentlist $row $p]
3871 set kids $children($curview,$p)
3872 lappend kids $newcmit
3873 set children($curview,$p) $kids
3874 set children($curview,$newcmit) {}
3875 set commitlisted [linsert $commitlisted $row 1]
3876 set l [llength $displayorder]
3877 for {set r $row} {$r < $l} {incr r} {
3878 set id [lindex $displayorder $r]
3879 set commitrow($curview,$id) $r
3881 incr commitidx($curview)
3883 set idlist [lindex $rowidlist $row]
3884 set offs [lindex $rowoffsets $row]
3885 set newoffs {}
3886 foreach x $idlist {
3887 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3888 lappend newoffs {}
3889 } else {
3890 lappend newoffs 0
3893 if {[llength $kids] == 1} {
3894 set col [lsearch -exact $idlist $p]
3895 lset idlist $col $newcmit
3896 } else {
3897 set col [llength $idlist]
3898 lappend idlist $newcmit
3899 lappend offs {}
3900 lset rowoffsets $row $offs
3902 set rowidlist [linsert $rowidlist $row $idlist]
3903 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3905 set rowrangelist [linsert $rowrangelist $row {}]
3906 if {[llength $kids] > 1} {
3907 set rp1 [expr {$row + 1}]
3908 set ranges [lindex $rowrangelist $rp1]
3909 if {$ranges eq {}} {
3910 set ranges [list $newcmit $p]
3911 } elseif {[lindex $ranges end-1] eq $p} {
3912 lset ranges end-1 $newcmit
3914 lset rowrangelist $rp1 $ranges
3917 catch {unset rowchk}
3919 incr rowlaidout
3920 incr rowoptim
3921 incr numcommits
3923 if {[info exists selectedline] && $selectedline >= $row} {
3924 incr selectedline
3926 redisplay
3929 # Remove a commit that was inserted with insertrow on row $row.
3930 proc removerow {row} {
3931 global displayorder parentlist commitlisted children
3932 global commitrow curview rowidlist rowoffsets numcommits
3933 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3934 global linesegends selectedline rowchk commitidx
3936 if {$row >= $numcommits} {
3937 puts "oops, removing row $row but only have $numcommits rows"
3938 return
3940 set rp1 [expr {$row + 1}]
3941 set id [lindex $displayorder $row]
3942 set p [lindex $parentlist $row]
3943 set displayorder [lreplace $displayorder $row $row]
3944 set parentlist [lreplace $parentlist $row $row]
3945 set commitlisted [lreplace $commitlisted $row $row]
3946 set kids $children($curview,$p)
3947 set i [lsearch -exact $kids $id]
3948 if {$i >= 0} {
3949 set kids [lreplace $kids $i $i]
3950 set children($curview,$p) $kids
3952 set l [llength $displayorder]
3953 for {set r $row} {$r < $l} {incr r} {
3954 set id [lindex $displayorder $r]
3955 set commitrow($curview,$id) $r
3957 incr commitidx($curview) -1
3959 set rowidlist [lreplace $rowidlist $row $row]
3960 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3961 if {$kids ne {}} {
3962 set offs [lindex $rowoffsets $row]
3963 set offs [lreplace $offs end end]
3964 lset rowoffsets $row $offs
3967 set rowrangelist [lreplace $rowrangelist $row $row]
3968 if {[llength $kids] > 0} {
3969 set ranges [lindex $rowrangelist $row]
3970 if {[lindex $ranges end-1] eq $id} {
3971 set ranges [lreplace $ranges end-1 end]
3972 lset rowrangelist $row $ranges
3976 catch {unset rowchk}
3978 incr rowlaidout -1
3979 incr rowoptim -1
3980 incr numcommits -1
3982 if {[info exists selectedline] && $selectedline > $row} {
3983 incr selectedline -1
3985 redisplay
3988 # Don't change the text pane cursor if it is currently the hand cursor,
3989 # showing that we are over a sha1 ID link.
3990 proc settextcursor {c} {
3991 global ctext curtextcursor
3993 if {[$ctext cget -cursor] == $curtextcursor} {
3994 $ctext config -cursor $c
3996 set curtextcursor $c
3999 proc nowbusy {what} {
4000 global isbusy
4002 if {[array names isbusy] eq {}} {
4003 . config -cursor watch
4004 settextcursor watch
4006 set isbusy($what) 1
4009 proc notbusy {what} {
4010 global isbusy maincursor textcursor
4012 catch {unset isbusy($what)}
4013 if {[array names isbusy] eq {}} {
4014 . config -cursor $maincursor
4015 settextcursor $textcursor
4019 proc findmatches {f} {
4020 global findtype findstring
4021 if {$findtype == "Regexp"} {
4022 set matches [regexp -indices -all -inline $findstring $f]
4023 } else {
4024 set fs $findstring
4025 if {$findtype == "IgnCase"} {
4026 set f [string tolower $f]
4027 set fs [string tolower $fs]
4029 set matches {}
4030 set i 0
4031 set l [string length $fs]
4032 while {[set j [string first $fs $f $i]] >= 0} {
4033 lappend matches [list $j [expr {$j+$l-1}]]
4034 set i [expr {$j + $l}]
4037 return $matches
4040 proc dofind {{rev 0}} {
4041 global findstring findstartline findcurline selectedline numcommits
4043 unmarkmatches
4044 cancel_next_highlight
4045 focus .
4046 if {$findstring eq {} || $numcommits == 0} return
4047 if {![info exists selectedline]} {
4048 set findstartline [lindex [visiblerows] $rev]
4049 } else {
4050 set findstartline $selectedline
4052 set findcurline $findstartline
4053 nowbusy finding
4054 if {!$rev} {
4055 run findmore
4056 } else {
4057 if {$findcurline == 0} {
4058 set findcurline $numcommits
4060 incr findcurline -1
4061 run findmorerev
4065 proc findnext {restart} {
4066 global findcurline
4067 if {![info exists findcurline]} {
4068 if {$restart} {
4069 dofind
4070 } else {
4071 bell
4073 } else {
4074 run findmore
4075 nowbusy finding
4079 proc findprev {} {
4080 global findcurline
4081 if {![info exists findcurline]} {
4082 dofind 1
4083 } else {
4084 run findmorerev
4085 nowbusy finding
4089 proc findmore {} {
4090 global commitdata commitinfo numcommits findstring findpattern findloc
4091 global findstartline findcurline displayorder
4093 set fldtypes {Headline Author Date Committer CDate Comments}
4094 set l [expr {$findcurline + 1}]
4095 if {$l >= $numcommits} {
4096 set l 0
4098 if {$l <= $findstartline} {
4099 set lim [expr {$findstartline + 1}]
4100 } else {
4101 set lim $numcommits
4103 if {$lim - $l > 500} {
4104 set lim [expr {$l + 500}]
4106 set last 0
4107 for {} {$l < $lim} {incr l} {
4108 set id [lindex $displayorder $l]
4109 # shouldn't happen unless git log doesn't give all the commits...
4110 if {![info exists commitdata($id)]} continue
4111 if {![doesmatch $commitdata($id)]} continue
4112 if {![info exists commitinfo($id)]} {
4113 getcommit $id
4115 set info $commitinfo($id)
4116 foreach f $info ty $fldtypes {
4117 if {($findloc eq "All fields" || $findloc eq $ty) &&
4118 [doesmatch $f]} {
4119 findselectline $l
4120 notbusy finding
4121 return 0
4125 if {$l == $findstartline + 1} {
4126 bell
4127 unset findcurline
4128 notbusy finding
4129 return 0
4131 set findcurline [expr {$l - 1}]
4132 return 1
4135 proc findmorerev {} {
4136 global commitdata commitinfo numcommits findstring findpattern findloc
4137 global findstartline findcurline displayorder
4139 set fldtypes {Headline Author Date Committer CDate Comments}
4140 set l $findcurline
4141 if {$l == 0} {
4142 set l $numcommits
4144 incr l -1
4145 if {$l >= $findstartline} {
4146 set lim [expr {$findstartline - 1}]
4147 } else {
4148 set lim -1
4150 if {$l - $lim > 500} {
4151 set lim [expr {$l - 500}]
4153 set last 0
4154 for {} {$l > $lim} {incr l -1} {
4155 set id [lindex $displayorder $l]
4156 if {![doesmatch $commitdata($id)]} continue
4157 if {![info exists commitinfo($id)]} {
4158 getcommit $id
4160 set info $commitinfo($id)
4161 foreach f $info ty $fldtypes {
4162 if {($findloc eq "All fields" || $findloc eq $ty) &&
4163 [doesmatch $f]} {
4164 findselectline $l
4165 notbusy finding
4166 return 0
4170 if {$l == -1} {
4171 bell
4172 unset findcurline
4173 notbusy finding
4174 return 0
4176 set findcurline [expr {$l + 1}]
4177 return 1
4180 proc findselectline {l} {
4181 global findloc commentend ctext findcurline markingmatches
4183 set markingmatches 1
4184 set findcurline $l
4185 selectline $l 1
4186 if {$findloc == "All fields" || $findloc == "Comments"} {
4187 # highlight the matches in the comments
4188 set f [$ctext get 1.0 $commentend]
4189 set matches [findmatches $f]
4190 foreach match $matches {
4191 set start [lindex $match 0]
4192 set end [expr {[lindex $match 1] + 1}]
4193 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4196 drawvisible
4199 # mark the bits of a headline or author that match a find string
4200 proc markmatches {canv l str tag matches font row} {
4201 global selectedline
4203 set bbox [$canv bbox $tag]
4204 set x0 [lindex $bbox 0]
4205 set y0 [lindex $bbox 1]
4206 set y1 [lindex $bbox 3]
4207 foreach match $matches {
4208 set start [lindex $match 0]
4209 set end [lindex $match 1]
4210 if {$start > $end} continue
4211 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4212 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4213 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4214 [expr {$x0+$xlen+2}] $y1 \
4215 -outline {} -tags [list match$l matches] -fill yellow]
4216 $canv lower $t
4217 if {[info exists selectedline] && $row == $selectedline} {
4218 $canv raise $t secsel
4223 proc unmarkmatches {} {
4224 global findids markingmatches findcurline
4226 allcanvs delete matches
4227 catch {unset findids}
4228 set markingmatches 0
4229 catch {unset findcurline}
4232 proc selcanvline {w x y} {
4233 global canv canvy0 ctext linespc
4234 global rowtextx
4235 set ymax [lindex [$canv cget -scrollregion] 3]
4236 if {$ymax == {}} return
4237 set yfrac [lindex [$canv yview] 0]
4238 set y [expr {$y + $yfrac * $ymax}]
4239 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4240 if {$l < 0} {
4241 set l 0
4243 if {$w eq $canv} {
4244 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4246 unmarkmatches
4247 selectline $l 1
4250 proc commit_descriptor {p} {
4251 global commitinfo
4252 if {![info exists commitinfo($p)]} {
4253 getcommit $p
4255 set l "..."
4256 if {[llength $commitinfo($p)] > 1} {
4257 set l [lindex $commitinfo($p) 0]
4259 return "$p ($l)\n"
4262 # append some text to the ctext widget, and make any SHA1 ID
4263 # that we know about be a clickable link.
4264 proc appendwithlinks {text tags} {
4265 global ctext commitrow linknum curview
4267 set start [$ctext index "end - 1c"]
4268 $ctext insert end $text $tags
4269 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4270 foreach l $links {
4271 set s [lindex $l 0]
4272 set e [lindex $l 1]
4273 set linkid [string range $text $s $e]
4274 if {![info exists commitrow($curview,$linkid)]} continue
4275 incr e
4276 $ctext tag add link "$start + $s c" "$start + $e c"
4277 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4278 $ctext tag bind link$linknum <1> \
4279 [list selectline $commitrow($curview,$linkid) 1]
4280 incr linknum
4282 $ctext tag conf link -foreground blue -underline 1
4283 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4284 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4287 proc viewnextline {dir} {
4288 global canv linespc
4290 $canv delete hover
4291 set ymax [lindex [$canv cget -scrollregion] 3]
4292 set wnow [$canv yview]
4293 set wtop [expr {[lindex $wnow 0] * $ymax}]
4294 set newtop [expr {$wtop + $dir * $linespc}]
4295 if {$newtop < 0} {
4296 set newtop 0
4297 } elseif {$newtop > $ymax} {
4298 set newtop $ymax
4300 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4303 # add a list of tag or branch names at position pos
4304 # returns the number of names inserted
4305 proc appendrefs {pos ids var} {
4306 global ctext commitrow linknum curview $var maxrefs
4308 if {[catch {$ctext index $pos}]} {
4309 return 0
4311 $ctext conf -state normal
4312 $ctext delete $pos "$pos lineend"
4313 set tags {}
4314 foreach id $ids {
4315 foreach tag [set $var\($id\)] {
4316 lappend tags [list $tag $id]
4319 if {[llength $tags] > $maxrefs} {
4320 $ctext insert $pos "many ([llength $tags])"
4321 } else {
4322 set tags [lsort -index 0 -decreasing $tags]
4323 set sep {}
4324 foreach ti $tags {
4325 set id [lindex $ti 1]
4326 set lk link$linknum
4327 incr linknum
4328 $ctext tag delete $lk
4329 $ctext insert $pos $sep
4330 $ctext insert $pos [lindex $ti 0] $lk
4331 if {[info exists commitrow($curview,$id)]} {
4332 $ctext tag conf $lk -foreground blue
4333 $ctext tag bind $lk <1> \
4334 [list selectline $commitrow($curview,$id) 1]
4335 $ctext tag conf $lk -underline 1
4336 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4337 $ctext tag bind $lk <Leave> \
4338 { %W configure -cursor $curtextcursor }
4340 set sep ", "
4343 $ctext conf -state disabled
4344 return [llength $tags]
4347 # called when we have finished computing the nearby tags
4348 proc dispneartags {delay} {
4349 global selectedline currentid showneartags tagphase
4351 if {![info exists selectedline] || !$showneartags} return
4352 after cancel dispnexttag
4353 if {$delay} {
4354 after 200 dispnexttag
4355 set tagphase -1
4356 } else {
4357 after idle dispnexttag
4358 set tagphase 0
4362 proc dispnexttag {} {
4363 global selectedline currentid showneartags tagphase ctext
4365 if {![info exists selectedline] || !$showneartags} return
4366 switch -- $tagphase {
4368 set dtags [desctags $currentid]
4369 if {$dtags ne {}} {
4370 appendrefs precedes $dtags idtags
4374 set atags [anctags $currentid]
4375 if {$atags ne {}} {
4376 appendrefs follows $atags idtags
4380 set dheads [descheads $currentid]
4381 if {$dheads ne {}} {
4382 if {[appendrefs branch $dheads idheads] > 1
4383 && [$ctext get "branch -3c"] eq "h"} {
4384 # turn "Branch" into "Branches"
4385 $ctext conf -state normal
4386 $ctext insert "branch -2c" "es"
4387 $ctext conf -state disabled
4392 if {[incr tagphase] <= 2} {
4393 after idle dispnexttag
4397 proc selectline {l isnew} {
4398 global canv canv2 canv3 ctext commitinfo selectedline
4399 global displayorder linehtag linentag linedtag
4400 global canvy0 linespc parentlist children curview
4401 global currentid sha1entry
4402 global commentend idtags linknum
4403 global mergemax numcommits pending_select
4404 global cmitmode showneartags allcommits
4406 catch {unset pending_select}
4407 $canv delete hover
4408 normalline
4409 cancel_next_highlight
4410 if {$l < 0 || $l >= $numcommits} return
4411 set y [expr {$canvy0 + $l * $linespc}]
4412 set ymax [lindex [$canv cget -scrollregion] 3]
4413 set ytop [expr {$y - $linespc - 1}]
4414 set ybot [expr {$y + $linespc + 1}]
4415 set wnow [$canv yview]
4416 set wtop [expr {[lindex $wnow 0] * $ymax}]
4417 set wbot [expr {[lindex $wnow 1] * $ymax}]
4418 set wh [expr {$wbot - $wtop}]
4419 set newtop $wtop
4420 if {$ytop < $wtop} {
4421 if {$ybot < $wtop} {
4422 set newtop [expr {$y - $wh / 2.0}]
4423 } else {
4424 set newtop $ytop
4425 if {$newtop > $wtop - $linespc} {
4426 set newtop [expr {$wtop - $linespc}]
4429 } elseif {$ybot > $wbot} {
4430 if {$ytop > $wbot} {
4431 set newtop [expr {$y - $wh / 2.0}]
4432 } else {
4433 set newtop [expr {$ybot - $wh}]
4434 if {$newtop < $wtop + $linespc} {
4435 set newtop [expr {$wtop + $linespc}]
4439 if {$newtop != $wtop} {
4440 if {$newtop < 0} {
4441 set newtop 0
4443 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4444 drawvisible
4447 if {![info exists linehtag($l)]} return
4448 $canv delete secsel
4449 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4450 -tags secsel -fill [$canv cget -selectbackground]]
4451 $canv lower $t
4452 $canv2 delete secsel
4453 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4454 -tags secsel -fill [$canv2 cget -selectbackground]]
4455 $canv2 lower $t
4456 $canv3 delete secsel
4457 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4458 -tags secsel -fill [$canv3 cget -selectbackground]]
4459 $canv3 lower $t
4461 if {$isnew} {
4462 addtohistory [list selectline $l 0]
4465 set selectedline $l
4467 set id [lindex $displayorder $l]
4468 set currentid $id
4469 $sha1entry delete 0 end
4470 $sha1entry insert 0 $id
4471 $sha1entry selection from 0
4472 $sha1entry selection to end
4473 rhighlight_sel $id
4475 $ctext conf -state normal
4476 clear_ctext
4477 set linknum 0
4478 set info $commitinfo($id)
4479 set date [formatdate [lindex $info 2]]
4480 $ctext insert end "Author: [lindex $info 1] $date\n"
4481 set date [formatdate [lindex $info 4]]
4482 $ctext insert end "Committer: [lindex $info 3] $date\n"
4483 if {[info exists idtags($id)]} {
4484 $ctext insert end "Tags:"
4485 foreach tag $idtags($id) {
4486 $ctext insert end " $tag"
4488 $ctext insert end "\n"
4491 set headers {}
4492 set olds [lindex $parentlist $l]
4493 if {[llength $olds] > 1} {
4494 set np 0
4495 foreach p $olds {
4496 if {$np >= $mergemax} {
4497 set tag mmax
4498 } else {
4499 set tag m$np
4501 $ctext insert end "Parent: " $tag
4502 appendwithlinks [commit_descriptor $p] {}
4503 incr np
4505 } else {
4506 foreach p $olds {
4507 append headers "Parent: [commit_descriptor $p]"
4511 foreach c $children($curview,$id) {
4512 append headers "Child: [commit_descriptor $c]"
4515 # make anything that looks like a SHA1 ID be a clickable link
4516 appendwithlinks $headers {}
4517 if {$showneartags} {
4518 if {![info exists allcommits]} {
4519 getallcommits
4521 $ctext insert end "Branch: "
4522 $ctext mark set branch "end -1c"
4523 $ctext mark gravity branch left
4524 $ctext insert end "\nFollows: "
4525 $ctext mark set follows "end -1c"
4526 $ctext mark gravity follows left
4527 $ctext insert end "\nPrecedes: "
4528 $ctext mark set precedes "end -1c"
4529 $ctext mark gravity precedes left
4530 $ctext insert end "\n"
4531 dispneartags 1
4533 $ctext insert end "\n"
4534 set comment [lindex $info 5]
4535 if {[string first "\r" $comment] >= 0} {
4536 set comment [string map {"\r" "\n "} $comment]
4538 appendwithlinks $comment {comment}
4540 $ctext tag remove found 1.0 end
4541 $ctext conf -state disabled
4542 set commentend [$ctext index "end - 1c"]
4544 init_flist "Comments"
4545 if {$cmitmode eq "tree"} {
4546 gettree $id
4547 } elseif {[llength $olds] <= 1} {
4548 startdiff $id
4549 } else {
4550 mergediff $id $l
4554 proc selfirstline {} {
4555 unmarkmatches
4556 selectline 0 1
4559 proc sellastline {} {
4560 global numcommits
4561 unmarkmatches
4562 set l [expr {$numcommits - 1}]
4563 selectline $l 1
4566 proc selnextline {dir} {
4567 global selectedline
4568 if {![info exists selectedline]} return
4569 set l [expr {$selectedline + $dir}]
4570 unmarkmatches
4571 selectline $l 1
4574 proc selnextpage {dir} {
4575 global canv linespc selectedline numcommits
4577 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4578 if {$lpp < 1} {
4579 set lpp 1
4581 allcanvs yview scroll [expr {$dir * $lpp}] units
4582 drawvisible
4583 if {![info exists selectedline]} return
4584 set l [expr {$selectedline + $dir * $lpp}]
4585 if {$l < 0} {
4586 set l 0
4587 } elseif {$l >= $numcommits} {
4588 set l [expr $numcommits - 1]
4590 unmarkmatches
4591 selectline $l 1
4594 proc unselectline {} {
4595 global selectedline currentid
4597 catch {unset selectedline}
4598 catch {unset currentid}
4599 allcanvs delete secsel
4600 rhighlight_none
4601 cancel_next_highlight
4604 proc reselectline {} {
4605 global selectedline
4607 if {[info exists selectedline]} {
4608 selectline $selectedline 0
4612 proc addtohistory {cmd} {
4613 global history historyindex curview
4615 set elt [list $curview $cmd]
4616 if {$historyindex > 0
4617 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4618 return
4621 if {$historyindex < [llength $history]} {
4622 set history [lreplace $history $historyindex end $elt]
4623 } else {
4624 lappend history $elt
4626 incr historyindex
4627 if {$historyindex > 1} {
4628 .tf.bar.leftbut conf -state normal
4629 } else {
4630 .tf.bar.leftbut conf -state disabled
4632 .tf.bar.rightbut conf -state disabled
4635 proc godo {elt} {
4636 global curview
4638 set view [lindex $elt 0]
4639 set cmd [lindex $elt 1]
4640 if {$curview != $view} {
4641 showview $view
4643 eval $cmd
4646 proc goback {} {
4647 global history historyindex
4649 if {$historyindex > 1} {
4650 incr historyindex -1
4651 godo [lindex $history [expr {$historyindex - 1}]]
4652 .tf.bar.rightbut conf -state normal
4654 if {$historyindex <= 1} {
4655 .tf.bar.leftbut conf -state disabled
4659 proc goforw {} {
4660 global history historyindex
4662 if {$historyindex < [llength $history]} {
4663 set cmd [lindex $history $historyindex]
4664 incr historyindex
4665 godo $cmd
4666 .tf.bar.leftbut conf -state normal
4668 if {$historyindex >= [llength $history]} {
4669 .tf.bar.rightbut conf -state disabled
4673 proc gettree {id} {
4674 global treefilelist treeidlist diffids diffmergeid treepending
4675 global nullid nullid2
4677 set diffids $id
4678 catch {unset diffmergeid}
4679 if {![info exists treefilelist($id)]} {
4680 if {![info exists treepending]} {
4681 if {$id eq $nullid} {
4682 set cmd [list | git ls-files]
4683 } elseif {$id eq $nullid2} {
4684 set cmd [list | git ls-files --stage -t]
4685 } else {
4686 set cmd [list | git ls-tree -r $id]
4688 if {[catch {set gtf [open $cmd r]}]} {
4689 return
4691 set treepending $id
4692 set treefilelist($id) {}
4693 set treeidlist($id) {}
4694 fconfigure $gtf -blocking 0
4695 filerun $gtf [list gettreeline $gtf $id]
4697 } else {
4698 setfilelist $id
4702 proc gettreeline {gtf id} {
4703 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4705 set nl 0
4706 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4707 if {$diffids eq $nullid} {
4708 set fname $line
4709 } else {
4710 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4711 set i [string first "\t" $line]
4712 if {$i < 0} continue
4713 set sha1 [lindex $line 2]
4714 set fname [string range $line [expr {$i+1}] end]
4715 if {[string index $fname 0] eq "\""} {
4716 set fname [lindex $fname 0]
4718 lappend treeidlist($id) $sha1
4720 lappend treefilelist($id) $fname
4722 if {![eof $gtf]} {
4723 return [expr {$nl >= 1000? 2: 1}]
4725 close $gtf
4726 unset treepending
4727 if {$cmitmode ne "tree"} {
4728 if {![info exists diffmergeid]} {
4729 gettreediffs $diffids
4731 } elseif {$id ne $diffids} {
4732 gettree $diffids
4733 } else {
4734 setfilelist $id
4736 return 0
4739 proc showfile {f} {
4740 global treefilelist treeidlist diffids nullid nullid2
4741 global ctext commentend
4743 set i [lsearch -exact $treefilelist($diffids) $f]
4744 if {$i < 0} {
4745 puts "oops, $f not in list for id $diffids"
4746 return
4748 if {$diffids eq $nullid} {
4749 if {[catch {set bf [open $f r]} err]} {
4750 puts "oops, can't read $f: $err"
4751 return
4753 } else {
4754 set blob [lindex $treeidlist($diffids) $i]
4755 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4756 puts "oops, error reading blob $blob: $err"
4757 return
4760 fconfigure $bf -blocking 0
4761 filerun $bf [list getblobline $bf $diffids]
4762 $ctext config -state normal
4763 clear_ctext $commentend
4764 $ctext insert end "\n"
4765 $ctext insert end "$f\n" filesep
4766 $ctext config -state disabled
4767 $ctext yview $commentend
4770 proc getblobline {bf id} {
4771 global diffids cmitmode ctext
4773 if {$id ne $diffids || $cmitmode ne "tree"} {
4774 catch {close $bf}
4775 return 0
4777 $ctext config -state normal
4778 set nl 0
4779 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4780 $ctext insert end "$line\n"
4782 if {[eof $bf]} {
4783 # delete last newline
4784 $ctext delete "end - 2c" "end - 1c"
4785 close $bf
4786 return 0
4788 $ctext config -state disabled
4789 return [expr {$nl >= 1000? 2: 1}]
4792 proc mergediff {id l} {
4793 global diffmergeid diffopts mdifffd
4794 global diffids
4795 global parentlist
4797 set diffmergeid $id
4798 set diffids $id
4799 # this doesn't seem to actually affect anything...
4800 set env(GIT_DIFF_OPTS) $diffopts
4801 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4802 if {[catch {set mdf [open $cmd r]} err]} {
4803 error_popup "Error getting merge diffs: $err"
4804 return
4806 fconfigure $mdf -blocking 0
4807 set mdifffd($id) $mdf
4808 set np [llength [lindex $parentlist $l]]
4809 filerun $mdf [list getmergediffline $mdf $id $np]
4812 proc getmergediffline {mdf id np} {
4813 global diffmergeid ctext cflist mergemax
4814 global difffilestart mdifffd
4816 $ctext conf -state normal
4817 set nr 0
4818 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4819 if {![info exists diffmergeid] || $id != $diffmergeid
4820 || $mdf != $mdifffd($id)} {
4821 close $mdf
4822 return 0
4824 if {[regexp {^diff --cc (.*)} $line match fname]} {
4825 # start of a new file
4826 $ctext insert end "\n"
4827 set here [$ctext index "end - 1c"]
4828 lappend difffilestart $here
4829 add_flist [list $fname]
4830 set l [expr {(78 - [string length $fname]) / 2}]
4831 set pad [string range "----------------------------------------" 1 $l]
4832 $ctext insert end "$pad $fname $pad\n" filesep
4833 } elseif {[regexp {^@@} $line]} {
4834 $ctext insert end "$line\n" hunksep
4835 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4836 # do nothing
4837 } else {
4838 # parse the prefix - one ' ', '-' or '+' for each parent
4839 set spaces {}
4840 set minuses {}
4841 set pluses {}
4842 set isbad 0
4843 for {set j 0} {$j < $np} {incr j} {
4844 set c [string range $line $j $j]
4845 if {$c == " "} {
4846 lappend spaces $j
4847 } elseif {$c == "-"} {
4848 lappend minuses $j
4849 } elseif {$c == "+"} {
4850 lappend pluses $j
4851 } else {
4852 set isbad 1
4853 break
4856 set tags {}
4857 set num {}
4858 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4859 # line doesn't appear in result, parents in $minuses have the line
4860 set num [lindex $minuses 0]
4861 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4862 # line appears in result, parents in $pluses don't have the line
4863 lappend tags mresult
4864 set num [lindex $spaces 0]
4866 if {$num ne {}} {
4867 if {$num >= $mergemax} {
4868 set num "max"
4870 lappend tags m$num
4872 $ctext insert end "$line\n" $tags
4875 $ctext conf -state disabled
4876 if {[eof $mdf]} {
4877 close $mdf
4878 return 0
4880 return [expr {$nr >= 1000? 2: 1}]
4883 proc startdiff {ids} {
4884 global treediffs diffids treepending diffmergeid nullid nullid2
4886 set diffids $ids
4887 catch {unset diffmergeid}
4888 if {![info exists treediffs($ids)] ||
4889 [lsearch -exact $ids $nullid] >= 0 ||
4890 [lsearch -exact $ids $nullid2] >= 0} {
4891 if {![info exists treepending]} {
4892 gettreediffs $ids
4894 } else {
4895 addtocflist $ids
4899 proc addtocflist {ids} {
4900 global treediffs cflist
4901 add_flist $treediffs($ids)
4902 getblobdiffs $ids
4905 proc diffcmd {ids flags} {
4906 global nullid nullid2
4908 set i [lsearch -exact $ids $nullid]
4909 set j [lsearch -exact $ids $nullid2]
4910 if {$i >= 0} {
4911 if {[llength $ids] > 1 && $j < 0} {
4912 # comparing working directory with some specific revision
4913 set cmd [concat | git diff-index $flags]
4914 if {$i == 0} {
4915 lappend cmd -R [lindex $ids 1]
4916 } else {
4917 lappend cmd [lindex $ids 0]
4919 } else {
4920 # comparing working directory with index
4921 set cmd [concat | git diff-files $flags]
4922 if {$j == 1} {
4923 lappend cmd -R
4926 } elseif {$j >= 0} {
4927 set cmd [concat | git diff-index --cached $flags]
4928 if {[llength $ids] > 1} {
4929 # comparing index with specific revision
4930 if {$i == 0} {
4931 lappend cmd -R [lindex $ids 1]
4932 } else {
4933 lappend cmd [lindex $ids 0]
4935 } else {
4936 # comparing index with HEAD
4937 lappend cmd HEAD
4939 } else {
4940 set cmd [concat | git diff-tree -r $flags $ids]
4942 return $cmd
4945 proc gettreediffs {ids} {
4946 global treediff treepending
4948 set treepending $ids
4949 set treediff {}
4950 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4951 fconfigure $gdtf -blocking 0
4952 filerun $gdtf [list gettreediffline $gdtf $ids]
4955 proc gettreediffline {gdtf ids} {
4956 global treediff treediffs treepending diffids diffmergeid
4957 global cmitmode
4959 set nr 0
4960 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4961 set i [string first "\t" $line]
4962 if {$i >= 0} {
4963 set file [string range $line [expr {$i+1}] end]
4964 if {[string index $file 0] eq "\""} {
4965 set file [lindex $file 0]
4967 lappend treediff $file
4970 if {![eof $gdtf]} {
4971 return [expr {$nr >= 1000? 2: 1}]
4973 close $gdtf
4974 set treediffs($ids) $treediff
4975 unset treepending
4976 if {$cmitmode eq "tree"} {
4977 gettree $diffids
4978 } elseif {$ids != $diffids} {
4979 if {![info exists diffmergeid]} {
4980 gettreediffs $diffids
4982 } else {
4983 addtocflist $ids
4985 return 0
4988 proc getblobdiffs {ids} {
4989 global diffopts blobdifffd diffids env
4990 global diffinhdr treediffs
4992 set env(GIT_DIFF_OPTS) $diffopts
4993 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4994 puts "error getting diffs: $err"
4995 return
4997 set diffinhdr 0
4998 fconfigure $bdf -blocking 0
4999 set blobdifffd($ids) $bdf
5000 filerun $bdf [list getblobdiffline $bdf $diffids]
5003 proc setinlist {var i val} {
5004 global $var
5006 while {[llength [set $var]] < $i} {
5007 lappend $var {}
5009 if {[llength [set $var]] == $i} {
5010 lappend $var $val
5011 } else {
5012 lset $var $i $val
5016 proc makediffhdr {fname ids} {
5017 global ctext curdiffstart treediffs
5019 set i [lsearch -exact $treediffs($ids) $fname]
5020 if {$i >= 0} {
5021 setinlist difffilestart $i $curdiffstart
5023 set l [expr {(78 - [string length $fname]) / 2}]
5024 set pad [string range "----------------------------------------" 1 $l]
5025 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5028 proc getblobdiffline {bdf ids} {
5029 global diffids blobdifffd ctext curdiffstart
5030 global diffnexthead diffnextnote difffilestart
5031 global diffinhdr treediffs
5033 set nr 0
5034 $ctext conf -state normal
5035 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5036 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5037 close $bdf
5038 return 0
5040 if {![string compare -length 11 "diff --git " $line]} {
5041 # trim off "diff --git "
5042 set line [string range $line 11 end]
5043 set diffinhdr 1
5044 # start of a new file
5045 $ctext insert end "\n"
5046 set curdiffstart [$ctext index "end - 1c"]
5047 $ctext insert end "\n" filesep
5048 # If the name hasn't changed the length will be odd,
5049 # the middle char will be a space, and the two bits either
5050 # side will be a/name and b/name, or "a/name" and "b/name".
5051 # If the name has changed we'll get "rename from" and
5052 # "rename to" lines following this, and we'll use them
5053 # to get the filenames.
5054 # This complexity is necessary because spaces in the filename(s)
5055 # don't get escaped.
5056 set l [string length $line]
5057 set i [expr {$l / 2}]
5058 if {!(($l & 1) && [string index $line $i] eq " " &&
5059 [string range $line 2 [expr {$i - 1}]] eq \
5060 [string range $line [expr {$i + 3}] end])} {
5061 continue
5063 # unescape if quoted and chop off the a/ from the front
5064 if {[string index $line 0] eq "\""} {
5065 set fname [string range [lindex $line 0] 2 end]
5066 } else {
5067 set fname [string range $line 2 [expr {$i - 1}]]
5069 makediffhdr $fname $ids
5071 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5072 $line match f1l f1c f2l f2c rest]} {
5073 $ctext insert end "$line\n" hunksep
5074 set diffinhdr 0
5076 } elseif {$diffinhdr} {
5077 if {![string compare -length 12 "rename from " $line]} {
5078 set fname [string range $line 12 end]
5079 if {[string index $fname 0] eq "\""} {
5080 set fname [lindex $fname 0]
5082 set i [lsearch -exact $treediffs($ids) $fname]
5083 if {$i >= 0} {
5084 setinlist difffilestart $i $curdiffstart
5086 } elseif {![string compare -length 10 $line "rename to "]} {
5087 set fname [string range $line 10 end]
5088 if {[string index $fname 0] eq "\""} {
5089 set fname [lindex $fname 0]
5091 makediffhdr $fname $ids
5092 } elseif {[string compare -length 3 $line "---"] == 0} {
5093 # do nothing
5094 continue
5095 } elseif {[string compare -length 3 $line "+++"] == 0} {
5096 set diffinhdr 0
5097 continue
5099 $ctext insert end "$line\n" filesep
5101 } else {
5102 set x [string range $line 0 0]
5103 if {$x == "-" || $x == "+"} {
5104 set tag [expr {$x == "+"}]
5105 $ctext insert end "$line\n" d$tag
5106 } elseif {$x == " "} {
5107 $ctext insert end "$line\n"
5108 } else {
5109 # "\ No newline at end of file",
5110 # or something else we don't recognize
5111 $ctext insert end "$line\n" hunksep
5115 $ctext conf -state disabled
5116 if {[eof $bdf]} {
5117 close $bdf
5118 return 0
5120 return [expr {$nr >= 1000? 2: 1}]
5123 proc changediffdisp {} {
5124 global ctext diffelide
5126 $ctext tag conf d0 -elide [lindex $diffelide 0]
5127 $ctext tag conf d1 -elide [lindex $diffelide 1]
5130 proc prevfile {} {
5131 global difffilestart ctext
5132 set prev [lindex $difffilestart 0]
5133 set here [$ctext index @0,0]
5134 foreach loc $difffilestart {
5135 if {[$ctext compare $loc >= $here]} {
5136 $ctext yview $prev
5137 return
5139 set prev $loc
5141 $ctext yview $prev
5144 proc nextfile {} {
5145 global difffilestart ctext
5146 set here [$ctext index @0,0]
5147 foreach loc $difffilestart {
5148 if {[$ctext compare $loc > $here]} {
5149 $ctext yview $loc
5150 return
5155 proc clear_ctext {{first 1.0}} {
5156 global ctext smarktop smarkbot
5158 set l [lindex [split $first .] 0]
5159 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5160 set smarktop $l
5162 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5163 set smarkbot $l
5165 $ctext delete $first end
5168 proc incrsearch {name ix op} {
5169 global ctext searchstring searchdirn
5171 $ctext tag remove found 1.0 end
5172 if {[catch {$ctext index anchor}]} {
5173 # no anchor set, use start of selection, or of visible area
5174 set sel [$ctext tag ranges sel]
5175 if {$sel ne {}} {
5176 $ctext mark set anchor [lindex $sel 0]
5177 } elseif {$searchdirn eq "-forwards"} {
5178 $ctext mark set anchor @0,0
5179 } else {
5180 $ctext mark set anchor @0,[winfo height $ctext]
5183 if {$searchstring ne {}} {
5184 set here [$ctext search $searchdirn -- $searchstring anchor]
5185 if {$here ne {}} {
5186 $ctext see $here
5188 searchmarkvisible 1
5192 proc dosearch {} {
5193 global sstring ctext searchstring searchdirn
5195 focus $sstring
5196 $sstring icursor end
5197 set searchdirn -forwards
5198 if {$searchstring ne {}} {
5199 set sel [$ctext tag ranges sel]
5200 if {$sel ne {}} {
5201 set start "[lindex $sel 0] + 1c"
5202 } elseif {[catch {set start [$ctext index anchor]}]} {
5203 set start "@0,0"
5205 set match [$ctext search -count mlen -- $searchstring $start]
5206 $ctext tag remove sel 1.0 end
5207 if {$match eq {}} {
5208 bell
5209 return
5211 $ctext see $match
5212 set mend "$match + $mlen c"
5213 $ctext tag add sel $match $mend
5214 $ctext mark unset anchor
5218 proc dosearchback {} {
5219 global sstring ctext searchstring searchdirn
5221 focus $sstring
5222 $sstring icursor end
5223 set searchdirn -backwards
5224 if {$searchstring ne {}} {
5225 set sel [$ctext tag ranges sel]
5226 if {$sel ne {}} {
5227 set start [lindex $sel 0]
5228 } elseif {[catch {set start [$ctext index anchor]}]} {
5229 set start @0,[winfo height $ctext]
5231 set match [$ctext search -backwards -count ml -- $searchstring $start]
5232 $ctext tag remove sel 1.0 end
5233 if {$match eq {}} {
5234 bell
5235 return
5237 $ctext see $match
5238 set mend "$match + $ml c"
5239 $ctext tag add sel $match $mend
5240 $ctext mark unset anchor
5244 proc searchmark {first last} {
5245 global ctext searchstring
5247 set mend $first.0
5248 while {1} {
5249 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5250 if {$match eq {}} break
5251 set mend "$match + $mlen c"
5252 $ctext tag add found $match $mend
5256 proc searchmarkvisible {doall} {
5257 global ctext smarktop smarkbot
5259 set topline [lindex [split [$ctext index @0,0] .] 0]
5260 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5261 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5262 # no overlap with previous
5263 searchmark $topline $botline
5264 set smarktop $topline
5265 set smarkbot $botline
5266 } else {
5267 if {$topline < $smarktop} {
5268 searchmark $topline [expr {$smarktop-1}]
5269 set smarktop $topline
5271 if {$botline > $smarkbot} {
5272 searchmark [expr {$smarkbot+1}] $botline
5273 set smarkbot $botline
5278 proc scrolltext {f0 f1} {
5279 global searchstring
5281 .bleft.sb set $f0 $f1
5282 if {$searchstring ne {}} {
5283 searchmarkvisible 0
5287 proc setcoords {} {
5288 global linespc charspc canvx0 canvy0 mainfont
5289 global xspc1 xspc2 lthickness
5291 set linespc [font metrics $mainfont -linespace]
5292 set charspc [font measure $mainfont "m"]
5293 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5294 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5295 set lthickness [expr {int($linespc / 9) + 1}]
5296 set xspc1(0) $linespc
5297 set xspc2 $linespc
5300 proc redisplay {} {
5301 global canv
5302 global selectedline
5304 set ymax [lindex [$canv cget -scrollregion] 3]
5305 if {$ymax eq {} || $ymax == 0} return
5306 set span [$canv yview]
5307 clear_display
5308 setcanvscroll
5309 allcanvs yview moveto [lindex $span 0]
5310 drawvisible
5311 if {[info exists selectedline]} {
5312 selectline $selectedline 0
5313 allcanvs yview moveto [lindex $span 0]
5317 proc incrfont {inc} {
5318 global mainfont textfont ctext canv phase cflist
5319 global charspc tabstop
5320 global stopped entries
5321 unmarkmatches
5322 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5323 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5324 setcoords
5325 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5326 $cflist conf -font $textfont
5327 $ctext tag conf filesep -font [concat $textfont bold]
5328 foreach e $entries {
5329 $e conf -font $mainfont
5331 if {$phase eq "getcommits"} {
5332 $canv itemconf textitems -font $mainfont
5334 redisplay
5337 proc clearsha1 {} {
5338 global sha1entry sha1string
5339 if {[string length $sha1string] == 40} {
5340 $sha1entry delete 0 end
5344 proc sha1change {n1 n2 op} {
5345 global sha1string currentid sha1but
5346 if {$sha1string == {}
5347 || ([info exists currentid] && $sha1string == $currentid)} {
5348 set state disabled
5349 } else {
5350 set state normal
5352 if {[$sha1but cget -state] == $state} return
5353 if {$state == "normal"} {
5354 $sha1but conf -state normal -relief raised -text "Goto: "
5355 } else {
5356 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5360 proc gotocommit {} {
5361 global sha1string currentid commitrow tagids headids
5362 global displayorder numcommits curview
5364 if {$sha1string == {}
5365 || ([info exists currentid] && $sha1string == $currentid)} return
5366 if {[info exists tagids($sha1string)]} {
5367 set id $tagids($sha1string)
5368 } elseif {[info exists headids($sha1string)]} {
5369 set id $headids($sha1string)
5370 } else {
5371 set id [string tolower $sha1string]
5372 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5373 set matches {}
5374 foreach i $displayorder {
5375 if {[string match $id* $i]} {
5376 lappend matches $i
5379 if {$matches ne {}} {
5380 if {[llength $matches] > 1} {
5381 error_popup "Short SHA1 id $id is ambiguous"
5382 return
5384 set id [lindex $matches 0]
5388 if {[info exists commitrow($curview,$id)]} {
5389 selectline $commitrow($curview,$id) 1
5390 return
5392 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5393 set type "SHA1 id"
5394 } else {
5395 set type "Tag/Head"
5397 error_popup "$type $sha1string is not known"
5400 proc lineenter {x y id} {
5401 global hoverx hovery hoverid hovertimer
5402 global commitinfo canv
5404 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5405 set hoverx $x
5406 set hovery $y
5407 set hoverid $id
5408 if {[info exists hovertimer]} {
5409 after cancel $hovertimer
5411 set hovertimer [after 500 linehover]
5412 $canv delete hover
5415 proc linemotion {x y id} {
5416 global hoverx hovery hoverid hovertimer
5418 if {[info exists hoverid] && $id == $hoverid} {
5419 set hoverx $x
5420 set hovery $y
5421 if {[info exists hovertimer]} {
5422 after cancel $hovertimer
5424 set hovertimer [after 500 linehover]
5428 proc lineleave {id} {
5429 global hoverid hovertimer canv
5431 if {[info exists hoverid] && $id == $hoverid} {
5432 $canv delete hover
5433 if {[info exists hovertimer]} {
5434 after cancel $hovertimer
5435 unset hovertimer
5437 unset hoverid
5441 proc linehover {} {
5442 global hoverx hovery hoverid hovertimer
5443 global canv linespc lthickness
5444 global commitinfo mainfont
5446 set text [lindex $commitinfo($hoverid) 0]
5447 set ymax [lindex [$canv cget -scrollregion] 3]
5448 if {$ymax == {}} return
5449 set yfrac [lindex [$canv yview] 0]
5450 set x [expr {$hoverx + 2 * $linespc}]
5451 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5452 set x0 [expr {$x - 2 * $lthickness}]
5453 set y0 [expr {$y - 2 * $lthickness}]
5454 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5455 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5456 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5457 -fill \#ffff80 -outline black -width 1 -tags hover]
5458 $canv raise $t
5459 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5460 -font $mainfont]
5461 $canv raise $t
5464 proc clickisonarrow {id y} {
5465 global lthickness
5467 set ranges [rowranges $id]
5468 set thresh [expr {2 * $lthickness + 6}]
5469 set n [expr {[llength $ranges] - 1}]
5470 for {set i 1} {$i < $n} {incr i} {
5471 set row [lindex $ranges $i]
5472 if {abs([yc $row] - $y) < $thresh} {
5473 return $i
5476 return {}
5479 proc arrowjump {id n y} {
5480 global canv
5482 # 1 <-> 2, 3 <-> 4, etc...
5483 set n [expr {(($n - 1) ^ 1) + 1}]
5484 set row [lindex [rowranges $id] $n]
5485 set yt [yc $row]
5486 set ymax [lindex [$canv cget -scrollregion] 3]
5487 if {$ymax eq {} || $ymax <= 0} return
5488 set view [$canv yview]
5489 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5490 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5491 if {$yfrac < 0} {
5492 set yfrac 0
5494 allcanvs yview moveto $yfrac
5497 proc lineclick {x y id isnew} {
5498 global ctext commitinfo children canv thickerline curview
5500 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5501 unmarkmatches
5502 unselectline
5503 normalline
5504 $canv delete hover
5505 # draw this line thicker than normal
5506 set thickerline $id
5507 drawlines $id
5508 if {$isnew} {
5509 set ymax [lindex [$canv cget -scrollregion] 3]
5510 if {$ymax eq {}} return
5511 set yfrac [lindex [$canv yview] 0]
5512 set y [expr {$y + $yfrac * $ymax}]
5514 set dirn [clickisonarrow $id $y]
5515 if {$dirn ne {}} {
5516 arrowjump $id $dirn $y
5517 return
5520 if {$isnew} {
5521 addtohistory [list lineclick $x $y $id 0]
5523 # fill the details pane with info about this line
5524 $ctext conf -state normal
5525 clear_ctext
5526 $ctext tag conf link -foreground blue -underline 1
5527 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5528 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5529 $ctext insert end "Parent:\t"
5530 $ctext insert end $id [list link link0]
5531 $ctext tag bind link0 <1> [list selbyid $id]
5532 set info $commitinfo($id)
5533 $ctext insert end "\n\t[lindex $info 0]\n"
5534 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5535 set date [formatdate [lindex $info 2]]
5536 $ctext insert end "\tDate:\t$date\n"
5537 set kids $children($curview,$id)
5538 if {$kids ne {}} {
5539 $ctext insert end "\nChildren:"
5540 set i 0
5541 foreach child $kids {
5542 incr i
5543 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5544 set info $commitinfo($child)
5545 $ctext insert end "\n\t"
5546 $ctext insert end $child [list link link$i]
5547 $ctext tag bind link$i <1> [list selbyid $child]
5548 $ctext insert end "\n\t[lindex $info 0]"
5549 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5550 set date [formatdate [lindex $info 2]]
5551 $ctext insert end "\n\tDate:\t$date\n"
5554 $ctext conf -state disabled
5555 init_flist {}
5558 proc normalline {} {
5559 global thickerline
5560 if {[info exists thickerline]} {
5561 set id $thickerline
5562 unset thickerline
5563 drawlines $id
5567 proc selbyid {id} {
5568 global commitrow curview
5569 if {[info exists commitrow($curview,$id)]} {
5570 selectline $commitrow($curview,$id) 1
5574 proc mstime {} {
5575 global startmstime
5576 if {![info exists startmstime]} {
5577 set startmstime [clock clicks -milliseconds]
5579 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5582 proc rowmenu {x y id} {
5583 global rowctxmenu commitrow selectedline rowmenuid curview
5584 global nullid nullid2 fakerowmenu mainhead
5586 set rowmenuid $id
5587 if {![info exists selectedline]
5588 || $commitrow($curview,$id) eq $selectedline} {
5589 set state disabled
5590 } else {
5591 set state normal
5593 if {$id ne $nullid && $id ne $nullid2} {
5594 set menu $rowctxmenu
5595 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5596 } else {
5597 set menu $fakerowmenu
5599 $menu entryconfigure "Diff this*" -state $state
5600 $menu entryconfigure "Diff selected*" -state $state
5601 $menu entryconfigure "Make patch" -state $state
5602 tk_popup $menu $x $y
5605 proc diffvssel {dirn} {
5606 global rowmenuid selectedline displayorder
5608 if {![info exists selectedline]} return
5609 if {$dirn} {
5610 set oldid [lindex $displayorder $selectedline]
5611 set newid $rowmenuid
5612 } else {
5613 set oldid $rowmenuid
5614 set newid [lindex $displayorder $selectedline]
5616 addtohistory [list doseldiff $oldid $newid]
5617 doseldiff $oldid $newid
5620 proc doseldiff {oldid newid} {
5621 global ctext
5622 global commitinfo
5624 $ctext conf -state normal
5625 clear_ctext
5626 init_flist "Top"
5627 $ctext insert end "From "
5628 $ctext tag conf link -foreground blue -underline 1
5629 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5630 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5631 $ctext tag bind link0 <1> [list selbyid $oldid]
5632 $ctext insert end $oldid [list link link0]
5633 $ctext insert end "\n "
5634 $ctext insert end [lindex $commitinfo($oldid) 0]
5635 $ctext insert end "\n\nTo "
5636 $ctext tag bind link1 <1> [list selbyid $newid]
5637 $ctext insert end $newid [list link link1]
5638 $ctext insert end "\n "
5639 $ctext insert end [lindex $commitinfo($newid) 0]
5640 $ctext insert end "\n"
5641 $ctext conf -state disabled
5642 $ctext tag remove found 1.0 end
5643 startdiff [list $oldid $newid]
5646 proc mkpatch {} {
5647 global rowmenuid currentid commitinfo patchtop patchnum
5649 if {![info exists currentid]} return
5650 set oldid $currentid
5651 set oldhead [lindex $commitinfo($oldid) 0]
5652 set newid $rowmenuid
5653 set newhead [lindex $commitinfo($newid) 0]
5654 set top .patch
5655 set patchtop $top
5656 catch {destroy $top}
5657 toplevel $top
5658 label $top.title -text "Generate patch"
5659 grid $top.title - -pady 10
5660 label $top.from -text "From:"
5661 entry $top.fromsha1 -width 40 -relief flat
5662 $top.fromsha1 insert 0 $oldid
5663 $top.fromsha1 conf -state readonly
5664 grid $top.from $top.fromsha1 -sticky w
5665 entry $top.fromhead -width 60 -relief flat
5666 $top.fromhead insert 0 $oldhead
5667 $top.fromhead conf -state readonly
5668 grid x $top.fromhead -sticky w
5669 label $top.to -text "To:"
5670 entry $top.tosha1 -width 40 -relief flat
5671 $top.tosha1 insert 0 $newid
5672 $top.tosha1 conf -state readonly
5673 grid $top.to $top.tosha1 -sticky w
5674 entry $top.tohead -width 60 -relief flat
5675 $top.tohead insert 0 $newhead
5676 $top.tohead conf -state readonly
5677 grid x $top.tohead -sticky w
5678 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5679 grid $top.rev x -pady 10
5680 label $top.flab -text "Output file:"
5681 entry $top.fname -width 60
5682 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5683 incr patchnum
5684 grid $top.flab $top.fname -sticky w
5685 frame $top.buts
5686 button $top.buts.gen -text "Generate" -command mkpatchgo
5687 button $top.buts.can -text "Cancel" -command mkpatchcan
5688 grid $top.buts.gen $top.buts.can
5689 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5690 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5691 grid $top.buts - -pady 10 -sticky ew
5692 focus $top.fname
5695 proc mkpatchrev {} {
5696 global patchtop
5698 set oldid [$patchtop.fromsha1 get]
5699 set oldhead [$patchtop.fromhead get]
5700 set newid [$patchtop.tosha1 get]
5701 set newhead [$patchtop.tohead get]
5702 foreach e [list fromsha1 fromhead tosha1 tohead] \
5703 v [list $newid $newhead $oldid $oldhead] {
5704 $patchtop.$e conf -state normal
5705 $patchtop.$e delete 0 end
5706 $patchtop.$e insert 0 $v
5707 $patchtop.$e conf -state readonly
5711 proc mkpatchgo {} {
5712 global patchtop nullid nullid2
5714 set oldid [$patchtop.fromsha1 get]
5715 set newid [$patchtop.tosha1 get]
5716 set fname [$patchtop.fname get]
5717 set cmd [diffcmd [list $oldid $newid] -p]
5718 lappend cmd >$fname &
5719 if {[catch {eval exec $cmd} err]} {
5720 error_popup "Error creating patch: $err"
5722 catch {destroy $patchtop}
5723 unset patchtop
5726 proc mkpatchcan {} {
5727 global patchtop
5729 catch {destroy $patchtop}
5730 unset patchtop
5733 proc mktag {} {
5734 global rowmenuid mktagtop commitinfo
5736 set top .maketag
5737 set mktagtop $top
5738 catch {destroy $top}
5739 toplevel $top
5740 label $top.title -text "Create tag"
5741 grid $top.title - -pady 10
5742 label $top.id -text "ID:"
5743 entry $top.sha1 -width 40 -relief flat
5744 $top.sha1 insert 0 $rowmenuid
5745 $top.sha1 conf -state readonly
5746 grid $top.id $top.sha1 -sticky w
5747 entry $top.head -width 60 -relief flat
5748 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5749 $top.head conf -state readonly
5750 grid x $top.head -sticky w
5751 label $top.tlab -text "Tag name:"
5752 entry $top.tag -width 60
5753 grid $top.tlab $top.tag -sticky w
5754 frame $top.buts
5755 button $top.buts.gen -text "Create" -command mktaggo
5756 button $top.buts.can -text "Cancel" -command mktagcan
5757 grid $top.buts.gen $top.buts.can
5758 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5759 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5760 grid $top.buts - -pady 10 -sticky ew
5761 focus $top.tag
5764 proc domktag {} {
5765 global mktagtop env tagids idtags
5767 set id [$mktagtop.sha1 get]
5768 set tag [$mktagtop.tag get]
5769 if {$tag == {}} {
5770 error_popup "No tag name specified"
5771 return
5773 if {[info exists tagids($tag)]} {
5774 error_popup "Tag \"$tag\" already exists"
5775 return
5777 if {[catch {
5778 set dir [gitdir]
5779 set fname [file join $dir "refs/tags" $tag]
5780 set f [open $fname w]
5781 puts $f $id
5782 close $f
5783 } err]} {
5784 error_popup "Error creating tag: $err"
5785 return
5788 set tagids($tag) $id
5789 lappend idtags($id) $tag
5790 redrawtags $id
5791 addedtag $id
5794 proc redrawtags {id} {
5795 global canv linehtag commitrow idpos selectedline curview
5796 global mainfont canvxmax iddrawn
5798 if {![info exists commitrow($curview,$id)]} return
5799 if {![info exists iddrawn($id)]} return
5800 drawcommits $commitrow($curview,$id)
5801 $canv delete tag.$id
5802 set xt [eval drawtags $id $idpos($id)]
5803 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5804 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5805 set xr [expr {$xt + [font measure $mainfont $text]}]
5806 if {$xr > $canvxmax} {
5807 set canvxmax $xr
5808 setcanvscroll
5810 if {[info exists selectedline]
5811 && $selectedline == $commitrow($curview,$id)} {
5812 selectline $selectedline 0
5816 proc mktagcan {} {
5817 global mktagtop
5819 catch {destroy $mktagtop}
5820 unset mktagtop
5823 proc mktaggo {} {
5824 domktag
5825 mktagcan
5828 proc writecommit {} {
5829 global rowmenuid wrcomtop commitinfo wrcomcmd
5831 set top .writecommit
5832 set wrcomtop $top
5833 catch {destroy $top}
5834 toplevel $top
5835 label $top.title -text "Write commit to file"
5836 grid $top.title - -pady 10
5837 label $top.id -text "ID:"
5838 entry $top.sha1 -width 40 -relief flat
5839 $top.sha1 insert 0 $rowmenuid
5840 $top.sha1 conf -state readonly
5841 grid $top.id $top.sha1 -sticky w
5842 entry $top.head -width 60 -relief flat
5843 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5844 $top.head conf -state readonly
5845 grid x $top.head -sticky w
5846 label $top.clab -text "Command:"
5847 entry $top.cmd -width 60 -textvariable wrcomcmd
5848 grid $top.clab $top.cmd -sticky w -pady 10
5849 label $top.flab -text "Output file:"
5850 entry $top.fname -width 60
5851 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5852 grid $top.flab $top.fname -sticky w
5853 frame $top.buts
5854 button $top.buts.gen -text "Write" -command wrcomgo
5855 button $top.buts.can -text "Cancel" -command wrcomcan
5856 grid $top.buts.gen $top.buts.can
5857 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5858 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5859 grid $top.buts - -pady 10 -sticky ew
5860 focus $top.fname
5863 proc wrcomgo {} {
5864 global wrcomtop
5866 set id [$wrcomtop.sha1 get]
5867 set cmd "echo $id | [$wrcomtop.cmd get]"
5868 set fname [$wrcomtop.fname get]
5869 if {[catch {exec sh -c $cmd >$fname &} err]} {
5870 error_popup "Error writing commit: $err"
5872 catch {destroy $wrcomtop}
5873 unset wrcomtop
5876 proc wrcomcan {} {
5877 global wrcomtop
5879 catch {destroy $wrcomtop}
5880 unset wrcomtop
5883 proc mkbranch {} {
5884 global rowmenuid mkbrtop
5886 set top .makebranch
5887 catch {destroy $top}
5888 toplevel $top
5889 label $top.title -text "Create new branch"
5890 grid $top.title - -pady 10
5891 label $top.id -text "ID:"
5892 entry $top.sha1 -width 40 -relief flat
5893 $top.sha1 insert 0 $rowmenuid
5894 $top.sha1 conf -state readonly
5895 grid $top.id $top.sha1 -sticky w
5896 label $top.nlab -text "Name:"
5897 entry $top.name -width 40
5898 grid $top.nlab $top.name -sticky w
5899 frame $top.buts
5900 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5901 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5902 grid $top.buts.go $top.buts.can
5903 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5904 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5905 grid $top.buts - -pady 10 -sticky ew
5906 focus $top.name
5909 proc mkbrgo {top} {
5910 global headids idheads
5912 set name [$top.name get]
5913 set id [$top.sha1 get]
5914 if {$name eq {}} {
5915 error_popup "Please specify a name for the new branch"
5916 return
5918 catch {destroy $top}
5919 nowbusy newbranch
5920 update
5921 if {[catch {
5922 exec git branch $name $id
5923 } err]} {
5924 notbusy newbranch
5925 error_popup $err
5926 } else {
5927 set headids($name) $id
5928 lappend idheads($id) $name
5929 addedhead $id $name
5930 notbusy newbranch
5931 redrawtags $id
5932 dispneartags 0
5936 proc cherrypick {} {
5937 global rowmenuid curview commitrow
5938 global mainhead
5940 set oldhead [exec git rev-parse HEAD]
5941 set dheads [descheads $rowmenuid]
5942 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5943 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5944 included in branch $mainhead -- really re-apply it?"]
5945 if {!$ok} return
5947 nowbusy cherrypick
5948 update
5949 # Unfortunately git-cherry-pick writes stuff to stderr even when
5950 # no error occurs, and exec takes that as an indication of error...
5951 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5952 notbusy cherrypick
5953 error_popup $err
5954 return
5956 set newhead [exec git rev-parse HEAD]
5957 if {$newhead eq $oldhead} {
5958 notbusy cherrypick
5959 error_popup "No changes committed"
5960 return
5962 addnewchild $newhead $oldhead
5963 if {[info exists commitrow($curview,$oldhead)]} {
5964 insertrow $commitrow($curview,$oldhead) $newhead
5965 if {$mainhead ne {}} {
5966 movehead $newhead $mainhead
5967 movedhead $newhead $mainhead
5969 redrawtags $oldhead
5970 redrawtags $newhead
5972 notbusy cherrypick
5975 proc resethead {} {
5976 global mainheadid mainhead rowmenuid confirm_ok resettype
5977 global showlocalchanges
5979 set confirm_ok 0
5980 set w ".confirmreset"
5981 toplevel $w
5982 wm transient $w .
5983 wm title $w "Confirm reset"
5984 message $w.m -text \
5985 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5986 -justify center -aspect 1000
5987 pack $w.m -side top -fill x -padx 20 -pady 20
5988 frame $w.f -relief sunken -border 2
5989 message $w.f.rt -text "Reset type:" -aspect 1000
5990 grid $w.f.rt -sticky w
5991 set resettype mixed
5992 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5993 -text "Soft: Leave working tree and index untouched"
5994 grid $w.f.soft -sticky w
5995 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5996 -text "Mixed: Leave working tree untouched, reset index"
5997 grid $w.f.mixed -sticky w
5998 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5999 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6000 grid $w.f.hard -sticky w
6001 pack $w.f -side top -fill x
6002 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6003 pack $w.ok -side left -fill x -padx 20 -pady 20
6004 button $w.cancel -text Cancel -command "destroy $w"
6005 pack $w.cancel -side right -fill x -padx 20 -pady 20
6006 bind $w <Visibility> "grab $w; focus $w"
6007 tkwait window $w
6008 if {!$confirm_ok} return
6009 if {[catch {set fd [open \
6010 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6011 error_popup $err
6012 } else {
6013 dohidelocalchanges
6014 set w ".resetprogress"
6015 filerun $fd [list readresetstat $fd $w]
6016 toplevel $w
6017 wm transient $w
6018 wm title $w "Reset progress"
6019 message $w.m -text "Reset in progress, please wait..." \
6020 -justify center -aspect 1000
6021 pack $w.m -side top -fill x -padx 20 -pady 5
6022 canvas $w.c -width 150 -height 20 -bg white
6023 $w.c create rect 0 0 0 20 -fill green -tags rect
6024 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6025 nowbusy reset
6029 proc readresetstat {fd w} {
6030 global mainhead mainheadid showlocalchanges
6032 if {[gets $fd line] >= 0} {
6033 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6034 set x [expr {($m * 150) / $n}]
6035 $w.c coords rect 0 0 $x 20
6037 return 1
6039 destroy $w
6040 notbusy reset
6041 if {[catch {close $fd} err]} {
6042 error_popup $err
6044 set oldhead $mainheadid
6045 set newhead [exec git rev-parse HEAD]
6046 if {$newhead ne $oldhead} {
6047 movehead $newhead $mainhead
6048 movedhead $newhead $mainhead
6049 set mainheadid $newhead
6050 redrawtags $oldhead
6051 redrawtags $newhead
6053 if {$showlocalchanges} {
6054 doshowlocalchanges
6056 return 0
6059 # context menu for a head
6060 proc headmenu {x y id head} {
6061 global headmenuid headmenuhead headctxmenu mainhead
6063 set headmenuid $id
6064 set headmenuhead $head
6065 set state normal
6066 if {$head eq $mainhead} {
6067 set state disabled
6069 $headctxmenu entryconfigure 0 -state $state
6070 $headctxmenu entryconfigure 1 -state $state
6071 tk_popup $headctxmenu $x $y
6074 proc cobranch {} {
6075 global headmenuid headmenuhead mainhead headids
6076 global showlocalchanges mainheadid
6078 # check the tree is clean first??
6079 set oldmainhead $mainhead
6080 nowbusy checkout
6081 update
6082 dohidelocalchanges
6083 if {[catch {
6084 exec git checkout -q $headmenuhead
6085 } err]} {
6086 notbusy checkout
6087 error_popup $err
6088 } else {
6089 notbusy checkout
6090 set mainhead $headmenuhead
6091 set mainheadid $headmenuid
6092 if {[info exists headids($oldmainhead)]} {
6093 redrawtags $headids($oldmainhead)
6095 redrawtags $headmenuid
6097 if {$showlocalchanges} {
6098 dodiffindex
6102 proc rmbranch {} {
6103 global headmenuid headmenuhead mainhead
6104 global headids idheads
6106 set head $headmenuhead
6107 set id $headmenuid
6108 # this check shouldn't be needed any more...
6109 if {$head eq $mainhead} {
6110 error_popup "Cannot delete the currently checked-out branch"
6111 return
6113 set dheads [descheads $id]
6114 if {$dheads eq $headids($head)} {
6115 # the stuff on this branch isn't on any other branch
6116 if {![confirm_popup "The commits on branch $head aren't on any other\
6117 branch.\nReally delete branch $head?"]} return
6119 nowbusy rmbranch
6120 update
6121 if {[catch {exec git branch -D $head} err]} {
6122 notbusy rmbranch
6123 error_popup $err
6124 return
6126 removehead $id $head
6127 removedhead $id $head
6128 redrawtags $id
6129 notbusy rmbranch
6130 dispneartags 0
6133 # Stuff for finding nearby tags
6134 proc getallcommits {} {
6135 global allcommits allids nbmp nextarc seeds
6137 set allids {}
6138 set nbmp 0
6139 set nextarc 0
6140 set allcommits 0
6141 set seeds {}
6142 regetallcommits
6145 # Called when the graph might have changed
6146 proc regetallcommits {} {
6147 global allcommits seeds
6149 set cmd [concat | git rev-list --all --parents]
6150 foreach id $seeds {
6151 lappend cmd "^$id"
6153 set fd [open $cmd r]
6154 fconfigure $fd -blocking 0
6155 incr allcommits
6156 nowbusy allcommits
6157 filerun $fd [list getallclines $fd]
6160 # Since most commits have 1 parent and 1 child, we group strings of
6161 # such commits into "arcs" joining branch/merge points (BMPs), which
6162 # are commits that either don't have 1 parent or don't have 1 child.
6164 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6165 # arcout(id) - outgoing arcs for BMP
6166 # arcids(a) - list of IDs on arc including end but not start
6167 # arcstart(a) - BMP ID at start of arc
6168 # arcend(a) - BMP ID at end of arc
6169 # growing(a) - arc a is still growing
6170 # arctags(a) - IDs out of arcids (excluding end) that have tags
6171 # archeads(a) - IDs out of arcids (excluding end) that have heads
6172 # The start of an arc is at the descendent end, so "incoming" means
6173 # coming from descendents, and "outgoing" means going towards ancestors.
6175 proc getallclines {fd} {
6176 global allids allparents allchildren idtags idheads nextarc nbmp
6177 global arcnos arcids arctags arcout arcend arcstart archeads growing
6178 global seeds allcommits
6180 set nid 0
6181 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6182 set id [lindex $line 0]
6183 if {[info exists allparents($id)]} {
6184 # seen it already
6185 continue
6187 lappend allids $id
6188 set olds [lrange $line 1 end]
6189 set allparents($id) $olds
6190 if {![info exists allchildren($id)]} {
6191 set allchildren($id) {}
6192 set arcnos($id) {}
6193 lappend seeds $id
6194 } else {
6195 set a $arcnos($id)
6196 if {[llength $olds] == 1 && [llength $a] == 1} {
6197 lappend arcids($a) $id
6198 if {[info exists idtags($id)]} {
6199 lappend arctags($a) $id
6201 if {[info exists idheads($id)]} {
6202 lappend archeads($a) $id
6204 if {[info exists allparents($olds)]} {
6205 # seen parent already
6206 if {![info exists arcout($olds)]} {
6207 splitarc $olds
6209 lappend arcids($a) $olds
6210 set arcend($a) $olds
6211 unset growing($a)
6213 lappend allchildren($olds) $id
6214 lappend arcnos($olds) $a
6215 continue
6218 incr nbmp
6219 foreach a $arcnos($id) {
6220 lappend arcids($a) $id
6221 set arcend($a) $id
6222 unset growing($a)
6225 set ao {}
6226 foreach p $olds {
6227 lappend allchildren($p) $id
6228 set a [incr nextarc]
6229 set arcstart($a) $id
6230 set archeads($a) {}
6231 set arctags($a) {}
6232 set archeads($a) {}
6233 set arcids($a) {}
6234 lappend ao $a
6235 set growing($a) 1
6236 if {[info exists allparents($p)]} {
6237 # seen it already, may need to make a new branch
6238 if {![info exists arcout($p)]} {
6239 splitarc $p
6241 lappend arcids($a) $p
6242 set arcend($a) $p
6243 unset growing($a)
6245 lappend arcnos($p) $a
6247 set arcout($id) $ao
6249 if {$nid > 0} {
6250 global cached_dheads cached_dtags cached_atags
6251 catch {unset cached_dheads}
6252 catch {unset cached_dtags}
6253 catch {unset cached_atags}
6255 if {![eof $fd]} {
6256 return [expr {$nid >= 1000? 2: 1}]
6258 close $fd
6259 if {[incr allcommits -1] == 0} {
6260 notbusy allcommits
6262 dispneartags 0
6263 return 0
6266 proc recalcarc {a} {
6267 global arctags archeads arcids idtags idheads
6269 set at {}
6270 set ah {}
6271 foreach id [lrange $arcids($a) 0 end-1] {
6272 if {[info exists idtags($id)]} {
6273 lappend at $id
6275 if {[info exists idheads($id)]} {
6276 lappend ah $id
6279 set arctags($a) $at
6280 set archeads($a) $ah
6283 proc splitarc {p} {
6284 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6285 global arcstart arcend arcout allparents growing
6287 set a $arcnos($p)
6288 if {[llength $a] != 1} {
6289 puts "oops splitarc called but [llength $a] arcs already"
6290 return
6292 set a [lindex $a 0]
6293 set i [lsearch -exact $arcids($a) $p]
6294 if {$i < 0} {
6295 puts "oops splitarc $p not in arc $a"
6296 return
6298 set na [incr nextarc]
6299 if {[info exists arcend($a)]} {
6300 set arcend($na) $arcend($a)
6301 } else {
6302 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6303 set j [lsearch -exact $arcnos($l) $a]
6304 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6306 set tail [lrange $arcids($a) [expr {$i+1}] end]
6307 set arcids($a) [lrange $arcids($a) 0 $i]
6308 set arcend($a) $p
6309 set arcstart($na) $p
6310 set arcout($p) $na
6311 set arcids($na) $tail
6312 if {[info exists growing($a)]} {
6313 set growing($na) 1
6314 unset growing($a)
6316 incr nbmp
6318 foreach id $tail {
6319 if {[llength $arcnos($id)] == 1} {
6320 set arcnos($id) $na
6321 } else {
6322 set j [lsearch -exact $arcnos($id) $a]
6323 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6327 # reconstruct tags and heads lists
6328 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6329 recalcarc $a
6330 recalcarc $na
6331 } else {
6332 set arctags($na) {}
6333 set archeads($na) {}
6337 # Update things for a new commit added that is a child of one
6338 # existing commit. Used when cherry-picking.
6339 proc addnewchild {id p} {
6340 global allids allparents allchildren idtags nextarc nbmp
6341 global arcnos arcids arctags arcout arcend arcstart archeads growing
6342 global seeds
6344 lappend allids $id
6345 set allparents($id) [list $p]
6346 set allchildren($id) {}
6347 set arcnos($id) {}
6348 lappend seeds $id
6349 incr nbmp
6350 lappend allchildren($p) $id
6351 set a [incr nextarc]
6352 set arcstart($a) $id
6353 set archeads($a) {}
6354 set arctags($a) {}
6355 set arcids($a) [list $p]
6356 set arcend($a) $p
6357 if {![info exists arcout($p)]} {
6358 splitarc $p
6360 lappend arcnos($p) $a
6361 set arcout($id) [list $a]
6364 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6365 # or 0 if neither is true.
6366 proc anc_or_desc {a b} {
6367 global arcout arcstart arcend arcnos cached_isanc
6369 if {$arcnos($a) eq $arcnos($b)} {
6370 # Both are on the same arc(s); either both are the same BMP,
6371 # or if one is not a BMP, the other is also not a BMP or is
6372 # the BMP at end of the arc (and it only has 1 incoming arc).
6373 # Or both can be BMPs with no incoming arcs.
6374 if {$a eq $b || $arcnos($a) eq {}} {
6375 return 0
6377 # assert {[llength $arcnos($a)] == 1}
6378 set arc [lindex $arcnos($a) 0]
6379 set i [lsearch -exact $arcids($arc) $a]
6380 set j [lsearch -exact $arcids($arc) $b]
6381 if {$i < 0 || $i > $j} {
6382 return 1
6383 } else {
6384 return -1
6388 if {![info exists arcout($a)]} {
6389 set arc [lindex $arcnos($a) 0]
6390 if {[info exists arcend($arc)]} {
6391 set aend $arcend($arc)
6392 } else {
6393 set aend {}
6395 set a $arcstart($arc)
6396 } else {
6397 set aend $a
6399 if {![info exists arcout($b)]} {
6400 set arc [lindex $arcnos($b) 0]
6401 if {[info exists arcend($arc)]} {
6402 set bend $arcend($arc)
6403 } else {
6404 set bend {}
6406 set b $arcstart($arc)
6407 } else {
6408 set bend $b
6410 if {$a eq $bend} {
6411 return 1
6413 if {$b eq $aend} {
6414 return -1
6416 if {[info exists cached_isanc($a,$bend)]} {
6417 if {$cached_isanc($a,$bend)} {
6418 return 1
6421 if {[info exists cached_isanc($b,$aend)]} {
6422 if {$cached_isanc($b,$aend)} {
6423 return -1
6425 if {[info exists cached_isanc($a,$bend)]} {
6426 return 0
6430 set todo [list $a $b]
6431 set anc($a) a
6432 set anc($b) b
6433 for {set i 0} {$i < [llength $todo]} {incr i} {
6434 set x [lindex $todo $i]
6435 if {$anc($x) eq {}} {
6436 continue
6438 foreach arc $arcnos($x) {
6439 set xd $arcstart($arc)
6440 if {$xd eq $bend} {
6441 set cached_isanc($a,$bend) 1
6442 set cached_isanc($b,$aend) 0
6443 return 1
6444 } elseif {$xd eq $aend} {
6445 set cached_isanc($b,$aend) 1
6446 set cached_isanc($a,$bend) 0
6447 return -1
6449 if {![info exists anc($xd)]} {
6450 set anc($xd) $anc($x)
6451 lappend todo $xd
6452 } elseif {$anc($xd) ne $anc($x)} {
6453 set anc($xd) {}
6457 set cached_isanc($a,$bend) 0
6458 set cached_isanc($b,$aend) 0
6459 return 0
6462 # This identifies whether $desc has an ancestor that is
6463 # a growing tip of the graph and which is not an ancestor of $anc
6464 # and returns 0 if so and 1 if not.
6465 # If we subsequently discover a tag on such a growing tip, and that
6466 # turns out to be a descendent of $anc (which it could, since we
6467 # don't necessarily see children before parents), then $desc
6468 # isn't a good choice to display as a descendent tag of
6469 # $anc (since it is the descendent of another tag which is
6470 # a descendent of $anc). Similarly, $anc isn't a good choice to
6471 # display as a ancestor tag of $desc.
6473 proc is_certain {desc anc} {
6474 global arcnos arcout arcstart arcend growing problems
6476 set certain {}
6477 if {[llength $arcnos($anc)] == 1} {
6478 # tags on the same arc are certain
6479 if {$arcnos($desc) eq $arcnos($anc)} {
6480 return 1
6482 if {![info exists arcout($anc)]} {
6483 # if $anc is partway along an arc, use the start of the arc instead
6484 set a [lindex $arcnos($anc) 0]
6485 set anc $arcstart($a)
6488 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6489 set x $desc
6490 } else {
6491 set a [lindex $arcnos($desc) 0]
6492 set x $arcend($a)
6494 if {$x == $anc} {
6495 return 1
6497 set anclist [list $x]
6498 set dl($x) 1
6499 set nnh 1
6500 set ngrowanc 0
6501 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6502 set x [lindex $anclist $i]
6503 if {$dl($x)} {
6504 incr nnh -1
6506 set done($x) 1
6507 foreach a $arcout($x) {
6508 if {[info exists growing($a)]} {
6509 if {![info exists growanc($x)] && $dl($x)} {
6510 set growanc($x) 1
6511 incr ngrowanc
6513 } else {
6514 set y $arcend($a)
6515 if {[info exists dl($y)]} {
6516 if {$dl($y)} {
6517 if {!$dl($x)} {
6518 set dl($y) 0
6519 if {![info exists done($y)]} {
6520 incr nnh -1
6522 if {[info exists growanc($x)]} {
6523 incr ngrowanc -1
6525 set xl [list $y]
6526 for {set k 0} {$k < [llength $xl]} {incr k} {
6527 set z [lindex $xl $k]
6528 foreach c $arcout($z) {
6529 if {[info exists arcend($c)]} {
6530 set v $arcend($c)
6531 if {[info exists dl($v)] && $dl($v)} {
6532 set dl($v) 0
6533 if {![info exists done($v)]} {
6534 incr nnh -1
6536 if {[info exists growanc($v)]} {
6537 incr ngrowanc -1
6539 lappend xl $v
6546 } elseif {$y eq $anc || !$dl($x)} {
6547 set dl($y) 0
6548 lappend anclist $y
6549 } else {
6550 set dl($y) 1
6551 lappend anclist $y
6552 incr nnh
6557 foreach x [array names growanc] {
6558 if {$dl($x)} {
6559 return 0
6561 return 0
6563 return 1
6566 proc validate_arctags {a} {
6567 global arctags idtags
6569 set i -1
6570 set na $arctags($a)
6571 foreach id $arctags($a) {
6572 incr i
6573 if {![info exists idtags($id)]} {
6574 set na [lreplace $na $i $i]
6575 incr i -1
6578 set arctags($a) $na
6581 proc validate_archeads {a} {
6582 global archeads idheads
6584 set i -1
6585 set na $archeads($a)
6586 foreach id $archeads($a) {
6587 incr i
6588 if {![info exists idheads($id)]} {
6589 set na [lreplace $na $i $i]
6590 incr i -1
6593 set archeads($a) $na
6596 # Return the list of IDs that have tags that are descendents of id,
6597 # ignoring IDs that are descendents of IDs already reported.
6598 proc desctags {id} {
6599 global arcnos arcstart arcids arctags idtags allparents
6600 global growing cached_dtags
6602 if {![info exists allparents($id)]} {
6603 return {}
6605 set t1 [clock clicks -milliseconds]
6606 set argid $id
6607 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6608 # part-way along an arc; check that arc first
6609 set a [lindex $arcnos($id) 0]
6610 if {$arctags($a) ne {}} {
6611 validate_arctags $a
6612 set i [lsearch -exact $arcids($a) $id]
6613 set tid {}
6614 foreach t $arctags($a) {
6615 set j [lsearch -exact $arcids($a) $t]
6616 if {$j >= $i} break
6617 set tid $t
6619 if {$tid ne {}} {
6620 return $tid
6623 set id $arcstart($a)
6624 if {[info exists idtags($id)]} {
6625 return $id
6628 if {[info exists cached_dtags($id)]} {
6629 return $cached_dtags($id)
6632 set origid $id
6633 set todo [list $id]
6634 set queued($id) 1
6635 set nc 1
6636 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6637 set id [lindex $todo $i]
6638 set done($id) 1
6639 set ta [info exists hastaggedancestor($id)]
6640 if {!$ta} {
6641 incr nc -1
6643 # ignore tags on starting node
6644 if {!$ta && $i > 0} {
6645 if {[info exists idtags($id)]} {
6646 set tagloc($id) $id
6647 set ta 1
6648 } elseif {[info exists cached_dtags($id)]} {
6649 set tagloc($id) $cached_dtags($id)
6650 set ta 1
6653 foreach a $arcnos($id) {
6654 set d $arcstart($a)
6655 if {!$ta && $arctags($a) ne {}} {
6656 validate_arctags $a
6657 if {$arctags($a) ne {}} {
6658 lappend tagloc($id) [lindex $arctags($a) end]
6661 if {$ta || $arctags($a) ne {}} {
6662 set tomark [list $d]
6663 for {set j 0} {$j < [llength $tomark]} {incr j} {
6664 set dd [lindex $tomark $j]
6665 if {![info exists hastaggedancestor($dd)]} {
6666 if {[info exists done($dd)]} {
6667 foreach b $arcnos($dd) {
6668 lappend tomark $arcstart($b)
6670 if {[info exists tagloc($dd)]} {
6671 unset tagloc($dd)
6673 } elseif {[info exists queued($dd)]} {
6674 incr nc -1
6676 set hastaggedancestor($dd) 1
6680 if {![info exists queued($d)]} {
6681 lappend todo $d
6682 set queued($d) 1
6683 if {![info exists hastaggedancestor($d)]} {
6684 incr nc
6689 set tags {}
6690 foreach id [array names tagloc] {
6691 if {![info exists hastaggedancestor($id)]} {
6692 foreach t $tagloc($id) {
6693 if {[lsearch -exact $tags $t] < 0} {
6694 lappend tags $t
6699 set t2 [clock clicks -milliseconds]
6700 set loopix $i
6702 # remove tags that are descendents of other tags
6703 for {set i 0} {$i < [llength $tags]} {incr i} {
6704 set a [lindex $tags $i]
6705 for {set j 0} {$j < $i} {incr j} {
6706 set b [lindex $tags $j]
6707 set r [anc_or_desc $a $b]
6708 if {$r == 1} {
6709 set tags [lreplace $tags $j $j]
6710 incr j -1
6711 incr i -1
6712 } elseif {$r == -1} {
6713 set tags [lreplace $tags $i $i]
6714 incr i -1
6715 break
6720 if {[array names growing] ne {}} {
6721 # graph isn't finished, need to check if any tag could get
6722 # eclipsed by another tag coming later. Simply ignore any
6723 # tags that could later get eclipsed.
6724 set ctags {}
6725 foreach t $tags {
6726 if {[is_certain $t $origid]} {
6727 lappend ctags $t
6730 if {$tags eq $ctags} {
6731 set cached_dtags($origid) $tags
6732 } else {
6733 set tags $ctags
6735 } else {
6736 set cached_dtags($origid) $tags
6738 set t3 [clock clicks -milliseconds]
6739 if {0 && $t3 - $t1 >= 100} {
6740 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6741 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6743 return $tags
6746 proc anctags {id} {
6747 global arcnos arcids arcout arcend arctags idtags allparents
6748 global growing cached_atags
6750 if {![info exists allparents($id)]} {
6751 return {}
6753 set t1 [clock clicks -milliseconds]
6754 set argid $id
6755 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6756 # part-way along an arc; check that arc first
6757 set a [lindex $arcnos($id) 0]
6758 if {$arctags($a) ne {}} {
6759 validate_arctags $a
6760 set i [lsearch -exact $arcids($a) $id]
6761 foreach t $arctags($a) {
6762 set j [lsearch -exact $arcids($a) $t]
6763 if {$j > $i} {
6764 return $t
6768 if {![info exists arcend($a)]} {
6769 return {}
6771 set id $arcend($a)
6772 if {[info exists idtags($id)]} {
6773 return $id
6776 if {[info exists cached_atags($id)]} {
6777 return $cached_atags($id)
6780 set origid $id
6781 set todo [list $id]
6782 set queued($id) 1
6783 set taglist {}
6784 set nc 1
6785 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6786 set id [lindex $todo $i]
6787 set done($id) 1
6788 set td [info exists hastaggeddescendent($id)]
6789 if {!$td} {
6790 incr nc -1
6792 # ignore tags on starting node
6793 if {!$td && $i > 0} {
6794 if {[info exists idtags($id)]} {
6795 set tagloc($id) $id
6796 set td 1
6797 } elseif {[info exists cached_atags($id)]} {
6798 set tagloc($id) $cached_atags($id)
6799 set td 1
6802 foreach a $arcout($id) {
6803 if {!$td && $arctags($a) ne {}} {
6804 validate_arctags $a
6805 if {$arctags($a) ne {}} {
6806 lappend tagloc($id) [lindex $arctags($a) 0]
6809 if {![info exists arcend($a)]} continue
6810 set d $arcend($a)
6811 if {$td || $arctags($a) ne {}} {
6812 set tomark [list $d]
6813 for {set j 0} {$j < [llength $tomark]} {incr j} {
6814 set dd [lindex $tomark $j]
6815 if {![info exists hastaggeddescendent($dd)]} {
6816 if {[info exists done($dd)]} {
6817 foreach b $arcout($dd) {
6818 if {[info exists arcend($b)]} {
6819 lappend tomark $arcend($b)
6822 if {[info exists tagloc($dd)]} {
6823 unset tagloc($dd)
6825 } elseif {[info exists queued($dd)]} {
6826 incr nc -1
6828 set hastaggeddescendent($dd) 1
6832 if {![info exists queued($d)]} {
6833 lappend todo $d
6834 set queued($d) 1
6835 if {![info exists hastaggeddescendent($d)]} {
6836 incr nc
6841 set t2 [clock clicks -milliseconds]
6842 set loopix $i
6843 set tags {}
6844 foreach id [array names tagloc] {
6845 if {![info exists hastaggeddescendent($id)]} {
6846 foreach t $tagloc($id) {
6847 if {[lsearch -exact $tags $t] < 0} {
6848 lappend tags $t
6854 # remove tags that are ancestors of other tags
6855 for {set i 0} {$i < [llength $tags]} {incr i} {
6856 set a [lindex $tags $i]
6857 for {set j 0} {$j < $i} {incr j} {
6858 set b [lindex $tags $j]
6859 set r [anc_or_desc $a $b]
6860 if {$r == -1} {
6861 set tags [lreplace $tags $j $j]
6862 incr j -1
6863 incr i -1
6864 } elseif {$r == 1} {
6865 set tags [lreplace $tags $i $i]
6866 incr i -1
6867 break
6872 if {[array names growing] ne {}} {
6873 # graph isn't finished, need to check if any tag could get
6874 # eclipsed by another tag coming later. Simply ignore any
6875 # tags that could later get eclipsed.
6876 set ctags {}
6877 foreach t $tags {
6878 if {[is_certain $origid $t]} {
6879 lappend ctags $t
6882 if {$tags eq $ctags} {
6883 set cached_atags($origid) $tags
6884 } else {
6885 set tags $ctags
6887 } else {
6888 set cached_atags($origid) $tags
6890 set t3 [clock clicks -milliseconds]
6891 if {0 && $t3 - $t1 >= 100} {
6892 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6893 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6895 return $tags
6898 # Return the list of IDs that have heads that are descendents of id,
6899 # including id itself if it has a head.
6900 proc descheads {id} {
6901 global arcnos arcstart arcids archeads idheads cached_dheads
6902 global allparents
6904 if {![info exists allparents($id)]} {
6905 return {}
6907 set aret {}
6908 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6909 # part-way along an arc; check it first
6910 set a [lindex $arcnos($id) 0]
6911 if {$archeads($a) ne {}} {
6912 validate_archeads $a
6913 set i [lsearch -exact $arcids($a) $id]
6914 foreach t $archeads($a) {
6915 set j [lsearch -exact $arcids($a) $t]
6916 if {$j > $i} break
6917 lappend aret $t
6920 set id $arcstart($a)
6922 set origid $id
6923 set todo [list $id]
6924 set seen($id) 1
6925 set ret {}
6926 for {set i 0} {$i < [llength $todo]} {incr i} {
6927 set id [lindex $todo $i]
6928 if {[info exists cached_dheads($id)]} {
6929 set ret [concat $ret $cached_dheads($id)]
6930 } else {
6931 if {[info exists idheads($id)]} {
6932 lappend ret $id
6934 foreach a $arcnos($id) {
6935 if {$archeads($a) ne {}} {
6936 validate_archeads $a
6937 if {$archeads($a) ne {}} {
6938 set ret [concat $ret $archeads($a)]
6941 set d $arcstart($a)
6942 if {![info exists seen($d)]} {
6943 lappend todo $d
6944 set seen($d) 1
6949 set ret [lsort -unique $ret]
6950 set cached_dheads($origid) $ret
6951 return [concat $ret $aret]
6954 proc addedtag {id} {
6955 global arcnos arcout cached_dtags cached_atags
6957 if {![info exists arcnos($id)]} return
6958 if {![info exists arcout($id)]} {
6959 recalcarc [lindex $arcnos($id) 0]
6961 catch {unset cached_dtags}
6962 catch {unset cached_atags}
6965 proc addedhead {hid head} {
6966 global arcnos arcout cached_dheads
6968 if {![info exists arcnos($hid)]} return
6969 if {![info exists arcout($hid)]} {
6970 recalcarc [lindex $arcnos($hid) 0]
6972 catch {unset cached_dheads}
6975 proc removedhead {hid head} {
6976 global cached_dheads
6978 catch {unset cached_dheads}
6981 proc movedhead {hid head} {
6982 global arcnos arcout cached_dheads
6984 if {![info exists arcnos($hid)]} return
6985 if {![info exists arcout($hid)]} {
6986 recalcarc [lindex $arcnos($hid) 0]
6988 catch {unset cached_dheads}
6991 proc changedrefs {} {
6992 global cached_dheads cached_dtags cached_atags
6993 global arctags archeads arcnos arcout idheads idtags
6995 foreach id [concat [array names idheads] [array names idtags]] {
6996 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6997 set a [lindex $arcnos($id) 0]
6998 if {![info exists donearc($a)]} {
6999 recalcarc $a
7000 set donearc($a) 1
7004 catch {unset cached_dtags}
7005 catch {unset cached_atags}
7006 catch {unset cached_dheads}
7009 proc rereadrefs {} {
7010 global idtags idheads idotherrefs mainhead
7012 set refids [concat [array names idtags] \
7013 [array names idheads] [array names idotherrefs]]
7014 foreach id $refids {
7015 if {![info exists ref($id)]} {
7016 set ref($id) [listrefs $id]
7019 set oldmainhead $mainhead
7020 readrefs
7021 changedrefs
7022 set refids [lsort -unique [concat $refids [array names idtags] \
7023 [array names idheads] [array names idotherrefs]]]
7024 foreach id $refids {
7025 set v [listrefs $id]
7026 if {![info exists ref($id)] || $ref($id) != $v ||
7027 ($id eq $oldmainhead && $id ne $mainhead) ||
7028 ($id eq $mainhead && $id ne $oldmainhead)} {
7029 redrawtags $id
7034 proc listrefs {id} {
7035 global idtags idheads idotherrefs
7037 set x {}
7038 if {[info exists idtags($id)]} {
7039 set x $idtags($id)
7041 set y {}
7042 if {[info exists idheads($id)]} {
7043 set y $idheads($id)
7045 set z {}
7046 if {[info exists idotherrefs($id)]} {
7047 set z $idotherrefs($id)
7049 return [list $x $y $z]
7052 proc showtag {tag isnew} {
7053 global ctext tagcontents tagids linknum tagobjid
7055 if {$isnew} {
7056 addtohistory [list showtag $tag 0]
7058 $ctext conf -state normal
7059 clear_ctext
7060 set linknum 0
7061 if {![info exists tagcontents($tag)]} {
7062 catch {
7063 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7066 if {[info exists tagcontents($tag)]} {
7067 set text $tagcontents($tag)
7068 } else {
7069 set text "Tag: $tag\nId: $tagids($tag)"
7071 appendwithlinks $text {}
7072 $ctext conf -state disabled
7073 init_flist {}
7076 proc doquit {} {
7077 global stopped
7078 set stopped 100
7079 savestuff .
7080 destroy .
7083 proc doprefs {} {
7084 global maxwidth maxgraphpct diffopts
7085 global oldprefs prefstop showneartags showlocalchanges
7086 global bgcolor fgcolor ctext diffcolors selectbgcolor
7087 global uifont tabstop
7089 set top .gitkprefs
7090 set prefstop $top
7091 if {[winfo exists $top]} {
7092 raise $top
7093 return
7095 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7096 set oldprefs($v) [set $v]
7098 toplevel $top
7099 wm title $top "Gitk preferences"
7100 label $top.ldisp -text "Commit list display options"
7101 $top.ldisp configure -font $uifont
7102 grid $top.ldisp - -sticky w -pady 10
7103 label $top.spacer -text " "
7104 label $top.maxwidthl -text "Maximum graph width (lines)" \
7105 -font optionfont
7106 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7107 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7108 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7109 -font optionfont
7110 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7111 grid x $top.maxpctl $top.maxpct -sticky w
7112 frame $top.showlocal
7113 label $top.showlocal.l -text "Show local changes" -font optionfont
7114 checkbutton $top.showlocal.b -variable showlocalchanges
7115 pack $top.showlocal.b $top.showlocal.l -side left
7116 grid x $top.showlocal -sticky w
7118 label $top.ddisp -text "Diff display options"
7119 $top.ddisp configure -font $uifont
7120 grid $top.ddisp - -sticky w -pady 10
7121 label $top.diffoptl -text "Options for diff program" \
7122 -font optionfont
7123 entry $top.diffopt -width 20 -textvariable diffopts
7124 grid x $top.diffoptl $top.diffopt -sticky w
7125 frame $top.ntag
7126 label $top.ntag.l -text "Display nearby tags" -font optionfont
7127 checkbutton $top.ntag.b -variable showneartags
7128 pack $top.ntag.b $top.ntag.l -side left
7129 grid x $top.ntag -sticky w
7130 label $top.tabstopl -text "tabstop" -font optionfont
7131 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7132 grid x $top.tabstopl $top.tabstop -sticky w
7134 label $top.cdisp -text "Colors: press to choose"
7135 $top.cdisp configure -font $uifont
7136 grid $top.cdisp - -sticky w -pady 10
7137 label $top.bg -padx 40 -relief sunk -background $bgcolor
7138 button $top.bgbut -text "Background" -font optionfont \
7139 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7140 grid x $top.bgbut $top.bg -sticky w
7141 label $top.fg -padx 40 -relief sunk -background $fgcolor
7142 button $top.fgbut -text "Foreground" -font optionfont \
7143 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7144 grid x $top.fgbut $top.fg -sticky w
7145 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7146 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7147 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7148 [list $ctext tag conf d0 -foreground]]
7149 grid x $top.diffoldbut $top.diffold -sticky w
7150 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7151 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7152 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7153 [list $ctext tag conf d1 -foreground]]
7154 grid x $top.diffnewbut $top.diffnew -sticky w
7155 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7156 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7157 -command [list choosecolor diffcolors 2 $top.hunksep \
7158 "diff hunk header" \
7159 [list $ctext tag conf hunksep -foreground]]
7160 grid x $top.hunksepbut $top.hunksep -sticky w
7161 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7162 button $top.selbgbut -text "Select bg" -font optionfont \
7163 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7164 grid x $top.selbgbut $top.selbgsep -sticky w
7166 frame $top.buts
7167 button $top.buts.ok -text "OK" -command prefsok -default active
7168 $top.buts.ok configure -font $uifont
7169 button $top.buts.can -text "Cancel" -command prefscan -default normal
7170 $top.buts.can configure -font $uifont
7171 grid $top.buts.ok $top.buts.can
7172 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7173 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7174 grid $top.buts - - -pady 10 -sticky ew
7175 bind $top <Visibility> "focus $top.buts.ok"
7178 proc choosecolor {v vi w x cmd} {
7179 global $v
7181 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7182 -title "Gitk: choose color for $x"]
7183 if {$c eq {}} return
7184 $w conf -background $c
7185 lset $v $vi $c
7186 eval $cmd $c
7189 proc setselbg {c} {
7190 global bglist cflist
7191 foreach w $bglist {
7192 $w configure -selectbackground $c
7194 $cflist tag configure highlight \
7195 -background [$cflist cget -selectbackground]
7196 allcanvs itemconf secsel -fill $c
7199 proc setbg {c} {
7200 global bglist
7202 foreach w $bglist {
7203 $w conf -background $c
7207 proc setfg {c} {
7208 global fglist canv
7210 foreach w $fglist {
7211 $w conf -foreground $c
7213 allcanvs itemconf text -fill $c
7214 $canv itemconf circle -outline $c
7217 proc prefscan {} {
7218 global maxwidth maxgraphpct diffopts
7219 global oldprefs prefstop showneartags showlocalchanges
7221 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7222 set $v $oldprefs($v)
7224 catch {destroy $prefstop}
7225 unset prefstop
7228 proc prefsok {} {
7229 global maxwidth maxgraphpct
7230 global oldprefs prefstop showneartags showlocalchanges
7231 global charspc ctext tabstop
7233 catch {destroy $prefstop}
7234 unset prefstop
7235 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7236 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7237 if {$showlocalchanges} {
7238 doshowlocalchanges
7239 } else {
7240 dohidelocalchanges
7243 if {$maxwidth != $oldprefs(maxwidth)
7244 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7245 redisplay
7246 } elseif {$showneartags != $oldprefs(showneartags)} {
7247 reselectline
7251 proc formatdate {d} {
7252 if {$d ne {}} {
7253 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7255 return $d
7258 # This list of encoding names and aliases is distilled from
7259 # http://www.iana.org/assignments/character-sets.
7260 # Not all of them are supported by Tcl.
7261 set encoding_aliases {
7262 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7263 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7264 { ISO-10646-UTF-1 csISO10646UTF1 }
7265 { ISO_646.basic:1983 ref csISO646basic1983 }
7266 { INVARIANT csINVARIANT }
7267 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7268 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7269 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7270 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7271 { NATS-DANO iso-ir-9-1 csNATSDANO }
7272 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7273 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7274 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7275 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7276 { ISO-2022-KR csISO2022KR }
7277 { EUC-KR csEUCKR }
7278 { ISO-2022-JP csISO2022JP }
7279 { ISO-2022-JP-2 csISO2022JP2 }
7280 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7281 csISO13JISC6220jp }
7282 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7283 { IT iso-ir-15 ISO646-IT csISO15Italian }
7284 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7285 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7286 { greek7-old iso-ir-18 csISO18Greek7Old }
7287 { latin-greek iso-ir-19 csISO19LatinGreek }
7288 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7289 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7290 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7291 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7292 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7293 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7294 { INIS iso-ir-49 csISO49INIS }
7295 { INIS-8 iso-ir-50 csISO50INIS8 }
7296 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7297 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7298 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7299 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7300 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7301 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7302 csISO60Norwegian1 }
7303 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7304 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7305 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7306 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7307 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7308 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7309 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7310 { greek7 iso-ir-88 csISO88Greek7 }
7311 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7312 { iso-ir-90 csISO90 }
7313 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7314 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7315 csISO92JISC62991984b }
7316 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7317 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7318 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7319 csISO95JIS62291984handadd }
7320 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7321 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7322 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7323 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7324 CP819 csISOLatin1 }
7325 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7326 { T.61-7bit iso-ir-102 csISO102T617bit }
7327 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7328 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7329 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7330 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7331 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7332 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7333 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7334 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7335 arabic csISOLatinArabic }
7336 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7337 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7338 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7339 greek greek8 csISOLatinGreek }
7340 { T.101-G2 iso-ir-128 csISO128T101G2 }
7341 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7342 csISOLatinHebrew }
7343 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7344 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7345 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7346 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7347 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7348 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7349 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7350 csISOLatinCyrillic }
7351 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7352 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7353 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7354 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7355 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7356 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7357 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7358 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7359 { ISO_10367-box iso-ir-155 csISO10367Box }
7360 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7361 { latin-lap lap iso-ir-158 csISO158Lap }
7362 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7363 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7364 { us-dk csUSDK }
7365 { dk-us csDKUS }
7366 { JIS_X0201 X0201 csHalfWidthKatakana }
7367 { KSC5636 ISO646-KR csKSC5636 }
7368 { ISO-10646-UCS-2 csUnicode }
7369 { ISO-10646-UCS-4 csUCS4 }
7370 { DEC-MCS dec csDECMCS }
7371 { hp-roman8 roman8 r8 csHPRoman8 }
7372 { macintosh mac csMacintosh }
7373 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7374 csIBM037 }
7375 { IBM038 EBCDIC-INT cp038 csIBM038 }
7376 { IBM273 CP273 csIBM273 }
7377 { IBM274 EBCDIC-BE CP274 csIBM274 }
7378 { IBM275 EBCDIC-BR cp275 csIBM275 }
7379 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7380 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7381 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7382 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7383 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7384 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7385 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7386 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7387 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7388 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7389 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7390 { IBM437 cp437 437 csPC8CodePage437 }
7391 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7392 { IBM775 cp775 csPC775Baltic }
7393 { IBM850 cp850 850 csPC850Multilingual }
7394 { IBM851 cp851 851 csIBM851 }
7395 { IBM852 cp852 852 csPCp852 }
7396 { IBM855 cp855 855 csIBM855 }
7397 { IBM857 cp857 857 csIBM857 }
7398 { IBM860 cp860 860 csIBM860 }
7399 { IBM861 cp861 861 cp-is csIBM861 }
7400 { IBM862 cp862 862 csPC862LatinHebrew }
7401 { IBM863 cp863 863 csIBM863 }
7402 { IBM864 cp864 csIBM864 }
7403 { IBM865 cp865 865 csIBM865 }
7404 { IBM866 cp866 866 csIBM866 }
7405 { IBM868 CP868 cp-ar csIBM868 }
7406 { IBM869 cp869 869 cp-gr csIBM869 }
7407 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7408 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7409 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7410 { IBM891 cp891 csIBM891 }
7411 { IBM903 cp903 csIBM903 }
7412 { IBM904 cp904 904 csIBBM904 }
7413 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7414 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7415 { IBM1026 CP1026 csIBM1026 }
7416 { EBCDIC-AT-DE csIBMEBCDICATDE }
7417 { EBCDIC-AT-DE-A csEBCDICATDEA }
7418 { EBCDIC-CA-FR csEBCDICCAFR }
7419 { EBCDIC-DK-NO csEBCDICDKNO }
7420 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7421 { EBCDIC-FI-SE csEBCDICFISE }
7422 { EBCDIC-FI-SE-A csEBCDICFISEA }
7423 { EBCDIC-FR csEBCDICFR }
7424 { EBCDIC-IT csEBCDICIT }
7425 { EBCDIC-PT csEBCDICPT }
7426 { EBCDIC-ES csEBCDICES }
7427 { EBCDIC-ES-A csEBCDICESA }
7428 { EBCDIC-ES-S csEBCDICESS }
7429 { EBCDIC-UK csEBCDICUK }
7430 { EBCDIC-US csEBCDICUS }
7431 { UNKNOWN-8BIT csUnknown8BiT }
7432 { MNEMONIC csMnemonic }
7433 { MNEM csMnem }
7434 { VISCII csVISCII }
7435 { VIQR csVIQR }
7436 { KOI8-R csKOI8R }
7437 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7438 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7439 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7440 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7441 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7442 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7443 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7444 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7445 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7446 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7447 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7448 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7449 { IBM1047 IBM-1047 }
7450 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7451 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7452 { UNICODE-1-1 csUnicode11 }
7453 { CESU-8 csCESU-8 }
7454 { BOCU-1 csBOCU-1 }
7455 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7456 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7457 l8 }
7458 { ISO-8859-15 ISO_8859-15 Latin-9 }
7459 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7460 { GBK CP936 MS936 windows-936 }
7461 { JIS_Encoding csJISEncoding }
7462 { Shift_JIS MS_Kanji csShiftJIS }
7463 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7464 EUC-JP }
7465 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7466 { ISO-10646-UCS-Basic csUnicodeASCII }
7467 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7468 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7469 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7470 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7471 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7472 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7473 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7474 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7475 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7476 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7477 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7478 { Ventura-US csVenturaUS }
7479 { Ventura-International csVenturaInternational }
7480 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7481 { PC8-Turkish csPC8Turkish }
7482 { IBM-Symbols csIBMSymbols }
7483 { IBM-Thai csIBMThai }
7484 { HP-Legal csHPLegal }
7485 { HP-Pi-font csHPPiFont }
7486 { HP-Math8 csHPMath8 }
7487 { Adobe-Symbol-Encoding csHPPSMath }
7488 { HP-DeskTop csHPDesktop }
7489 { Ventura-Math csVenturaMath }
7490 { Microsoft-Publishing csMicrosoftPublishing }
7491 { Windows-31J csWindows31J }
7492 { GB2312 csGB2312 }
7493 { Big5 csBig5 }
7496 proc tcl_encoding {enc} {
7497 global encoding_aliases
7498 set names [encoding names]
7499 set lcnames [string tolower $names]
7500 set enc [string tolower $enc]
7501 set i [lsearch -exact $lcnames $enc]
7502 if {$i < 0} {
7503 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7504 if {[regsub {^iso[-_]} $enc iso encx]} {
7505 set i [lsearch -exact $lcnames $encx]
7508 if {$i < 0} {
7509 foreach l $encoding_aliases {
7510 set ll [string tolower $l]
7511 if {[lsearch -exact $ll $enc] < 0} continue
7512 # look through the aliases for one that tcl knows about
7513 foreach e $ll {
7514 set i [lsearch -exact $lcnames $e]
7515 if {$i < 0} {
7516 if {[regsub {^iso[-_]} $e iso ex]} {
7517 set i [lsearch -exact $lcnames $ex]
7520 if {$i >= 0} break
7522 break
7525 if {$i >= 0} {
7526 return [lindex $names $i]
7528 return {}
7531 # defaults...
7532 set datemode 0
7533 set diffopts "-U 5 -p"
7534 set wrcomcmd "git diff-tree --stdin -p --pretty"
7536 set gitencoding {}
7537 catch {
7538 set gitencoding [exec git config --get i18n.commitencoding]
7540 if {$gitencoding == ""} {
7541 set gitencoding "utf-8"
7543 set tclencoding [tcl_encoding $gitencoding]
7544 if {$tclencoding == {}} {
7545 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7548 set mainfont {Helvetica 9}
7549 set textfont {Courier 9}
7550 set uifont {Helvetica 9 bold}
7551 set tabstop 8
7552 set findmergefiles 0
7553 set maxgraphpct 50
7554 set maxwidth 16
7555 set revlistorder 0
7556 set fastdate 0
7557 set uparrowlen 7
7558 set downarrowlen 7
7559 set mingaplen 30
7560 set cmitmode "patch"
7561 set wrapcomment "none"
7562 set showneartags 1
7563 set maxrefs 20
7564 set maxlinelen 200
7565 set showlocalchanges 1
7567 set colors {green red blue magenta darkgrey brown orange}
7568 set bgcolor white
7569 set fgcolor black
7570 set diffcolors {red "#00a000" blue}
7571 set selectbgcolor gray85
7573 catch {source ~/.gitk}
7575 font create optionfont -family sans-serif -size -12
7577 # check that we can find a .git directory somewhere...
7578 set gitdir [gitdir]
7579 if {![file isdirectory $gitdir]} {
7580 show_error {} . "Cannot find the git directory \"$gitdir\"."
7581 exit 1
7584 set revtreeargs {}
7585 set cmdline_files {}
7586 set i 0
7587 foreach arg $argv {
7588 switch -- $arg {
7589 "" { }
7590 "-d" { set datemode 1 }
7591 "--" {
7592 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7593 break
7595 default {
7596 lappend revtreeargs $arg
7599 incr i
7602 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7603 # no -- on command line, but some arguments (other than -d)
7604 if {[catch {
7605 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7606 set cmdline_files [split $f "\n"]
7607 set n [llength $cmdline_files]
7608 set revtreeargs [lrange $revtreeargs 0 end-$n]
7609 # Unfortunately git rev-parse doesn't produce an error when
7610 # something is both a revision and a filename. To be consistent
7611 # with git log and git rev-list, check revtreeargs for filenames.
7612 foreach arg $revtreeargs {
7613 if {[file exists $arg]} {
7614 show_error {} . "Ambiguous argument '$arg': both revision\
7615 and filename"
7616 exit 1
7619 } err]} {
7620 # unfortunately we get both stdout and stderr in $err,
7621 # so look for "fatal:".
7622 set i [string first "fatal:" $err]
7623 if {$i > 0} {
7624 set err [string range $err [expr {$i + 6}] end]
7626 show_error {} . "Bad arguments to gitk:\n$err"
7627 exit 1
7631 set nullid "0000000000000000000000000000000000000000"
7632 set nullid2 "0000000000000000000000000000000000000001"
7635 set runq {}
7636 set history {}
7637 set historyindex 0
7638 set fh_serial 0
7639 set nhl_names {}
7640 set highlight_paths {}
7641 set searchdirn -forwards
7642 set boldrows {}
7643 set boldnamerows {}
7644 set diffelide {0 0}
7645 set markingmatches 0
7647 set optim_delay 16
7649 set nextviewnum 1
7650 set curview 0
7651 set selectedview 0
7652 set selectedhlview None
7653 set viewfiles(0) {}
7654 set viewperm(0) 0
7655 set viewargs(0) {}
7657 set cmdlineok 0
7658 set stopped 0
7659 set stuffsaved 0
7660 set patchnum 0
7661 set lookingforhead 0
7662 set localirow -1
7663 set localfrow -1
7664 set lserial 0
7665 setcoords
7666 makewindow
7667 # wait for the window to become visible
7668 tkwait visibility .
7669 wm title . "[file tail $argv0]: [file tail [pwd]]"
7670 readrefs
7672 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7673 # create a view for the files/dirs specified on the command line
7674 set curview 1
7675 set selectedview 1
7676 set nextviewnum 2
7677 set viewname(1) "Command line"
7678 set viewfiles(1) $cmdline_files
7679 set viewargs(1) $revtreeargs
7680 set viewperm(1) 0
7681 addviewmenu 1
7682 .bar.view entryconf Edit* -state normal
7683 .bar.view entryconf Delete* -state normal
7686 if {[info exists permviews]} {
7687 foreach v $permviews {
7688 set n $nextviewnum
7689 incr nextviewnum
7690 set viewname($n) [lindex $v 0]
7691 set viewfiles($n) [lindex $v 1]
7692 set viewargs($n) [lindex $v 2]
7693 set viewperm($n) 1
7694 addviewmenu $n
7697 getcommits