[PATCH] gitk: Bind keyboard actions to the command key on Mac OS
[git/spearce.git] / gitk
blob66e4a643d6df64ad42c5d6a68e9c75eaf2f591a8
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 if {$stuff == {}} {
143 if {![eof $fd]} {
144 return 1
146 global viewname
147 unset commfd($view)
148 notbusy $view
149 # set it blocking so we wait for the process to terminate
150 fconfigure $fd -blocking 1
151 if {[catch {close $fd} err]} {
152 set fv {}
153 if {$view != $curview} {
154 set fv " for the \"$viewname($view)\" view"
156 if {[string range $err 0 4] == "usage"} {
157 set err "Gitk: error reading commits$fv:\
158 bad arguments to git rev-list."
159 if {$viewname($view) eq "Command line"} {
160 append err \
161 " (Note: arguments to gitk are passed to git rev-list\
162 to allow selection of commits to be displayed.)"
164 } else {
165 set err "Error reading commits$fv: $err"
167 error_popup $err
169 if {$view == $curview} {
170 run chewcommits $view
172 return 0
174 set start 0
175 set gotsome 0
176 while 1 {
177 set i [string first "\0" $stuff $start]
178 if {$i < 0} {
179 append leftover($view) [string range $stuff $start end]
180 break
182 if {$start == 0} {
183 set cmit $leftover($view)
184 append cmit [string range $stuff 0 [expr {$i - 1}]]
185 set leftover($view) {}
186 } else {
187 set cmit [string range $stuff $start [expr {$i - 1}]]
189 set start [expr {$i + 1}]
190 set j [string first "\n" $cmit]
191 set ok 0
192 set listed 1
193 if {$j >= 0 && [string match "commit *" $cmit]} {
194 set ids [string range $cmit 7 [expr {$j - 1}]]
195 if {[string match {[-<>]*} $ids]} {
196 switch -- [string index $ids 0] {
197 "-" {set listed 0}
198 "<" {set listed 2}
199 ">" {set listed 3}
201 set ids [string range $ids 1 end]
203 set ok 1
204 foreach id $ids {
205 if {[string length $id] != 40} {
206 set ok 0
207 break
211 if {!$ok} {
212 set shortcmit $cmit
213 if {[string length $shortcmit] > 80} {
214 set shortcmit "[string range $shortcmit 0 80]..."
216 error_popup "Can't parse git log output: {$shortcmit}"
217 exit 1
219 set id [lindex $ids 0]
220 if {$listed} {
221 set olds [lrange $ids 1 end]
222 set i 0
223 foreach p $olds {
224 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
225 lappend children($view,$p) $id
227 incr i
229 } else {
230 set olds {}
232 if {![info exists children($view,$id)]} {
233 set children($view,$id) {}
235 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
236 set commitrow($view,$id) $commitidx($view)
237 incr commitidx($view)
238 if {$view == $curview} {
239 lappend parentlist $olds
240 lappend displayorder $id
241 lappend commitlisted $listed
242 } else {
243 lappend vparentlist($view) $olds
244 lappend vdisporder($view) $id
245 lappend vcmitlisted($view) $listed
247 set gotsome 1
249 if {$gotsome} {
250 run chewcommits $view
252 return 2
255 proc chewcommits {view} {
256 global curview hlview commfd
257 global selectedline pending_select
259 set more 0
260 if {$view == $curview} {
261 set allread [expr {![info exists commfd($view)]}]
262 set tlimit [expr {[clock clicks -milliseconds] + 50}]
263 set more [layoutmore $tlimit $allread]
264 if {$allread && !$more} {
265 global displayorder commitidx phase
266 global numcommits startmsecs
268 if {[info exists pending_select]} {
269 set row [first_real_row]
270 selectline $row 1
272 if {$commitidx($curview) > 0} {
273 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
274 #puts "overall $ms ms for $numcommits commits"
275 } else {
276 show_status "No commits selected"
278 notbusy layout
279 set phase {}
282 if {[info exists hlview] && $view == $hlview} {
283 vhighlightmore
285 return $more
288 proc readcommit {id} {
289 if {[catch {set contents [exec git cat-file commit $id]}]} return
290 parsecommit $id $contents 0
293 proc updatecommits {} {
294 global viewdata curview phase displayorder
295 global children commitrow selectedline thickerline
297 if {$phase ne {}} {
298 stop_rev_list
299 set phase {}
301 set n $curview
302 foreach id $displayorder {
303 catch {unset children($n,$id)}
304 catch {unset commitrow($n,$id)}
306 set curview -1
307 catch {unset selectedline}
308 catch {unset thickerline}
309 catch {unset viewdata($n)}
310 readrefs
311 changedrefs
312 regetallcommits
313 showview $n
316 proc parsecommit {id contents listed} {
317 global commitinfo cdate
319 set inhdr 1
320 set comment {}
321 set headline {}
322 set auname {}
323 set audate {}
324 set comname {}
325 set comdate {}
326 set hdrend [string first "\n\n" $contents]
327 if {$hdrend < 0} {
328 # should never happen...
329 set hdrend [string length $contents]
331 set header [string range $contents 0 [expr {$hdrend - 1}]]
332 set comment [string range $contents [expr {$hdrend + 2}] end]
333 foreach line [split $header "\n"] {
334 set tag [lindex $line 0]
335 if {$tag == "author"} {
336 set audate [lindex $line end-1]
337 set auname [lrange $line 1 end-2]
338 } elseif {$tag == "committer"} {
339 set comdate [lindex $line end-1]
340 set comname [lrange $line 1 end-2]
343 set headline {}
344 # take the first non-blank line of the comment as the headline
345 set headline [string trimleft $comment]
346 set i [string first "\n" $headline]
347 if {$i >= 0} {
348 set headline [string range $headline 0 $i]
350 set headline [string trimright $headline]
351 set i [string first "\r" $headline]
352 if {$i >= 0} {
353 set headline [string trimright [string range $headline 0 $i]]
355 if {!$listed} {
356 # git rev-list indents the comment by 4 spaces;
357 # if we got this via git cat-file, add the indentation
358 set newcomment {}
359 foreach line [split $comment "\n"] {
360 append newcomment " "
361 append newcomment $line
362 append newcomment "\n"
364 set comment $newcomment
366 if {$comdate != {}} {
367 set cdate($id) $comdate
369 set commitinfo($id) [list $headline $auname $audate \
370 $comname $comdate $comment]
373 proc getcommit {id} {
374 global commitdata commitinfo
376 if {[info exists commitdata($id)]} {
377 parsecommit $id $commitdata($id) 1
378 } else {
379 readcommit $id
380 if {![info exists commitinfo($id)]} {
381 set commitinfo($id) {"No commit information available"}
384 return 1
387 proc readrefs {} {
388 global tagids idtags headids idheads tagobjid
389 global otherrefids idotherrefs mainhead mainheadid
391 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
392 catch {unset $v}
394 set refd [open [list | git show-ref -d] r]
395 while {[gets $refd line] >= 0} {
396 if {[string index $line 40] ne " "} continue
397 set id [string range $line 0 39]
398 set ref [string range $line 41 end]
399 if {![string match "refs/*" $ref]} continue
400 set name [string range $ref 5 end]
401 if {[string match "remotes/*" $name]} {
402 if {![string match "*/HEAD" $name]} {
403 set headids($name) $id
404 lappend idheads($id) $name
406 } elseif {[string match "heads/*" $name]} {
407 set name [string range $name 6 end]
408 set headids($name) $id
409 lappend idheads($id) $name
410 } elseif {[string match "tags/*" $name]} {
411 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
412 # which is what we want since the former is the commit ID
413 set name [string range $name 5 end]
414 if {[string match "*^{}" $name]} {
415 set name [string range $name 0 end-3]
416 } else {
417 set tagobjid($name) $id
419 set tagids($name) $id
420 lappend idtags($id) $name
421 } else {
422 set otherrefids($name) $id
423 lappend idotherrefs($id) $name
426 close $refd
427 set mainhead {}
428 set mainheadid {}
429 catch {
430 set thehead [exec git symbolic-ref HEAD]
431 if {[string match "refs/heads/*" $thehead]} {
432 set mainhead [string range $thehead 11 end]
433 if {[info exists headids($mainhead)]} {
434 set mainheadid $headids($mainhead)
440 # skip over fake commits
441 proc first_real_row {} {
442 global nullid nullid2 displayorder numcommits
444 for {set row 0} {$row < $numcommits} {incr row} {
445 set id [lindex $displayorder $row]
446 if {$id ne $nullid && $id ne $nullid2} {
447 break
450 return $row
453 # update things for a head moved to a child of its previous location
454 proc movehead {id name} {
455 global headids idheads
457 removehead $headids($name) $name
458 set headids($name) $id
459 lappend idheads($id) $name
462 # update things when a head has been removed
463 proc removehead {id name} {
464 global headids idheads
466 if {$idheads($id) eq $name} {
467 unset idheads($id)
468 } else {
469 set i [lsearch -exact $idheads($id) $name]
470 if {$i >= 0} {
471 set idheads($id) [lreplace $idheads($id) $i $i]
474 unset headids($name)
477 proc show_error {w top msg} {
478 message $w.m -text $msg -justify center -aspect 400
479 pack $w.m -side top -fill x -padx 20 -pady 20
480 button $w.ok -text OK -command "destroy $top"
481 pack $w.ok -side bottom -fill x
482 bind $top <Visibility> "grab $top; focus $top"
483 bind $top <Key-Return> "destroy $top"
484 tkwait window $top
487 proc error_popup msg {
488 set w .error
489 toplevel $w
490 wm transient $w .
491 show_error $w $w $msg
494 proc confirm_popup msg {
495 global confirm_ok
496 set confirm_ok 0
497 set w .confirm
498 toplevel $w
499 wm transient $w .
500 message $w.m -text $msg -justify center -aspect 400
501 pack $w.m -side top -fill x -padx 20 -pady 20
502 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
503 pack $w.ok -side left -fill x
504 button $w.cancel -text Cancel -command "destroy $w"
505 pack $w.cancel -side right -fill x
506 bind $w <Visibility> "grab $w; focus $w"
507 tkwait window $w
508 return $confirm_ok
511 proc makewindow {} {
512 global canv canv2 canv3 linespc charspc ctext cflist
513 global textfont mainfont uifont tabstop
514 global findtype findtypemenu findloc findstring fstring geometry
515 global entries sha1entry sha1string sha1but
516 global maincursor textcursor curtextcursor
517 global rowctxmenu fakerowmenu mergemax wrapcomment
518 global highlight_files gdttype
519 global searchstring sstring
520 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
521 global headctxmenu
523 menu .bar
524 .bar add cascade -label "File" -menu .bar.file
525 .bar configure -font $uifont
526 menu .bar.file
527 .bar.file add command -label "Update" -command updatecommits
528 .bar.file add command -label "Reread references" -command rereadrefs
529 .bar.file add command -label "Quit" -command doquit
530 .bar.file configure -font $uifont
531 menu .bar.edit
532 .bar add cascade -label "Edit" -menu .bar.edit
533 .bar.edit add command -label "Preferences" -command doprefs
534 .bar.edit configure -font $uifont
536 menu .bar.view -font $uifont
537 .bar add cascade -label "View" -menu .bar.view
538 .bar.view add command -label "New view..." -command {newview 0}
539 .bar.view add command -label "Edit view..." -command editview \
540 -state disabled
541 .bar.view add command -label "Delete view" -command delview -state disabled
542 .bar.view add separator
543 .bar.view add radiobutton -label "All files" -command {showview 0} \
544 -variable selectedview -value 0
546 menu .bar.help
547 .bar add cascade -label "Help" -menu .bar.help
548 .bar.help add command -label "About gitk" -command about
549 .bar.help add command -label "Key bindings" -command keys
550 .bar.help configure -font $uifont
551 . configure -menu .bar
553 # the gui has upper and lower half, parts of a paned window.
554 panedwindow .ctop -orient vertical
556 # possibly use assumed geometry
557 if {![info exists geometry(pwsash0)]} {
558 set geometry(topheight) [expr {15 * $linespc}]
559 set geometry(topwidth) [expr {80 * $charspc}]
560 set geometry(botheight) [expr {15 * $linespc}]
561 set geometry(botwidth) [expr {50 * $charspc}]
562 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
563 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
566 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
567 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
568 frame .tf.histframe
569 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
571 # create three canvases
572 set cscroll .tf.histframe.csb
573 set canv .tf.histframe.pwclist.canv
574 canvas $canv \
575 -selectbackground $selectbgcolor \
576 -background $bgcolor -bd 0 \
577 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
578 .tf.histframe.pwclist add $canv
579 set canv2 .tf.histframe.pwclist.canv2
580 canvas $canv2 \
581 -selectbackground $selectbgcolor \
582 -background $bgcolor -bd 0 -yscrollincr $linespc
583 .tf.histframe.pwclist add $canv2
584 set canv3 .tf.histframe.pwclist.canv3
585 canvas $canv3 \
586 -selectbackground $selectbgcolor \
587 -background $bgcolor -bd 0 -yscrollincr $linespc
588 .tf.histframe.pwclist add $canv3
589 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
590 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
592 # a scroll bar to rule them
593 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
594 pack $cscroll -side right -fill y
595 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
596 lappend bglist $canv $canv2 $canv3
597 pack .tf.histframe.pwclist -fill both -expand 1 -side left
599 # we have two button bars at bottom of top frame. Bar 1
600 frame .tf.bar
601 frame .tf.lbar -height 15
603 set sha1entry .tf.bar.sha1
604 set entries $sha1entry
605 set sha1but .tf.bar.sha1label
606 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
607 -command gotocommit -width 8 -font $uifont
608 $sha1but conf -disabledforeground [$sha1but cget -foreground]
609 pack .tf.bar.sha1label -side left
610 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
611 trace add variable sha1string write sha1change
612 pack $sha1entry -side left -pady 2
614 image create bitmap bm-left -data {
615 #define left_width 16
616 #define left_height 16
617 static unsigned char left_bits[] = {
618 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
619 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
620 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
622 image create bitmap bm-right -data {
623 #define right_width 16
624 #define right_height 16
625 static unsigned char right_bits[] = {
626 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
627 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
628 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
630 button .tf.bar.leftbut -image bm-left -command goback \
631 -state disabled -width 26
632 pack .tf.bar.leftbut -side left -fill y
633 button .tf.bar.rightbut -image bm-right -command goforw \
634 -state disabled -width 26
635 pack .tf.bar.rightbut -side left -fill y
637 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
638 pack .tf.bar.findbut -side left
639 set findstring {}
640 set fstring .tf.bar.findstring
641 lappend entries $fstring
642 entry $fstring -width 30 -font $textfont -textvariable findstring
643 trace add variable findstring write find_change
644 pack $fstring -side left -expand 1 -fill x -in .tf.bar
645 set findtype Exact
646 set findtypemenu [tk_optionMenu .tf.bar.findtype \
647 findtype Exact IgnCase Regexp]
648 trace add variable findtype write find_change
649 .tf.bar.findtype configure -font $uifont
650 .tf.bar.findtype.menu configure -font $uifont
651 set findloc "All fields"
652 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
653 Comments Author Committer
654 trace add variable findloc write find_change
655 .tf.bar.findloc configure -font $uifont
656 .tf.bar.findloc.menu configure -font $uifont
657 pack .tf.bar.findloc -side right
658 pack .tf.bar.findtype -side right
660 # build up the bottom bar of upper window
661 label .tf.lbar.flabel -text "Highlight: Commits " \
662 -font $uifont
663 pack .tf.lbar.flabel -side left -fill y
664 set gdttype "touching paths:"
665 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
666 "adding/removing string:"]
667 trace add variable gdttype write hfiles_change
668 $gm conf -font $uifont
669 .tf.lbar.gdttype conf -font $uifont
670 pack .tf.lbar.gdttype -side left -fill y
671 entry .tf.lbar.fent -width 25 -font $textfont \
672 -textvariable highlight_files
673 trace add variable highlight_files write hfiles_change
674 lappend entries .tf.lbar.fent
675 pack .tf.lbar.fent -side left -fill x -expand 1
676 label .tf.lbar.vlabel -text " OR in view" -font $uifont
677 pack .tf.lbar.vlabel -side left -fill y
678 global viewhlmenu selectedhlview
679 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
680 $viewhlmenu entryconf None -command delvhighlight
681 $viewhlmenu conf -font $uifont
682 .tf.lbar.vhl conf -font $uifont
683 pack .tf.lbar.vhl -side left -fill y
684 label .tf.lbar.rlabel -text " OR " -font $uifont
685 pack .tf.lbar.rlabel -side left -fill y
686 global highlight_related
687 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
688 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
689 $m conf -font $uifont
690 .tf.lbar.relm conf -font $uifont
691 trace add variable highlight_related write vrel_change
692 pack .tf.lbar.relm -side left -fill y
694 # Finish putting the upper half of the viewer together
695 pack .tf.lbar -in .tf -side bottom -fill x
696 pack .tf.bar -in .tf -side bottom -fill x
697 pack .tf.histframe -fill both -side top -expand 1
698 .ctop add .tf
699 .ctop paneconfigure .tf -height $geometry(topheight)
700 .ctop paneconfigure .tf -width $geometry(topwidth)
702 # now build up the bottom
703 panedwindow .pwbottom -orient horizontal
705 # lower left, a text box over search bar, scroll bar to the right
706 # if we know window height, then that will set the lower text height, otherwise
707 # we set lower text height which will drive window height
708 if {[info exists geometry(main)]} {
709 frame .bleft -width $geometry(botwidth)
710 } else {
711 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
713 frame .bleft.top
714 frame .bleft.mid
716 button .bleft.top.search -text "Search" -command dosearch \
717 -font $uifont
718 pack .bleft.top.search -side left -padx 5
719 set sstring .bleft.top.sstring
720 entry $sstring -width 20 -font $textfont -textvariable searchstring
721 lappend entries $sstring
722 trace add variable searchstring write incrsearch
723 pack $sstring -side left -expand 1 -fill x
724 radiobutton .bleft.mid.diff -text "Diff" \
725 -command changediffdisp -variable diffelide -value {0 0}
726 radiobutton .bleft.mid.old -text "Old version" \
727 -command changediffdisp -variable diffelide -value {0 1}
728 radiobutton .bleft.mid.new -text "New version" \
729 -command changediffdisp -variable diffelide -value {1 0}
730 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
731 set ctext .bleft.ctext
732 text $ctext -background $bgcolor -foreground $fgcolor \
733 -tabs "[expr {$tabstop * $charspc}]" \
734 -state disabled -font $textfont \
735 -yscrollcommand scrolltext -wrap none
736 scrollbar .bleft.sb -command "$ctext yview"
737 pack .bleft.top -side top -fill x
738 pack .bleft.mid -side top -fill x
739 pack .bleft.sb -side right -fill y
740 pack $ctext -side left -fill both -expand 1
741 lappend bglist $ctext
742 lappend fglist $ctext
744 $ctext tag conf comment -wrap $wrapcomment
745 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
746 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
747 $ctext tag conf d0 -fore [lindex $diffcolors 0]
748 $ctext tag conf d1 -fore [lindex $diffcolors 1]
749 $ctext tag conf m0 -fore red
750 $ctext tag conf m1 -fore blue
751 $ctext tag conf m2 -fore green
752 $ctext tag conf m3 -fore purple
753 $ctext tag conf m4 -fore brown
754 $ctext tag conf m5 -fore "#009090"
755 $ctext tag conf m6 -fore magenta
756 $ctext tag conf m7 -fore "#808000"
757 $ctext tag conf m8 -fore "#009000"
758 $ctext tag conf m9 -fore "#ff0080"
759 $ctext tag conf m10 -fore cyan
760 $ctext tag conf m11 -fore "#b07070"
761 $ctext tag conf m12 -fore "#70b0f0"
762 $ctext tag conf m13 -fore "#70f0b0"
763 $ctext tag conf m14 -fore "#f0b070"
764 $ctext tag conf m15 -fore "#ff70b0"
765 $ctext tag conf mmax -fore darkgrey
766 set mergemax 16
767 $ctext tag conf mresult -font [concat $textfont bold]
768 $ctext tag conf msep -font [concat $textfont bold]
769 $ctext tag conf found -back yellow
771 .pwbottom add .bleft
772 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
774 # lower right
775 frame .bright
776 frame .bright.mode
777 radiobutton .bright.mode.patch -text "Patch" \
778 -command reselectline -variable cmitmode -value "patch"
779 .bright.mode.patch configure -font $uifont
780 radiobutton .bright.mode.tree -text "Tree" \
781 -command reselectline -variable cmitmode -value "tree"
782 .bright.mode.tree configure -font $uifont
783 grid .bright.mode.patch .bright.mode.tree -sticky ew
784 pack .bright.mode -side top -fill x
785 set cflist .bright.cfiles
786 set indent [font measure $mainfont "nn"]
787 text $cflist \
788 -selectbackground $selectbgcolor \
789 -background $bgcolor -foreground $fgcolor \
790 -font $mainfont \
791 -tabs [list $indent [expr {2 * $indent}]] \
792 -yscrollcommand ".bright.sb set" \
793 -cursor [. cget -cursor] \
794 -spacing1 1 -spacing3 1
795 lappend bglist $cflist
796 lappend fglist $cflist
797 scrollbar .bright.sb -command "$cflist yview"
798 pack .bright.sb -side right -fill y
799 pack $cflist -side left -fill both -expand 1
800 $cflist tag configure highlight \
801 -background [$cflist cget -selectbackground]
802 $cflist tag configure bold -font [concat $mainfont bold]
804 .pwbottom add .bright
805 .ctop add .pwbottom
807 # restore window position if known
808 if {[info exists geometry(main)]} {
809 wm geometry . "$geometry(main)"
812 if {[tk windowingsystem] eq {aqua}} {
813 set M1B M1
814 } else {
815 set M1B Control
818 bind .pwbottom <Configure> {resizecdetpanes %W %w}
819 pack .ctop -fill both -expand 1
820 bindall <1> {selcanvline %W %x %y}
821 #bindall <B1-Motion> {selcanvline %W %x %y}
822 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
823 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
824 bindall <2> "canvscan mark %W %x %y"
825 bindall <B2-Motion> "canvscan dragto %W %x %y"
826 bindkey <Home> selfirstline
827 bindkey <End> sellastline
828 bind . <Key-Up> "selnextline -1"
829 bind . <Key-Down> "selnextline 1"
830 bind . <Shift-Key-Up> "next_highlight -1"
831 bind . <Shift-Key-Down> "next_highlight 1"
832 bindkey <Key-Right> "goforw"
833 bindkey <Key-Left> "goback"
834 bind . <Key-Prior> "selnextpage -1"
835 bind . <Key-Next> "selnextpage 1"
836 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
837 bind . <$M1B-End> "allcanvs yview moveto 1.0"
838 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
839 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
840 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
841 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
842 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
843 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
844 bindkey <Key-space> "$ctext yview scroll 1 pages"
845 bindkey p "selnextline -1"
846 bindkey n "selnextline 1"
847 bindkey z "goback"
848 bindkey x "goforw"
849 bindkey i "selnextline -1"
850 bindkey k "selnextline 1"
851 bindkey j "goback"
852 bindkey l "goforw"
853 bindkey b "$ctext yview scroll -1 pages"
854 bindkey d "$ctext yview scroll 18 units"
855 bindkey u "$ctext yview scroll -18 units"
856 bindkey / {findnext 1}
857 bindkey <Key-Return> {findnext 0}
858 bindkey ? findprev
859 bindkey f nextfile
860 bindkey <F5> updatecommits
861 bind . <$M1B-q> doquit
862 bind . <$M1B-f> dofind
863 bind . <$M1B-g> {findnext 0}
864 bind . <$M1B-r> dosearchback
865 bind . <$M1B-s> dosearch
866 bind . <$M1B-equal> {incrfont 1}
867 bind . <$M1B-KP_Add> {incrfont 1}
868 bind . <$M1B-minus> {incrfont -1}
869 bind . <$M1B-KP_Subtract> {incrfont -1}
870 wm protocol . WM_DELETE_WINDOW doquit
871 bind . <Button-1> "click %W"
872 bind $fstring <Key-Return> dofind
873 bind $sha1entry <Key-Return> gotocommit
874 bind $sha1entry <<PasteSelection>> clearsha1
875 bind $cflist <1> {sel_flist %W %x %y; break}
876 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
877 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
879 set maincursor [. cget -cursor]
880 set textcursor [$ctext cget -cursor]
881 set curtextcursor $textcursor
883 set rowctxmenu .rowctxmenu
884 menu $rowctxmenu -tearoff 0
885 $rowctxmenu add command -label "Diff this -> selected" \
886 -command {diffvssel 0}
887 $rowctxmenu add command -label "Diff selected -> this" \
888 -command {diffvssel 1}
889 $rowctxmenu add command -label "Make patch" -command mkpatch
890 $rowctxmenu add command -label "Create tag" -command mktag
891 $rowctxmenu add command -label "Write commit to file" -command writecommit
892 $rowctxmenu add command -label "Create new branch" -command mkbranch
893 $rowctxmenu add command -label "Cherry-pick this commit" \
894 -command cherrypick
895 $rowctxmenu add command -label "Reset HEAD branch to here" \
896 -command resethead
898 set fakerowmenu .fakerowmenu
899 menu $fakerowmenu -tearoff 0
900 $fakerowmenu add command -label "Diff this -> selected" \
901 -command {diffvssel 0}
902 $fakerowmenu add command -label "Diff selected -> this" \
903 -command {diffvssel 1}
904 $fakerowmenu add command -label "Make patch" -command mkpatch
905 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
906 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
907 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
909 set headctxmenu .headctxmenu
910 menu $headctxmenu -tearoff 0
911 $headctxmenu add command -label "Check out this branch" \
912 -command cobranch
913 $headctxmenu add command -label "Remove this branch" \
914 -command rmbranch
917 # mouse-2 makes all windows scan vertically, but only the one
918 # the cursor is in scans horizontally
919 proc canvscan {op w x y} {
920 global canv canv2 canv3
921 foreach c [list $canv $canv2 $canv3] {
922 if {$c == $w} {
923 $c scan $op $x $y
924 } else {
925 $c scan $op 0 $y
930 proc scrollcanv {cscroll f0 f1} {
931 $cscroll set $f0 $f1
932 drawfrac $f0 $f1
933 flushhighlights
936 # when we make a key binding for the toplevel, make sure
937 # it doesn't get triggered when that key is pressed in the
938 # find string entry widget.
939 proc bindkey {ev script} {
940 global entries
941 bind . $ev $script
942 set escript [bind Entry $ev]
943 if {$escript == {}} {
944 set escript [bind Entry <Key>]
946 foreach e $entries {
947 bind $e $ev "$escript; break"
951 # set the focus back to the toplevel for any click outside
952 # the entry widgets
953 proc click {w} {
954 global entries
955 foreach e $entries {
956 if {$w == $e} return
958 focus .
961 proc savestuff {w} {
962 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
963 global stuffsaved findmergefiles maxgraphpct
964 global maxwidth showneartags showlocalchanges
965 global viewname viewfiles viewargs viewperm nextviewnum
966 global cmitmode wrapcomment
967 global colors bgcolor fgcolor diffcolors selectbgcolor
969 if {$stuffsaved} return
970 if {![winfo viewable .]} return
971 catch {
972 set f [open "~/.gitk-new" w]
973 puts $f [list set mainfont $mainfont]
974 puts $f [list set textfont $textfont]
975 puts $f [list set uifont $uifont]
976 puts $f [list set tabstop $tabstop]
977 puts $f [list set findmergefiles $findmergefiles]
978 puts $f [list set maxgraphpct $maxgraphpct]
979 puts $f [list set maxwidth $maxwidth]
980 puts $f [list set cmitmode $cmitmode]
981 puts $f [list set wrapcomment $wrapcomment]
982 puts $f [list set showneartags $showneartags]
983 puts $f [list set showlocalchanges $showlocalchanges]
984 puts $f [list set bgcolor $bgcolor]
985 puts $f [list set fgcolor $fgcolor]
986 puts $f [list set colors $colors]
987 puts $f [list set diffcolors $diffcolors]
988 puts $f [list set selectbgcolor $selectbgcolor]
990 puts $f "set geometry(main) [wm geometry .]"
991 puts $f "set geometry(topwidth) [winfo width .tf]"
992 puts $f "set geometry(topheight) [winfo height .tf]"
993 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
994 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
995 puts $f "set geometry(botwidth) [winfo width .bleft]"
996 puts $f "set geometry(botheight) [winfo height .bleft]"
998 puts -nonewline $f "set permviews {"
999 for {set v 0} {$v < $nextviewnum} {incr v} {
1000 if {$viewperm($v)} {
1001 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1004 puts $f "}"
1005 close $f
1006 file rename -force "~/.gitk-new" "~/.gitk"
1008 set stuffsaved 1
1011 proc resizeclistpanes {win w} {
1012 global oldwidth
1013 if {[info exists oldwidth($win)]} {
1014 set s0 [$win sash coord 0]
1015 set s1 [$win sash coord 1]
1016 if {$w < 60} {
1017 set sash0 [expr {int($w/2 - 2)}]
1018 set sash1 [expr {int($w*5/6 - 2)}]
1019 } else {
1020 set factor [expr {1.0 * $w / $oldwidth($win)}]
1021 set sash0 [expr {int($factor * [lindex $s0 0])}]
1022 set sash1 [expr {int($factor * [lindex $s1 0])}]
1023 if {$sash0 < 30} {
1024 set sash0 30
1026 if {$sash1 < $sash0 + 20} {
1027 set sash1 [expr {$sash0 + 20}]
1029 if {$sash1 > $w - 10} {
1030 set sash1 [expr {$w - 10}]
1031 if {$sash0 > $sash1 - 20} {
1032 set sash0 [expr {$sash1 - 20}]
1036 $win sash place 0 $sash0 [lindex $s0 1]
1037 $win sash place 1 $sash1 [lindex $s1 1]
1039 set oldwidth($win) $w
1042 proc resizecdetpanes {win w} {
1043 global oldwidth
1044 if {[info exists oldwidth($win)]} {
1045 set s0 [$win sash coord 0]
1046 if {$w < 60} {
1047 set sash0 [expr {int($w*3/4 - 2)}]
1048 } else {
1049 set factor [expr {1.0 * $w / $oldwidth($win)}]
1050 set sash0 [expr {int($factor * [lindex $s0 0])}]
1051 if {$sash0 < 45} {
1052 set sash0 45
1054 if {$sash0 > $w - 15} {
1055 set sash0 [expr {$w - 15}]
1058 $win sash place 0 $sash0 [lindex $s0 1]
1060 set oldwidth($win) $w
1063 proc allcanvs args {
1064 global canv canv2 canv3
1065 eval $canv $args
1066 eval $canv2 $args
1067 eval $canv3 $args
1070 proc bindall {event action} {
1071 global canv canv2 canv3
1072 bind $canv $event $action
1073 bind $canv2 $event $action
1074 bind $canv3 $event $action
1077 proc about {} {
1078 global uifont
1079 set w .about
1080 if {[winfo exists $w]} {
1081 raise $w
1082 return
1084 toplevel $w
1085 wm title $w "About gitk"
1086 message $w.m -text {
1087 Gitk - a commit viewer for git
1089 Copyright © 2005-2006 Paul Mackerras
1091 Use and redistribute under the terms of the GNU General Public License} \
1092 -justify center -aspect 400 -border 2 -bg white -relief groove
1093 pack $w.m -side top -fill x -padx 2 -pady 2
1094 $w.m configure -font $uifont
1095 button $w.ok -text Close -command "destroy $w" -default active
1096 pack $w.ok -side bottom
1097 $w.ok configure -font $uifont
1098 bind $w <Visibility> "focus $w.ok"
1099 bind $w <Key-Escape> "destroy $w"
1100 bind $w <Key-Return> "destroy $w"
1103 proc keys {} {
1104 global uifont
1105 set w .keys
1106 if {[winfo exists $w]} {
1107 raise $w
1108 return
1110 if {[tk windowingsystem] eq {aqua}} {
1111 set M1T Cmd
1112 } else {
1113 set M1T Ctrl
1115 toplevel $w
1116 wm title $w "Gitk key bindings"
1117 message $w.m -text "
1118 Gitk key bindings:
1120 <$M1T-Q> Quit
1121 <Home> Move to first commit
1122 <End> Move to last commit
1123 <Up>, p, i Move up one commit
1124 <Down>, n, k Move down one commit
1125 <Left>, z, j Go back in history list
1126 <Right>, x, l Go forward in history list
1127 <PageUp> Move up one page in commit list
1128 <PageDown> Move down one page in commit list
1129 <$M1T-Home> Scroll to top of commit list
1130 <$M1T-End> Scroll to bottom of commit list
1131 <$M1T-Up> Scroll commit list up one line
1132 <$M1T-Down> Scroll commit list down one line
1133 <$M1T-PageUp> Scroll commit list up one page
1134 <$M1T-PageDown> Scroll commit list down one page
1135 <Shift-Up> Move to previous highlighted line
1136 <Shift-Down> Move to next highlighted line
1137 <Delete>, b Scroll diff view up one page
1138 <Backspace> Scroll diff view up one page
1139 <Space> Scroll diff view down one page
1140 u Scroll diff view up 18 lines
1141 d Scroll diff view down 18 lines
1142 <$M1T-F> Find
1143 <$M1T-G> Move to next find hit
1144 <Return> Move to next find hit
1145 / Move to next find hit, or redo find
1146 ? Move to previous find hit
1147 f Scroll diff view to next file
1148 <$M1T-S> Search for next hit in diff view
1149 <$M1T-R> Search for previous hit in diff view
1150 <$M1T-KP+> Increase font size
1151 <$M1T-plus> Increase font size
1152 <$M1T-KP-> Decrease font size
1153 <$M1T-minus> Decrease font size
1154 <F5> Update
1156 -justify left -bg white -border 2 -relief groove
1157 pack $w.m -side top -fill both -padx 2 -pady 2
1158 $w.m configure -font $uifont
1159 button $w.ok -text Close -command "destroy $w" -default active
1160 pack $w.ok -side bottom
1161 $w.ok configure -font $uifont
1162 bind $w <Visibility> "focus $w.ok"
1163 bind $w <Key-Escape> "destroy $w"
1164 bind $w <Key-Return> "destroy $w"
1167 # Procedures for manipulating the file list window at the
1168 # bottom right of the overall window.
1170 proc treeview {w l openlevs} {
1171 global treecontents treediropen treeheight treeparent treeindex
1173 set ix 0
1174 set treeindex() 0
1175 set lev 0
1176 set prefix {}
1177 set prefixend -1
1178 set prefendstack {}
1179 set htstack {}
1180 set ht 0
1181 set treecontents() {}
1182 $w conf -state normal
1183 foreach f $l {
1184 while {[string range $f 0 $prefixend] ne $prefix} {
1185 if {$lev <= $openlevs} {
1186 $w mark set e:$treeindex($prefix) "end -1c"
1187 $w mark gravity e:$treeindex($prefix) left
1189 set treeheight($prefix) $ht
1190 incr ht [lindex $htstack end]
1191 set htstack [lreplace $htstack end end]
1192 set prefixend [lindex $prefendstack end]
1193 set prefendstack [lreplace $prefendstack end end]
1194 set prefix [string range $prefix 0 $prefixend]
1195 incr lev -1
1197 set tail [string range $f [expr {$prefixend+1}] end]
1198 while {[set slash [string first "/" $tail]] >= 0} {
1199 lappend htstack $ht
1200 set ht 0
1201 lappend prefendstack $prefixend
1202 incr prefixend [expr {$slash + 1}]
1203 set d [string range $tail 0 $slash]
1204 lappend treecontents($prefix) $d
1205 set oldprefix $prefix
1206 append prefix $d
1207 set treecontents($prefix) {}
1208 set treeindex($prefix) [incr ix]
1209 set treeparent($prefix) $oldprefix
1210 set tail [string range $tail [expr {$slash+1}] end]
1211 if {$lev <= $openlevs} {
1212 set ht 1
1213 set treediropen($prefix) [expr {$lev < $openlevs}]
1214 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1215 $w mark set d:$ix "end -1c"
1216 $w mark gravity d:$ix left
1217 set str "\n"
1218 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1219 $w insert end $str
1220 $w image create end -align center -image $bm -padx 1 \
1221 -name a:$ix
1222 $w insert end $d [highlight_tag $prefix]
1223 $w mark set s:$ix "end -1c"
1224 $w mark gravity s:$ix left
1226 incr lev
1228 if {$tail ne {}} {
1229 if {$lev <= $openlevs} {
1230 incr ht
1231 set str "\n"
1232 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1233 $w insert end $str
1234 $w insert end $tail [highlight_tag $f]
1236 lappend treecontents($prefix) $tail
1239 while {$htstack ne {}} {
1240 set treeheight($prefix) $ht
1241 incr ht [lindex $htstack end]
1242 set htstack [lreplace $htstack end end]
1243 set prefixend [lindex $prefendstack end]
1244 set prefendstack [lreplace $prefendstack end end]
1245 set prefix [string range $prefix 0 $prefixend]
1247 $w conf -state disabled
1250 proc linetoelt {l} {
1251 global treeheight treecontents
1253 set y 2
1254 set prefix {}
1255 while {1} {
1256 foreach e $treecontents($prefix) {
1257 if {$y == $l} {
1258 return "$prefix$e"
1260 set n 1
1261 if {[string index $e end] eq "/"} {
1262 set n $treeheight($prefix$e)
1263 if {$y + $n > $l} {
1264 append prefix $e
1265 incr y
1266 break
1269 incr y $n
1274 proc highlight_tree {y prefix} {
1275 global treeheight treecontents cflist
1277 foreach e $treecontents($prefix) {
1278 set path $prefix$e
1279 if {[highlight_tag $path] ne {}} {
1280 $cflist tag add bold $y.0 "$y.0 lineend"
1282 incr y
1283 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1284 set y [highlight_tree $y $path]
1287 return $y
1290 proc treeclosedir {w dir} {
1291 global treediropen treeheight treeparent treeindex
1293 set ix $treeindex($dir)
1294 $w conf -state normal
1295 $w delete s:$ix e:$ix
1296 set treediropen($dir) 0
1297 $w image configure a:$ix -image tri-rt
1298 $w conf -state disabled
1299 set n [expr {1 - $treeheight($dir)}]
1300 while {$dir ne {}} {
1301 incr treeheight($dir) $n
1302 set dir $treeparent($dir)
1306 proc treeopendir {w dir} {
1307 global treediropen treeheight treeparent treecontents treeindex
1309 set ix $treeindex($dir)
1310 $w conf -state normal
1311 $w image configure a:$ix -image tri-dn
1312 $w mark set e:$ix s:$ix
1313 $w mark gravity e:$ix right
1314 set lev 0
1315 set str "\n"
1316 set n [llength $treecontents($dir)]
1317 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1318 incr lev
1319 append str "\t"
1320 incr treeheight($x) $n
1322 foreach e $treecontents($dir) {
1323 set de $dir$e
1324 if {[string index $e end] eq "/"} {
1325 set iy $treeindex($de)
1326 $w mark set d:$iy e:$ix
1327 $w mark gravity d:$iy left
1328 $w insert e:$ix $str
1329 set treediropen($de) 0
1330 $w image create e:$ix -align center -image tri-rt -padx 1 \
1331 -name a:$iy
1332 $w insert e:$ix $e [highlight_tag $de]
1333 $w mark set s:$iy e:$ix
1334 $w mark gravity s:$iy left
1335 set treeheight($de) 1
1336 } else {
1337 $w insert e:$ix $str
1338 $w insert e:$ix $e [highlight_tag $de]
1341 $w mark gravity e:$ix left
1342 $w conf -state disabled
1343 set treediropen($dir) 1
1344 set top [lindex [split [$w index @0,0] .] 0]
1345 set ht [$w cget -height]
1346 set l [lindex [split [$w index s:$ix] .] 0]
1347 if {$l < $top} {
1348 $w yview $l.0
1349 } elseif {$l + $n + 1 > $top + $ht} {
1350 set top [expr {$l + $n + 2 - $ht}]
1351 if {$l < $top} {
1352 set top $l
1354 $w yview $top.0
1358 proc treeclick {w x y} {
1359 global treediropen cmitmode ctext cflist cflist_top
1361 if {$cmitmode ne "tree"} return
1362 if {![info exists cflist_top]} return
1363 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1364 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1365 $cflist tag add highlight $l.0 "$l.0 lineend"
1366 set cflist_top $l
1367 if {$l == 1} {
1368 $ctext yview 1.0
1369 return
1371 set e [linetoelt $l]
1372 if {[string index $e end] ne "/"} {
1373 showfile $e
1374 } elseif {$treediropen($e)} {
1375 treeclosedir $w $e
1376 } else {
1377 treeopendir $w $e
1381 proc setfilelist {id} {
1382 global treefilelist cflist
1384 treeview $cflist $treefilelist($id) 0
1387 image create bitmap tri-rt -background black -foreground blue -data {
1388 #define tri-rt_width 13
1389 #define tri-rt_height 13
1390 static unsigned char tri-rt_bits[] = {
1391 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1392 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1393 0x00, 0x00};
1394 } -maskdata {
1395 #define tri-rt-mask_width 13
1396 #define tri-rt-mask_height 13
1397 static unsigned char tri-rt-mask_bits[] = {
1398 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1399 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1400 0x08, 0x00};
1402 image create bitmap tri-dn -background black -foreground blue -data {
1403 #define tri-dn_width 13
1404 #define tri-dn_height 13
1405 static unsigned char tri-dn_bits[] = {
1406 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1407 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1408 0x00, 0x00};
1409 } -maskdata {
1410 #define tri-dn-mask_width 13
1411 #define tri-dn-mask_height 13
1412 static unsigned char tri-dn-mask_bits[] = {
1413 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1414 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1415 0x00, 0x00};
1418 proc init_flist {first} {
1419 global cflist cflist_top selectedline difffilestart
1421 $cflist conf -state normal
1422 $cflist delete 0.0 end
1423 if {$first ne {}} {
1424 $cflist insert end $first
1425 set cflist_top 1
1426 $cflist tag add highlight 1.0 "1.0 lineend"
1427 } else {
1428 catch {unset cflist_top}
1430 $cflist conf -state disabled
1431 set difffilestart {}
1434 proc highlight_tag {f} {
1435 global highlight_paths
1437 foreach p $highlight_paths {
1438 if {[string match $p $f]} {
1439 return "bold"
1442 return {}
1445 proc highlight_filelist {} {
1446 global cmitmode cflist
1448 $cflist conf -state normal
1449 if {$cmitmode ne "tree"} {
1450 set end [lindex [split [$cflist index end] .] 0]
1451 for {set l 2} {$l < $end} {incr l} {
1452 set line [$cflist get $l.0 "$l.0 lineend"]
1453 if {[highlight_tag $line] ne {}} {
1454 $cflist tag add bold $l.0 "$l.0 lineend"
1457 } else {
1458 highlight_tree 2 {}
1460 $cflist conf -state disabled
1463 proc unhighlight_filelist {} {
1464 global cflist
1466 $cflist conf -state normal
1467 $cflist tag remove bold 1.0 end
1468 $cflist conf -state disabled
1471 proc add_flist {fl} {
1472 global cflist
1474 $cflist conf -state normal
1475 foreach f $fl {
1476 $cflist insert end "\n"
1477 $cflist insert end $f [highlight_tag $f]
1479 $cflist conf -state disabled
1482 proc sel_flist {w x y} {
1483 global ctext difffilestart cflist cflist_top cmitmode
1485 if {$cmitmode eq "tree"} return
1486 if {![info exists cflist_top]} return
1487 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1488 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1489 $cflist tag add highlight $l.0 "$l.0 lineend"
1490 set cflist_top $l
1491 if {$l == 1} {
1492 $ctext yview 1.0
1493 } else {
1494 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1498 # Functions for adding and removing shell-type quoting
1500 proc shellquote {str} {
1501 if {![string match "*\['\"\\ \t]*" $str]} {
1502 return $str
1504 if {![string match "*\['\"\\]*" $str]} {
1505 return "\"$str\""
1507 if {![string match "*'*" $str]} {
1508 return "'$str'"
1510 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1513 proc shellarglist {l} {
1514 set str {}
1515 foreach a $l {
1516 if {$str ne {}} {
1517 append str " "
1519 append str [shellquote $a]
1521 return $str
1524 proc shelldequote {str} {
1525 set ret {}
1526 set used -1
1527 while {1} {
1528 incr used
1529 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1530 append ret [string range $str $used end]
1531 set used [string length $str]
1532 break
1534 set first [lindex $first 0]
1535 set ch [string index $str $first]
1536 if {$first > $used} {
1537 append ret [string range $str $used [expr {$first - 1}]]
1538 set used $first
1540 if {$ch eq " " || $ch eq "\t"} break
1541 incr used
1542 if {$ch eq "'"} {
1543 set first [string first "'" $str $used]
1544 if {$first < 0} {
1545 error "unmatched single-quote"
1547 append ret [string range $str $used [expr {$first - 1}]]
1548 set used $first
1549 continue
1551 if {$ch eq "\\"} {
1552 if {$used >= [string length $str]} {
1553 error "trailing backslash"
1555 append ret [string index $str $used]
1556 continue
1558 # here ch == "\""
1559 while {1} {
1560 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1561 error "unmatched double-quote"
1563 set first [lindex $first 0]
1564 set ch [string index $str $first]
1565 if {$first > $used} {
1566 append ret [string range $str $used [expr {$first - 1}]]
1567 set used $first
1569 if {$ch eq "\""} break
1570 incr used
1571 append ret [string index $str $used]
1572 incr used
1575 return [list $used $ret]
1578 proc shellsplit {str} {
1579 set l {}
1580 while {1} {
1581 set str [string trimleft $str]
1582 if {$str eq {}} break
1583 set dq [shelldequote $str]
1584 set n [lindex $dq 0]
1585 set word [lindex $dq 1]
1586 set str [string range $str $n end]
1587 lappend l $word
1589 return $l
1592 # Code to implement multiple views
1594 proc newview {ishighlight} {
1595 global nextviewnum newviewname newviewperm uifont newishighlight
1596 global newviewargs revtreeargs
1598 set newishighlight $ishighlight
1599 set top .gitkview
1600 if {[winfo exists $top]} {
1601 raise $top
1602 return
1604 set newviewname($nextviewnum) "View $nextviewnum"
1605 set newviewperm($nextviewnum) 0
1606 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1607 vieweditor $top $nextviewnum "Gitk view definition"
1610 proc editview {} {
1611 global curview
1612 global viewname viewperm newviewname newviewperm
1613 global viewargs newviewargs
1615 set top .gitkvedit-$curview
1616 if {[winfo exists $top]} {
1617 raise $top
1618 return
1620 set newviewname($curview) $viewname($curview)
1621 set newviewperm($curview) $viewperm($curview)
1622 set newviewargs($curview) [shellarglist $viewargs($curview)]
1623 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1626 proc vieweditor {top n title} {
1627 global newviewname newviewperm viewfiles
1628 global uifont
1630 toplevel $top
1631 wm title $top $title
1632 label $top.nl -text "Name" -font $uifont
1633 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1634 grid $top.nl $top.name -sticky w -pady 5
1635 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1636 -font $uifont
1637 grid $top.perm - -pady 5 -sticky w
1638 message $top.al -aspect 1000 -font $uifont \
1639 -text "Commits to include (arguments to git rev-list):"
1640 grid $top.al - -sticky w -pady 5
1641 entry $top.args -width 50 -textvariable newviewargs($n) \
1642 -background white -font $uifont
1643 grid $top.args - -sticky ew -padx 5
1644 message $top.l -aspect 1000 -font $uifont \
1645 -text "Enter files and directories to include, one per line:"
1646 grid $top.l - -sticky w
1647 text $top.t -width 40 -height 10 -background white -font $uifont
1648 if {[info exists viewfiles($n)]} {
1649 foreach f $viewfiles($n) {
1650 $top.t insert end $f
1651 $top.t insert end "\n"
1653 $top.t delete {end - 1c} end
1654 $top.t mark set insert 0.0
1656 grid $top.t - -sticky ew -padx 5
1657 frame $top.buts
1658 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1659 -font $uifont
1660 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1661 -font $uifont
1662 grid $top.buts.ok $top.buts.can
1663 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1664 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1665 grid $top.buts - -pady 10 -sticky ew
1666 focus $top.t
1669 proc doviewmenu {m first cmd op argv} {
1670 set nmenu [$m index end]
1671 for {set i $first} {$i <= $nmenu} {incr i} {
1672 if {[$m entrycget $i -command] eq $cmd} {
1673 eval $m $op $i $argv
1674 break
1679 proc allviewmenus {n op args} {
1680 global viewhlmenu
1682 doviewmenu .bar.view 5 [list showview $n] $op $args
1683 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1686 proc newviewok {top n} {
1687 global nextviewnum newviewperm newviewname newishighlight
1688 global viewname viewfiles viewperm selectedview curview
1689 global viewargs newviewargs viewhlmenu
1691 if {[catch {
1692 set newargs [shellsplit $newviewargs($n)]
1693 } err]} {
1694 error_popup "Error in commit selection arguments: $err"
1695 wm raise $top
1696 focus $top
1697 return
1699 set files {}
1700 foreach f [split [$top.t get 0.0 end] "\n"] {
1701 set ft [string trim $f]
1702 if {$ft ne {}} {
1703 lappend files $ft
1706 if {![info exists viewfiles($n)]} {
1707 # creating a new view
1708 incr nextviewnum
1709 set viewname($n) $newviewname($n)
1710 set viewperm($n) $newviewperm($n)
1711 set viewfiles($n) $files
1712 set viewargs($n) $newargs
1713 addviewmenu $n
1714 if {!$newishighlight} {
1715 run showview $n
1716 } else {
1717 run addvhighlight $n
1719 } else {
1720 # editing an existing view
1721 set viewperm($n) $newviewperm($n)
1722 if {$newviewname($n) ne $viewname($n)} {
1723 set viewname($n) $newviewname($n)
1724 doviewmenu .bar.view 5 [list showview $n] \
1725 entryconf [list -label $viewname($n)]
1726 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1727 entryconf [list -label $viewname($n) -value $viewname($n)]
1729 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1730 set viewfiles($n) $files
1731 set viewargs($n) $newargs
1732 if {$curview == $n} {
1733 run updatecommits
1737 catch {destroy $top}
1740 proc delview {} {
1741 global curview viewdata viewperm hlview selectedhlview
1743 if {$curview == 0} return
1744 if {[info exists hlview] && $hlview == $curview} {
1745 set selectedhlview None
1746 unset hlview
1748 allviewmenus $curview delete
1749 set viewdata($curview) {}
1750 set viewperm($curview) 0
1751 showview 0
1754 proc addviewmenu {n} {
1755 global viewname viewhlmenu
1757 .bar.view add radiobutton -label $viewname($n) \
1758 -command [list showview $n] -variable selectedview -value $n
1759 $viewhlmenu add radiobutton -label $viewname($n) \
1760 -command [list addvhighlight $n] -variable selectedhlview
1763 proc flatten {var} {
1764 global $var
1766 set ret {}
1767 foreach i [array names $var] {
1768 lappend ret $i [set $var\($i\)]
1770 return $ret
1773 proc unflatten {var l} {
1774 global $var
1776 catch {unset $var}
1777 foreach {i v} $l {
1778 set $var\($i\) $v
1782 proc showview {n} {
1783 global curview viewdata viewfiles
1784 global displayorder parentlist rowidlist rowoffsets
1785 global colormap rowtextx commitrow nextcolor canvxmax
1786 global numcommits rowrangelist commitlisted idrowranges rowchk
1787 global selectedline currentid canv canvy0
1788 global treediffs
1789 global pending_select phase
1790 global commitidx rowlaidout rowoptim
1791 global commfd
1792 global selectedview selectfirst
1793 global vparentlist vdisporder vcmitlisted
1794 global hlview selectedhlview
1796 if {$n == $curview} return
1797 set selid {}
1798 if {[info exists selectedline]} {
1799 set selid $currentid
1800 set y [yc $selectedline]
1801 set ymax [lindex [$canv cget -scrollregion] 3]
1802 set span [$canv yview]
1803 set ytop [expr {[lindex $span 0] * $ymax}]
1804 set ybot [expr {[lindex $span 1] * $ymax}]
1805 if {$ytop < $y && $y < $ybot} {
1806 set yscreen [expr {$y - $ytop}]
1807 } else {
1808 set yscreen [expr {($ybot - $ytop) / 2}]
1810 } elseif {[info exists pending_select]} {
1811 set selid $pending_select
1812 unset pending_select
1814 unselectline
1815 normalline
1816 if {$curview >= 0} {
1817 set vparentlist($curview) $parentlist
1818 set vdisporder($curview) $displayorder
1819 set vcmitlisted($curview) $commitlisted
1820 if {$phase ne {}} {
1821 set viewdata($curview) \
1822 [list $phase $rowidlist $rowoffsets $rowrangelist \
1823 [flatten idrowranges] [flatten idinlist] \
1824 $rowlaidout $rowoptim $numcommits]
1825 } elseif {![info exists viewdata($curview)]
1826 || [lindex $viewdata($curview) 0] ne {}} {
1827 set viewdata($curview) \
1828 [list {} $rowidlist $rowoffsets $rowrangelist]
1831 catch {unset treediffs}
1832 clear_display
1833 if {[info exists hlview] && $hlview == $n} {
1834 unset hlview
1835 set selectedhlview None
1838 set curview $n
1839 set selectedview $n
1840 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1841 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1843 if {![info exists viewdata($n)]} {
1844 if {$selid ne {}} {
1845 set pending_select $selid
1847 getcommits
1848 return
1851 set v $viewdata($n)
1852 set phase [lindex $v 0]
1853 set displayorder $vdisporder($n)
1854 set parentlist $vparentlist($n)
1855 set commitlisted $vcmitlisted($n)
1856 set rowidlist [lindex $v 1]
1857 set rowoffsets [lindex $v 2]
1858 set rowrangelist [lindex $v 3]
1859 if {$phase eq {}} {
1860 set numcommits [llength $displayorder]
1861 catch {unset idrowranges}
1862 } else {
1863 unflatten idrowranges [lindex $v 4]
1864 unflatten idinlist [lindex $v 5]
1865 set rowlaidout [lindex $v 6]
1866 set rowoptim [lindex $v 7]
1867 set numcommits [lindex $v 8]
1868 catch {unset rowchk}
1871 catch {unset colormap}
1872 catch {unset rowtextx}
1873 set nextcolor 0
1874 set canvxmax [$canv cget -width]
1875 set curview $n
1876 set row 0
1877 setcanvscroll
1878 set yf 0
1879 set row {}
1880 set selectfirst 0
1881 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1882 set row $commitrow($n,$selid)
1883 # try to get the selected row in the same position on the screen
1884 set ymax [lindex [$canv cget -scrollregion] 3]
1885 set ytop [expr {[yc $row] - $yscreen}]
1886 if {$ytop < 0} {
1887 set ytop 0
1889 set yf [expr {$ytop * 1.0 / $ymax}]
1891 allcanvs yview moveto $yf
1892 drawvisible
1893 if {$row ne {}} {
1894 selectline $row 0
1895 } elseif {$selid ne {}} {
1896 set pending_select $selid
1897 } else {
1898 set row [first_real_row]
1899 if {$row < $numcommits} {
1900 selectline $row 0
1901 } else {
1902 set selectfirst 1
1905 if {$phase ne {}} {
1906 if {$phase eq "getcommits"} {
1907 show_status "Reading commits..."
1909 run chewcommits $n
1910 } elseif {$numcommits == 0} {
1911 show_status "No commits selected"
1915 # Stuff relating to the highlighting facility
1917 proc ishighlighted {row} {
1918 global vhighlights fhighlights nhighlights rhighlights
1920 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1921 return $nhighlights($row)
1923 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1924 return $vhighlights($row)
1926 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1927 return $fhighlights($row)
1929 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1930 return $rhighlights($row)
1932 return 0
1935 proc bolden {row font} {
1936 global canv linehtag selectedline boldrows
1938 lappend boldrows $row
1939 $canv itemconf $linehtag($row) -font $font
1940 if {[info exists selectedline] && $row == $selectedline} {
1941 $canv delete secsel
1942 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1943 -outline {{}} -tags secsel \
1944 -fill [$canv cget -selectbackground]]
1945 $canv lower $t
1949 proc bolden_name {row font} {
1950 global canv2 linentag selectedline boldnamerows
1952 lappend boldnamerows $row
1953 $canv2 itemconf $linentag($row) -font $font
1954 if {[info exists selectedline] && $row == $selectedline} {
1955 $canv2 delete secsel
1956 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1957 -outline {{}} -tags secsel \
1958 -fill [$canv2 cget -selectbackground]]
1959 $canv2 lower $t
1963 proc unbolden {} {
1964 global mainfont boldrows
1966 set stillbold {}
1967 foreach row $boldrows {
1968 if {![ishighlighted $row]} {
1969 bolden $row $mainfont
1970 } else {
1971 lappend stillbold $row
1974 set boldrows $stillbold
1977 proc addvhighlight {n} {
1978 global hlview curview viewdata vhl_done vhighlights commitidx
1980 if {[info exists hlview]} {
1981 delvhighlight
1983 set hlview $n
1984 if {$n != $curview && ![info exists viewdata($n)]} {
1985 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1986 set vparentlist($n) {}
1987 set vdisporder($n) {}
1988 set vcmitlisted($n) {}
1989 start_rev_list $n
1991 set vhl_done $commitidx($hlview)
1992 if {$vhl_done > 0} {
1993 drawvisible
1997 proc delvhighlight {} {
1998 global hlview vhighlights
2000 if {![info exists hlview]} return
2001 unset hlview
2002 catch {unset vhighlights}
2003 unbolden
2006 proc vhighlightmore {} {
2007 global hlview vhl_done commitidx vhighlights
2008 global displayorder vdisporder curview mainfont
2010 set font [concat $mainfont bold]
2011 set max $commitidx($hlview)
2012 if {$hlview == $curview} {
2013 set disp $displayorder
2014 } else {
2015 set disp $vdisporder($hlview)
2017 set vr [visiblerows]
2018 set r0 [lindex $vr 0]
2019 set r1 [lindex $vr 1]
2020 for {set i $vhl_done} {$i < $max} {incr i} {
2021 set id [lindex $disp $i]
2022 if {[info exists commitrow($curview,$id)]} {
2023 set row $commitrow($curview,$id)
2024 if {$r0 <= $row && $row <= $r1} {
2025 if {![highlighted $row]} {
2026 bolden $row $font
2028 set vhighlights($row) 1
2032 set vhl_done $max
2035 proc askvhighlight {row id} {
2036 global hlview vhighlights commitrow iddrawn mainfont
2038 if {[info exists commitrow($hlview,$id)]} {
2039 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2040 bolden $row [concat $mainfont bold]
2042 set vhighlights($row) 1
2043 } else {
2044 set vhighlights($row) 0
2048 proc hfiles_change {name ix op} {
2049 global highlight_files filehighlight fhighlights fh_serial
2050 global mainfont highlight_paths
2052 if {[info exists filehighlight]} {
2053 # delete previous highlights
2054 catch {close $filehighlight}
2055 unset filehighlight
2056 catch {unset fhighlights}
2057 unbolden
2058 unhighlight_filelist
2060 set highlight_paths {}
2061 after cancel do_file_hl $fh_serial
2062 incr fh_serial
2063 if {$highlight_files ne {}} {
2064 after 300 do_file_hl $fh_serial
2068 proc makepatterns {l} {
2069 set ret {}
2070 foreach e $l {
2071 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2072 if {[string index $ee end] eq "/"} {
2073 lappend ret "$ee*"
2074 } else {
2075 lappend ret $ee
2076 lappend ret "$ee/*"
2079 return $ret
2082 proc do_file_hl {serial} {
2083 global highlight_files filehighlight highlight_paths gdttype fhl_list
2085 if {$gdttype eq "touching paths:"} {
2086 if {[catch {set paths [shellsplit $highlight_files]}]} return
2087 set highlight_paths [makepatterns $paths]
2088 highlight_filelist
2089 set gdtargs [concat -- $paths]
2090 } else {
2091 set gdtargs [list "-S$highlight_files"]
2093 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2094 set filehighlight [open $cmd r+]
2095 fconfigure $filehighlight -blocking 0
2096 filerun $filehighlight readfhighlight
2097 set fhl_list {}
2098 drawvisible
2099 flushhighlights
2102 proc flushhighlights {} {
2103 global filehighlight fhl_list
2105 if {[info exists filehighlight]} {
2106 lappend fhl_list {}
2107 puts $filehighlight ""
2108 flush $filehighlight
2112 proc askfilehighlight {row id} {
2113 global filehighlight fhighlights fhl_list
2115 lappend fhl_list $id
2116 set fhighlights($row) -1
2117 puts $filehighlight $id
2120 proc readfhighlight {} {
2121 global filehighlight fhighlights commitrow curview mainfont iddrawn
2122 global fhl_list
2124 if {![info exists filehighlight]} {
2125 return 0
2127 set nr 0
2128 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2129 set line [string trim $line]
2130 set i [lsearch -exact $fhl_list $line]
2131 if {$i < 0} continue
2132 for {set j 0} {$j < $i} {incr j} {
2133 set id [lindex $fhl_list $j]
2134 if {[info exists commitrow($curview,$id)]} {
2135 set fhighlights($commitrow($curview,$id)) 0
2138 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2139 if {$line eq {}} continue
2140 if {![info exists commitrow($curview,$line)]} continue
2141 set row $commitrow($curview,$line)
2142 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2143 bolden $row [concat $mainfont bold]
2145 set fhighlights($row) 1
2147 if {[eof $filehighlight]} {
2148 # strange...
2149 puts "oops, git diff-tree died"
2150 catch {close $filehighlight}
2151 unset filehighlight
2152 return 0
2154 next_hlcont
2155 return 1
2158 proc find_change {name ix op} {
2159 global nhighlights mainfont boldnamerows
2160 global findstring findpattern findtype markingmatches
2162 # delete previous highlights, if any
2163 foreach row $boldnamerows {
2164 bolden_name $row $mainfont
2166 set boldnamerows {}
2167 catch {unset nhighlights}
2168 unbolden
2169 unmarkmatches
2170 if {$findtype ne "Regexp"} {
2171 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2172 $findstring]
2173 set findpattern "*$e*"
2175 set markingmatches [expr {$findstring ne {}}]
2176 drawvisible
2179 proc doesmatch {f} {
2180 global findtype findstring findpattern
2182 if {$findtype eq "Regexp"} {
2183 return [regexp $findstring $f]
2184 } elseif {$findtype eq "IgnCase"} {
2185 return [string match -nocase $findpattern $f]
2186 } else {
2187 return [string match $findpattern $f]
2191 proc askfindhighlight {row id} {
2192 global nhighlights commitinfo iddrawn mainfont
2193 global findloc
2194 global markingmatches
2196 if {![info exists commitinfo($id)]} {
2197 getcommit $id
2199 set info $commitinfo($id)
2200 set isbold 0
2201 set fldtypes {Headline Author Date Committer CDate Comments}
2202 foreach f $info ty $fldtypes {
2203 if {($findloc eq "All fields" || $findloc eq $ty) &&
2204 [doesmatch $f]} {
2205 if {$ty eq "Author"} {
2206 set isbold 2
2207 break
2209 set isbold 1
2212 if {$isbold && [info exists iddrawn($id)]} {
2213 set f [concat $mainfont bold]
2214 if {![ishighlighted $row]} {
2215 bolden $row $f
2216 if {$isbold > 1} {
2217 bolden_name $row $f
2220 if {$markingmatches} {
2221 markrowmatches $row [lindex $info 0] [lindex $info 1]
2224 set nhighlights($row) $isbold
2227 proc markrowmatches {row headline author} {
2228 global canv canv2 linehtag linentag
2230 $canv delete match$row
2231 $canv2 delete match$row
2232 set m [findmatches $headline]
2233 if {$m ne {}} {
2234 markmatches $canv $row $headline $linehtag($row) $m \
2235 [$canv itemcget $linehtag($row) -font]
2237 set m [findmatches $author]
2238 if {$m ne {}} {
2239 markmatches $canv2 $row $author $linentag($row) $m \
2240 [$canv2 itemcget $linentag($row) -font]
2244 proc vrel_change {name ix op} {
2245 global highlight_related
2247 rhighlight_none
2248 if {$highlight_related ne "None"} {
2249 run drawvisible
2253 # prepare for testing whether commits are descendents or ancestors of a
2254 proc rhighlight_sel {a} {
2255 global descendent desc_todo ancestor anc_todo
2256 global highlight_related rhighlights
2258 catch {unset descendent}
2259 set desc_todo [list $a]
2260 catch {unset ancestor}
2261 set anc_todo [list $a]
2262 if {$highlight_related ne "None"} {
2263 rhighlight_none
2264 run drawvisible
2268 proc rhighlight_none {} {
2269 global rhighlights
2271 catch {unset rhighlights}
2272 unbolden
2275 proc is_descendent {a} {
2276 global curview children commitrow descendent desc_todo
2278 set v $curview
2279 set la $commitrow($v,$a)
2280 set todo $desc_todo
2281 set leftover {}
2282 set done 0
2283 for {set i 0} {$i < [llength $todo]} {incr i} {
2284 set do [lindex $todo $i]
2285 if {$commitrow($v,$do) < $la} {
2286 lappend leftover $do
2287 continue
2289 foreach nk $children($v,$do) {
2290 if {![info exists descendent($nk)]} {
2291 set descendent($nk) 1
2292 lappend todo $nk
2293 if {$nk eq $a} {
2294 set done 1
2298 if {$done} {
2299 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2300 return
2303 set descendent($a) 0
2304 set desc_todo $leftover
2307 proc is_ancestor {a} {
2308 global curview parentlist commitrow ancestor anc_todo
2310 set v $curview
2311 set la $commitrow($v,$a)
2312 set todo $anc_todo
2313 set leftover {}
2314 set done 0
2315 for {set i 0} {$i < [llength $todo]} {incr i} {
2316 set do [lindex $todo $i]
2317 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2318 lappend leftover $do
2319 continue
2321 foreach np [lindex $parentlist $commitrow($v,$do)] {
2322 if {![info exists ancestor($np)]} {
2323 set ancestor($np) 1
2324 lappend todo $np
2325 if {$np eq $a} {
2326 set done 1
2330 if {$done} {
2331 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2332 return
2335 set ancestor($a) 0
2336 set anc_todo $leftover
2339 proc askrelhighlight {row id} {
2340 global descendent highlight_related iddrawn mainfont rhighlights
2341 global selectedline ancestor
2343 if {![info exists selectedline]} return
2344 set isbold 0
2345 if {$highlight_related eq "Descendent" ||
2346 $highlight_related eq "Not descendent"} {
2347 if {![info exists descendent($id)]} {
2348 is_descendent $id
2350 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2351 set isbold 1
2353 } elseif {$highlight_related eq "Ancestor" ||
2354 $highlight_related eq "Not ancestor"} {
2355 if {![info exists ancestor($id)]} {
2356 is_ancestor $id
2358 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2359 set isbold 1
2362 if {[info exists iddrawn($id)]} {
2363 if {$isbold && ![ishighlighted $row]} {
2364 bolden $row [concat $mainfont bold]
2367 set rhighlights($row) $isbold
2370 proc next_hlcont {} {
2371 global fhl_row fhl_dirn displayorder numcommits
2372 global vhighlights fhighlights nhighlights rhighlights
2373 global hlview filehighlight findstring highlight_related
2375 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2376 set row $fhl_row
2377 while {1} {
2378 if {$row < 0 || $row >= $numcommits} {
2379 bell
2380 set fhl_dirn 0
2381 return
2383 set id [lindex $displayorder $row]
2384 if {[info exists hlview]} {
2385 if {![info exists vhighlights($row)]} {
2386 askvhighlight $row $id
2388 if {$vhighlights($row) > 0} break
2390 if {$findstring ne {}} {
2391 if {![info exists nhighlights($row)]} {
2392 askfindhighlight $row $id
2394 if {$nhighlights($row) > 0} break
2396 if {$highlight_related ne "None"} {
2397 if {![info exists rhighlights($row)]} {
2398 askrelhighlight $row $id
2400 if {$rhighlights($row) > 0} break
2402 if {[info exists filehighlight]} {
2403 if {![info exists fhighlights($row)]} {
2404 # ask for a few more while we're at it...
2405 set r $row
2406 for {set n 0} {$n < 100} {incr n} {
2407 if {![info exists fhighlights($r)]} {
2408 askfilehighlight $r [lindex $displayorder $r]
2410 incr r $fhl_dirn
2411 if {$r < 0 || $r >= $numcommits} break
2413 flushhighlights
2415 if {$fhighlights($row) < 0} {
2416 set fhl_row $row
2417 return
2419 if {$fhighlights($row) > 0} break
2421 incr row $fhl_dirn
2423 set fhl_dirn 0
2424 selectline $row 1
2427 proc next_highlight {dirn} {
2428 global selectedline fhl_row fhl_dirn
2429 global hlview filehighlight findstring highlight_related
2431 if {![info exists selectedline]} return
2432 if {!([info exists hlview] || $findstring ne {} ||
2433 $highlight_related ne "None" || [info exists filehighlight])} return
2434 set fhl_row [expr {$selectedline + $dirn}]
2435 set fhl_dirn $dirn
2436 next_hlcont
2439 proc cancel_next_highlight {} {
2440 global fhl_dirn
2442 set fhl_dirn 0
2445 # Graph layout functions
2447 proc shortids {ids} {
2448 set res {}
2449 foreach id $ids {
2450 if {[llength $id] > 1} {
2451 lappend res [shortids $id]
2452 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2453 lappend res [string range $id 0 7]
2454 } else {
2455 lappend res $id
2458 return $res
2461 proc incrange {l x o} {
2462 set n [llength $l]
2463 while {$x < $n} {
2464 set e [lindex $l $x]
2465 if {$e ne {}} {
2466 lset l $x [expr {$e + $o}]
2468 incr x
2470 return $l
2473 proc ntimes {n o} {
2474 set ret {}
2475 for {} {$n > 0} {incr n -1} {
2476 lappend ret $o
2478 return $ret
2481 proc usedinrange {id l1 l2} {
2482 global children commitrow curview
2484 if {[info exists commitrow($curview,$id)]} {
2485 set r $commitrow($curview,$id)
2486 if {$l1 <= $r && $r <= $l2} {
2487 return [expr {$r - $l1 + 1}]
2490 set kids $children($curview,$id)
2491 foreach c $kids {
2492 set r $commitrow($curview,$c)
2493 if {$l1 <= $r && $r <= $l2} {
2494 return [expr {$r - $l1 + 1}]
2497 return 0
2500 proc sanity {row {full 0}} {
2501 global rowidlist rowoffsets
2503 set col -1
2504 set ids [lindex $rowidlist $row]
2505 foreach id $ids {
2506 incr col
2507 if {$id eq {}} continue
2508 if {$col < [llength $ids] - 1 &&
2509 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2510 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2512 set o [lindex $rowoffsets $row $col]
2513 set y $row
2514 set x $col
2515 while {$o ne {}} {
2516 incr y -1
2517 incr x $o
2518 if {[lindex $rowidlist $y $x] != $id} {
2519 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2520 puts " id=[shortids $id] check started at row $row"
2521 for {set i $row} {$i >= $y} {incr i -1} {
2522 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2524 break
2526 if {!$full} break
2527 set o [lindex $rowoffsets $y $x]
2532 proc makeuparrow {oid x y z} {
2533 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2535 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2536 incr y -1
2537 incr x $z
2538 set off0 [lindex $rowoffsets $y]
2539 for {set x0 $x} {1} {incr x0} {
2540 if {$x0 >= [llength $off0]} {
2541 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2542 break
2544 set z [lindex $off0 $x0]
2545 if {$z ne {}} {
2546 incr x0 $z
2547 break
2550 set z [expr {$x0 - $x}]
2551 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2552 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2554 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2555 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2556 lappend idrowranges($oid) [lindex $displayorder $y]
2559 proc initlayout {} {
2560 global rowidlist rowoffsets displayorder commitlisted
2561 global rowlaidout rowoptim
2562 global idinlist rowchk rowrangelist idrowranges
2563 global numcommits canvxmax canv
2564 global nextcolor
2565 global parentlist
2566 global colormap rowtextx
2567 global selectfirst
2569 set numcommits 0
2570 set displayorder {}
2571 set commitlisted {}
2572 set parentlist {}
2573 set rowrangelist {}
2574 set nextcolor 0
2575 set rowidlist {{}}
2576 set rowoffsets {{}}
2577 catch {unset idinlist}
2578 catch {unset rowchk}
2579 set rowlaidout 0
2580 set rowoptim 0
2581 set canvxmax [$canv cget -width]
2582 catch {unset colormap}
2583 catch {unset rowtextx}
2584 catch {unset idrowranges}
2585 set selectfirst 1
2588 proc setcanvscroll {} {
2589 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2591 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2592 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2593 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2594 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2597 proc visiblerows {} {
2598 global canv numcommits linespc
2600 set ymax [lindex [$canv cget -scrollregion] 3]
2601 if {$ymax eq {} || $ymax == 0} return
2602 set f [$canv yview]
2603 set y0 [expr {int([lindex $f 0] * $ymax)}]
2604 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2605 if {$r0 < 0} {
2606 set r0 0
2608 set y1 [expr {int([lindex $f 1] * $ymax)}]
2609 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2610 if {$r1 >= $numcommits} {
2611 set r1 [expr {$numcommits - 1}]
2613 return [list $r0 $r1]
2616 proc layoutmore {tmax allread} {
2617 global rowlaidout rowoptim commitidx numcommits optim_delay
2618 global uparrowlen curview rowidlist idinlist
2620 set showlast 0
2621 set showdelay $optim_delay
2622 set optdelay [expr {$uparrowlen + 1}]
2623 while {1} {
2624 if {$rowoptim - $showdelay > $numcommits} {
2625 showstuff [expr {$rowoptim - $showdelay}] $showlast
2626 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2627 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2628 if {$nr > 100} {
2629 set nr 100
2631 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2632 incr rowoptim $nr
2633 } elseif {$commitidx($curview) > $rowlaidout} {
2634 set nr [expr {$commitidx($curview) - $rowlaidout}]
2635 # may need to increase this threshold if uparrowlen or
2636 # mingaplen are increased...
2637 if {$nr > 150} {
2638 set nr 150
2640 set row $rowlaidout
2641 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2642 if {$rowlaidout == $row} {
2643 return 0
2645 } elseif {$allread} {
2646 set optdelay 0
2647 set nrows $commitidx($curview)
2648 if {[lindex $rowidlist $nrows] ne {} ||
2649 [array names idinlist] ne {}} {
2650 layouttail
2651 set rowlaidout $commitidx($curview)
2652 } elseif {$rowoptim == $nrows} {
2653 set showdelay 0
2654 set showlast 1
2655 if {$numcommits == $nrows} {
2656 return 0
2659 } else {
2660 return 0
2662 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2663 return 1
2668 proc showstuff {canshow last} {
2669 global numcommits commitrow pending_select selectedline curview
2670 global lookingforhead mainheadid displayorder selectfirst
2671 global lastscrollset
2673 if {$numcommits == 0} {
2674 global phase
2675 set phase "incrdraw"
2676 allcanvs delete all
2678 set r0 $numcommits
2679 set prev $numcommits
2680 set numcommits $canshow
2681 set t [clock clicks -milliseconds]
2682 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2683 set lastscrollset $t
2684 setcanvscroll
2686 set rows [visiblerows]
2687 set r1 [lindex $rows 1]
2688 if {$r1 >= $canshow} {
2689 set r1 [expr {$canshow - 1}]
2691 if {$r0 <= $r1} {
2692 drawcommits $r0 $r1
2694 if {[info exists pending_select] &&
2695 [info exists commitrow($curview,$pending_select)] &&
2696 $commitrow($curview,$pending_select) < $numcommits} {
2697 selectline $commitrow($curview,$pending_select) 1
2699 if {$selectfirst} {
2700 if {[info exists selectedline] || [info exists pending_select]} {
2701 set selectfirst 0
2702 } else {
2703 set l [first_real_row]
2704 selectline $l 1
2705 set selectfirst 0
2708 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2709 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2710 set lookingforhead 0
2711 dodiffindex
2715 proc doshowlocalchanges {} {
2716 global lookingforhead curview mainheadid phase commitrow
2718 if {[info exists commitrow($curview,$mainheadid)] &&
2719 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2720 dodiffindex
2721 } elseif {$phase ne {}} {
2722 set lookingforhead 1
2726 proc dohidelocalchanges {} {
2727 global lookingforhead localfrow localirow lserial
2729 set lookingforhead 0
2730 if {$localfrow >= 0} {
2731 removerow $localfrow
2732 set localfrow -1
2733 if {$localirow > 0} {
2734 incr localirow -1
2737 if {$localirow >= 0} {
2738 removerow $localirow
2739 set localirow -1
2741 incr lserial
2744 # spawn off a process to do git diff-index --cached HEAD
2745 proc dodiffindex {} {
2746 global localirow localfrow lserial
2748 incr lserial
2749 set localfrow -1
2750 set localirow -1
2751 set fd [open "|git diff-index --cached HEAD" r]
2752 fconfigure $fd -blocking 0
2753 filerun $fd [list readdiffindex $fd $lserial]
2756 proc readdiffindex {fd serial} {
2757 global localirow commitrow mainheadid nullid2 curview
2758 global commitinfo commitdata lserial
2760 set isdiff 1
2761 if {[gets $fd line] < 0} {
2762 if {![eof $fd]} {
2763 return 1
2765 set isdiff 0
2767 # we only need to see one line and we don't really care what it says...
2768 close $fd
2770 # now see if there are any local changes not checked in to the index
2771 if {$serial == $lserial} {
2772 set fd [open "|git diff-files" r]
2773 fconfigure $fd -blocking 0
2774 filerun $fd [list readdifffiles $fd $serial]
2777 if {$isdiff && $serial == $lserial && $localirow == -1} {
2778 # add the line for the changes in the index to the graph
2779 set localirow $commitrow($curview,$mainheadid)
2780 set hl "Local changes checked in to index but not committed"
2781 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2782 set commitdata($nullid2) "\n $hl\n"
2783 insertrow $localirow $nullid2
2785 return 0
2788 proc readdifffiles {fd serial} {
2789 global localirow localfrow commitrow mainheadid nullid curview
2790 global commitinfo commitdata lserial
2792 set isdiff 1
2793 if {[gets $fd line] < 0} {
2794 if {![eof $fd]} {
2795 return 1
2797 set isdiff 0
2799 # we only need to see one line and we don't really care what it says...
2800 close $fd
2802 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2803 # add the line for the local diff to the graph
2804 if {$localirow >= 0} {
2805 set localfrow $localirow
2806 incr localirow
2807 } else {
2808 set localfrow $commitrow($curview,$mainheadid)
2810 set hl "Local uncommitted changes, not checked in to index"
2811 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2812 set commitdata($nullid) "\n $hl\n"
2813 insertrow $localfrow $nullid
2815 return 0
2818 proc layoutrows {row endrow last} {
2819 global rowidlist rowoffsets displayorder
2820 global uparrowlen downarrowlen maxwidth mingaplen
2821 global children parentlist
2822 global idrowranges
2823 global commitidx curview
2824 global idinlist rowchk rowrangelist
2826 set idlist [lindex $rowidlist $row]
2827 set offs [lindex $rowoffsets $row]
2828 while {$row < $endrow} {
2829 set id [lindex $displayorder $row]
2830 set oldolds {}
2831 set newolds {}
2832 foreach p [lindex $parentlist $row] {
2833 if {![info exists idinlist($p)]} {
2834 lappend newolds $p
2835 } elseif {!$idinlist($p)} {
2836 lappend oldolds $p
2839 set nev [expr {[llength $idlist] + [llength $newolds]
2840 + [llength $oldolds] - $maxwidth + 1}]
2841 if {$nev > 0} {
2842 if {!$last &&
2843 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2844 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2845 set i [lindex $idlist $x]
2846 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2847 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2848 [expr {$row + $uparrowlen + $mingaplen}]]
2849 if {$r == 0} {
2850 set idlist [lreplace $idlist $x $x]
2851 set offs [lreplace $offs $x $x]
2852 set offs [incrange $offs $x 1]
2853 set idinlist($i) 0
2854 set rm1 [expr {$row - 1}]
2855 lappend idrowranges($i) [lindex $displayorder $rm1]
2856 if {[incr nev -1] <= 0} break
2857 continue
2859 set rowchk($id) [expr {$row + $r}]
2862 lset rowidlist $row $idlist
2863 lset rowoffsets $row $offs
2865 set col [lsearch -exact $idlist $id]
2866 if {$col < 0} {
2867 set col [llength $idlist]
2868 lappend idlist $id
2869 lset rowidlist $row $idlist
2870 set z {}
2871 if {$children($curview,$id) ne {}} {
2872 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2873 unset idinlist($id)
2875 lappend offs $z
2876 lset rowoffsets $row $offs
2877 if {$z ne {}} {
2878 makeuparrow $id $col $row $z
2880 } else {
2881 unset idinlist($id)
2883 set ranges {}
2884 if {[info exists idrowranges($id)]} {
2885 set ranges $idrowranges($id)
2886 lappend ranges $id
2887 unset idrowranges($id)
2889 lappend rowrangelist $ranges
2890 incr row
2891 set offs [ntimes [llength $idlist] 0]
2892 set l [llength $newolds]
2893 set idlist [eval lreplace \$idlist $col $col $newolds]
2894 set o 0
2895 if {$l != 1} {
2896 set offs [lrange $offs 0 [expr {$col - 1}]]
2897 foreach x $newolds {
2898 lappend offs {}
2899 incr o -1
2901 incr o
2902 set tmp [expr {[llength $idlist] - [llength $offs]}]
2903 if {$tmp > 0} {
2904 set offs [concat $offs [ntimes $tmp $o]]
2906 } else {
2907 lset offs $col {}
2909 foreach i $newolds {
2910 set idinlist($i) 1
2911 set idrowranges($i) $id
2913 incr col $l
2914 foreach oid $oldolds {
2915 set idinlist($oid) 1
2916 set idlist [linsert $idlist $col $oid]
2917 set offs [linsert $offs $col $o]
2918 makeuparrow $oid $col $row $o
2919 incr col
2921 lappend rowidlist $idlist
2922 lappend rowoffsets $offs
2924 return $row
2927 proc addextraid {id row} {
2928 global displayorder commitrow commitinfo
2929 global commitidx commitlisted
2930 global parentlist children curview
2932 incr commitidx($curview)
2933 lappend displayorder $id
2934 lappend commitlisted 0
2935 lappend parentlist {}
2936 set commitrow($curview,$id) $row
2937 readcommit $id
2938 if {![info exists commitinfo($id)]} {
2939 set commitinfo($id) {"No commit information available"}
2941 if {![info exists children($curview,$id)]} {
2942 set children($curview,$id) {}
2946 proc layouttail {} {
2947 global rowidlist rowoffsets idinlist commitidx curview
2948 global idrowranges rowrangelist
2950 set row $commitidx($curview)
2951 set idlist [lindex $rowidlist $row]
2952 while {$idlist ne {}} {
2953 set col [expr {[llength $idlist] - 1}]
2954 set id [lindex $idlist $col]
2955 addextraid $id $row
2956 unset idinlist($id)
2957 lappend idrowranges($id) $id
2958 lappend rowrangelist $idrowranges($id)
2959 unset idrowranges($id)
2960 incr row
2961 set offs [ntimes $col 0]
2962 set idlist [lreplace $idlist $col $col]
2963 lappend rowidlist $idlist
2964 lappend rowoffsets $offs
2967 foreach id [array names idinlist] {
2968 unset idinlist($id)
2969 addextraid $id $row
2970 lset rowidlist $row [list $id]
2971 lset rowoffsets $row 0
2972 makeuparrow $id 0 $row 0
2973 lappend idrowranges($id) $id
2974 lappend rowrangelist $idrowranges($id)
2975 unset idrowranges($id)
2976 incr row
2977 lappend rowidlist {}
2978 lappend rowoffsets {}
2982 proc insert_pad {row col npad} {
2983 global rowidlist rowoffsets
2985 set pad [ntimes $npad {}]
2986 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2987 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2988 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2991 proc optimize_rows {row col endrow} {
2992 global rowidlist rowoffsets displayorder
2994 for {} {$row < $endrow} {incr row} {
2995 set idlist [lindex $rowidlist $row]
2996 set offs [lindex $rowoffsets $row]
2997 set haspad 0
2998 for {} {$col < [llength $offs]} {incr col} {
2999 if {[lindex $idlist $col] eq {}} {
3000 set haspad 1
3001 continue
3003 set z [lindex $offs $col]
3004 if {$z eq {}} continue
3005 set isarrow 0
3006 set x0 [expr {$col + $z}]
3007 set y0 [expr {$row - 1}]
3008 set z0 [lindex $rowoffsets $y0 $x0]
3009 if {$z0 eq {}} {
3010 set id [lindex $idlist $col]
3011 set ranges [rowranges $id]
3012 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3013 set isarrow 1
3016 # Looking at lines from this row to the previous row,
3017 # make them go straight up if they end in an arrow on
3018 # the previous row; otherwise make them go straight up
3019 # or at 45 degrees.
3020 if {$z < -1 || ($z < 0 && $isarrow)} {
3021 # Line currently goes left too much;
3022 # insert pads in the previous row, then optimize it
3023 set npad [expr {-1 - $z + $isarrow}]
3024 set offs [incrange $offs $col $npad]
3025 insert_pad $y0 $x0 $npad
3026 if {$y0 > 0} {
3027 optimize_rows $y0 $x0 $row
3029 set z [lindex $offs $col]
3030 set x0 [expr {$col + $z}]
3031 set z0 [lindex $rowoffsets $y0 $x0]
3032 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3033 # Line currently goes right too much;
3034 # insert pads in this line and adjust the next's rowoffsets
3035 set npad [expr {$z - 1 + $isarrow}]
3036 set y1 [expr {$row + 1}]
3037 set offs2 [lindex $rowoffsets $y1]
3038 set x1 -1
3039 foreach z $offs2 {
3040 incr x1
3041 if {$z eq {} || $x1 + $z < $col} continue
3042 if {$x1 + $z > $col} {
3043 incr npad
3045 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3046 break
3048 set pad [ntimes $npad {}]
3049 set idlist [eval linsert \$idlist $col $pad]
3050 set tmp [eval linsert \$offs $col $pad]
3051 incr col $npad
3052 set offs [incrange $tmp $col [expr {-$npad}]]
3053 set z [lindex $offs $col]
3054 set haspad 1
3056 if {$z0 eq {} && !$isarrow} {
3057 # this line links to its first child on row $row-2
3058 set rm2 [expr {$row - 2}]
3059 set id [lindex $displayorder $rm2]
3060 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3061 if {$xc >= 0} {
3062 set z0 [expr {$xc - $x0}]
3065 # avoid lines jigging left then immediately right
3066 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3067 insert_pad $y0 $x0 1
3068 set offs [incrange $offs $col 1]
3069 optimize_rows $y0 [expr {$x0 + 1}] $row
3072 if {!$haspad} {
3073 set o {}
3074 # Find the first column that doesn't have a line going right
3075 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3076 set o [lindex $offs $col]
3077 if {$o eq {}} {
3078 # check if this is the link to the first child
3079 set id [lindex $idlist $col]
3080 set ranges [rowranges $id]
3081 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3082 # it is, work out offset to child
3083 set y0 [expr {$row - 1}]
3084 set id [lindex $displayorder $y0]
3085 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3086 if {$x0 >= 0} {
3087 set o [expr {$x0 - $col}]
3091 if {$o eq {} || $o <= 0} break
3093 # Insert a pad at that column as long as it has a line and
3094 # isn't the last column, and adjust the next row' offsets
3095 if {$o ne {} && [incr col] < [llength $idlist]} {
3096 set y1 [expr {$row + 1}]
3097 set offs2 [lindex $rowoffsets $y1]
3098 set x1 -1
3099 foreach z $offs2 {
3100 incr x1
3101 if {$z eq {} || $x1 + $z < $col} continue
3102 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3103 break
3105 set idlist [linsert $idlist $col {}]
3106 set tmp [linsert $offs $col {}]
3107 incr col
3108 set offs [incrange $tmp $col -1]
3111 lset rowidlist $row $idlist
3112 lset rowoffsets $row $offs
3113 set col 0
3117 proc xc {row col} {
3118 global canvx0 linespc
3119 return [expr {$canvx0 + $col * $linespc}]
3122 proc yc {row} {
3123 global canvy0 linespc
3124 return [expr {$canvy0 + $row * $linespc}]
3127 proc linewidth {id} {
3128 global thickerline lthickness
3130 set wid $lthickness
3131 if {[info exists thickerline] && $id eq $thickerline} {
3132 set wid [expr {2 * $lthickness}]
3134 return $wid
3137 proc rowranges {id} {
3138 global phase idrowranges commitrow rowlaidout rowrangelist curview
3140 set ranges {}
3141 if {$phase eq {} ||
3142 ([info exists commitrow($curview,$id)]
3143 && $commitrow($curview,$id) < $rowlaidout)} {
3144 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3145 } elseif {[info exists idrowranges($id)]} {
3146 set ranges $idrowranges($id)
3148 set linenos {}
3149 foreach rid $ranges {
3150 lappend linenos $commitrow($curview,$rid)
3152 if {$linenos ne {}} {
3153 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3155 return $linenos
3158 # work around tk8.4 refusal to draw arrows on diagonal segments
3159 proc adjarrowhigh {coords} {
3160 global linespc
3162 set x0 [lindex $coords 0]
3163 set x1 [lindex $coords 2]
3164 if {$x0 != $x1} {
3165 set y0 [lindex $coords 1]
3166 set y1 [lindex $coords 3]
3167 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3168 # we have a nearby vertical segment, just trim off the diag bit
3169 set coords [lrange $coords 2 end]
3170 } else {
3171 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3172 set xi [expr {$x0 - $slope * $linespc / 2}]
3173 set yi [expr {$y0 - $linespc / 2}]
3174 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3177 return $coords
3180 proc drawlineseg {id row endrow arrowlow} {
3181 global rowidlist displayorder iddrawn linesegs
3182 global canv colormap linespc curview maxlinelen
3184 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3185 set le [expr {$row + 1}]
3186 set arrowhigh 1
3187 while {1} {
3188 set c [lsearch -exact [lindex $rowidlist $le] $id]
3189 if {$c < 0} {
3190 incr le -1
3191 break
3193 lappend cols $c
3194 set x [lindex $displayorder $le]
3195 if {$x eq $id} {
3196 set arrowhigh 0
3197 break
3199 if {[info exists iddrawn($x)] || $le == $endrow} {
3200 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3201 if {$c >= 0} {
3202 lappend cols $c
3203 set arrowhigh 0
3205 break
3207 incr le
3209 if {$le <= $row} {
3210 return $row
3213 set lines {}
3214 set i 0
3215 set joinhigh 0
3216 if {[info exists linesegs($id)]} {
3217 set lines $linesegs($id)
3218 foreach li $lines {
3219 set r0 [lindex $li 0]
3220 if {$r0 > $row} {
3221 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3222 set joinhigh 1
3224 break
3226 incr i
3229 set joinlow 0
3230 if {$i > 0} {
3231 set li [lindex $lines [expr {$i-1}]]
3232 set r1 [lindex $li 1]
3233 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3234 set joinlow 1
3238 set x [lindex $cols [expr {$le - $row}]]
3239 set xp [lindex $cols [expr {$le - 1 - $row}]]
3240 set dir [expr {$xp - $x}]
3241 if {$joinhigh} {
3242 set ith [lindex $lines $i 2]
3243 set coords [$canv coords $ith]
3244 set ah [$canv itemcget $ith -arrow]
3245 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3246 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3247 if {$x2 ne {} && $x - $x2 == $dir} {
3248 set coords [lrange $coords 0 end-2]
3250 } else {
3251 set coords [list [xc $le $x] [yc $le]]
3253 if {$joinlow} {
3254 set itl [lindex $lines [expr {$i-1}] 2]
3255 set al [$canv itemcget $itl -arrow]
3256 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3257 } elseif {$arrowlow &&
3258 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3259 set arrowlow 0
3261 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3262 for {set y $le} {[incr y -1] > $row} {} {
3263 set x $xp
3264 set xp [lindex $cols [expr {$y - 1 - $row}]]
3265 set ndir [expr {$xp - $x}]
3266 if {$dir != $ndir || $xp < 0} {
3267 lappend coords [xc $y $x] [yc $y]
3269 set dir $ndir
3271 if {!$joinlow} {
3272 if {$xp < 0} {
3273 # join parent line to first child
3274 set ch [lindex $displayorder $row]
3275 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3276 if {$xc < 0} {
3277 puts "oops: drawlineseg: child $ch not on row $row"
3278 } else {
3279 if {$xc < $x - 1} {
3280 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3281 } elseif {$xc > $x + 1} {
3282 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3284 set x $xc
3286 lappend coords [xc $row $x] [yc $row]
3287 } else {
3288 set xn [xc $row $xp]
3289 set yn [yc $row]
3290 # work around tk8.4 refusal to draw arrows on diagonal segments
3291 if {$arrowlow && $xn != [lindex $coords end-1]} {
3292 if {[llength $coords] < 4 ||
3293 [lindex $coords end-3] != [lindex $coords end-1] ||
3294 [lindex $coords end] - $yn > 2 * $linespc} {
3295 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3296 set yo [yc [expr {$row + 0.5}]]
3297 lappend coords $xn $yo $xn $yn
3299 } else {
3300 lappend coords $xn $yn
3303 if {!$joinhigh} {
3304 if {$arrowhigh} {
3305 set coords [adjarrowhigh $coords]
3307 assigncolor $id
3308 set t [$canv create line $coords -width [linewidth $id] \
3309 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3310 $canv lower $t
3311 bindline $t $id
3312 set lines [linsert $lines $i [list $row $le $t]]
3313 } else {
3314 $canv coords $ith $coords
3315 if {$arrow ne $ah} {
3316 $canv itemconf $ith -arrow $arrow
3318 lset lines $i 0 $row
3320 } else {
3321 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3322 set ndir [expr {$xo - $xp}]
3323 set clow [$canv coords $itl]
3324 if {$dir == $ndir} {
3325 set clow [lrange $clow 2 end]
3327 set coords [concat $coords $clow]
3328 if {!$joinhigh} {
3329 lset lines [expr {$i-1}] 1 $le
3330 if {$arrowhigh} {
3331 set coords [adjarrowhigh $coords]
3333 } else {
3334 # coalesce two pieces
3335 $canv delete $ith
3336 set b [lindex $lines [expr {$i-1}] 0]
3337 set e [lindex $lines $i 1]
3338 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3340 $canv coords $itl $coords
3341 if {$arrow ne $al} {
3342 $canv itemconf $itl -arrow $arrow
3346 set linesegs($id) $lines
3347 return $le
3350 proc drawparentlinks {id row} {
3351 global rowidlist canv colormap curview parentlist
3352 global idpos
3354 set rowids [lindex $rowidlist $row]
3355 set col [lsearch -exact $rowids $id]
3356 if {$col < 0} return
3357 set olds [lindex $parentlist $row]
3358 set row2 [expr {$row + 1}]
3359 set x [xc $row $col]
3360 set y [yc $row]
3361 set y2 [yc $row2]
3362 set ids [lindex $rowidlist $row2]
3363 # rmx = right-most X coord used
3364 set rmx 0
3365 foreach p $olds {
3366 set i [lsearch -exact $ids $p]
3367 if {$i < 0} {
3368 puts "oops, parent $p of $id not in list"
3369 continue
3371 set x2 [xc $row2 $i]
3372 if {$x2 > $rmx} {
3373 set rmx $x2
3375 if {[lsearch -exact $rowids $p] < 0} {
3376 # drawlineseg will do this one for us
3377 continue
3379 assigncolor $p
3380 # should handle duplicated parents here...
3381 set coords [list $x $y]
3382 if {$i < $col - 1} {
3383 lappend coords [xc $row [expr {$i + 1}]] $y
3384 } elseif {$i > $col + 1} {
3385 lappend coords [xc $row [expr {$i - 1}]] $y
3387 lappend coords $x2 $y2
3388 set t [$canv create line $coords -width [linewidth $p] \
3389 -fill $colormap($p) -tags lines.$p]
3390 $canv lower $t
3391 bindline $t $p
3393 if {$rmx > [lindex $idpos($id) 1]} {
3394 lset idpos($id) 1 $rmx
3395 redrawtags $id
3399 proc drawlines {id} {
3400 global canv
3402 $canv itemconf lines.$id -width [linewidth $id]
3405 proc drawcmittext {id row col} {
3406 global linespc canv canv2 canv3 canvy0 fgcolor curview
3407 global commitlisted commitinfo rowidlist parentlist
3408 global rowtextx idpos idtags idheads idotherrefs
3409 global linehtag linentag linedtag markingmatches
3410 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3412 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3413 set listed [lindex $commitlisted $row]
3414 if {$id eq $nullid} {
3415 set ofill red
3416 } elseif {$id eq $nullid2} {
3417 set ofill green
3418 } else {
3419 set ofill [expr {$listed != 0? "blue": "white"}]
3421 set x [xc $row $col]
3422 set y [yc $row]
3423 set orad [expr {$linespc / 3}]
3424 if {$listed <= 1} {
3425 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3426 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3427 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3428 } elseif {$listed == 2} {
3429 # triangle pointing left for left-side commits
3430 set t [$canv create polygon \
3431 [expr {$x - $orad}] $y \
3432 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3433 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3434 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3435 } else {
3436 # triangle pointing right for right-side commits
3437 set t [$canv create polygon \
3438 [expr {$x + $orad - 1}] $y \
3439 [expr {$x - $orad}] [expr {$y - $orad}] \
3440 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3441 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3443 $canv raise $t
3444 $canv bind $t <1> {selcanvline {} %x %y}
3445 set rmx [llength [lindex $rowidlist $row]]
3446 set olds [lindex $parentlist $row]
3447 if {$olds ne {}} {
3448 set nextids [lindex $rowidlist [expr {$row + 1}]]
3449 foreach p $olds {
3450 set i [lsearch -exact $nextids $p]
3451 if {$i > $rmx} {
3452 set rmx $i
3456 set xt [xc $row $rmx]
3457 set rowtextx($row) $xt
3458 set idpos($id) [list $x $xt $y]
3459 if {[info exists idtags($id)] || [info exists idheads($id)]
3460 || [info exists idotherrefs($id)]} {
3461 set xt [drawtags $id $x $xt $y]
3463 set headline [lindex $commitinfo($id) 0]
3464 set name [lindex $commitinfo($id) 1]
3465 set date [lindex $commitinfo($id) 2]
3466 set date [formatdate $date]
3467 set font $mainfont
3468 set nfont $mainfont
3469 set isbold [ishighlighted $row]
3470 if {$isbold > 0} {
3471 lappend boldrows $row
3472 lappend font bold
3473 if {$isbold > 1} {
3474 lappend boldnamerows $row
3475 lappend nfont bold
3478 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3479 -text $headline -font $font -tags text]
3480 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3481 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3482 -text $name -font $nfont -tags text]
3483 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3484 -text $date -font $mainfont -tags text]
3485 set xr [expr {$xt + [font measure $mainfont $headline]}]
3486 if {$markingmatches} {
3487 markrowmatches $row $headline $name
3489 if {$xr > $canvxmax} {
3490 set canvxmax $xr
3491 setcanvscroll
3495 proc drawcmitrow {row} {
3496 global displayorder rowidlist
3497 global iddrawn
3498 global commitinfo parentlist numcommits
3499 global filehighlight fhighlights findstring nhighlights
3500 global hlview vhighlights
3501 global highlight_related rhighlights
3503 if {$row >= $numcommits} return
3505 set id [lindex $displayorder $row]
3506 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3507 askvhighlight $row $id
3509 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3510 askfilehighlight $row $id
3512 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3513 askfindhighlight $row $id
3515 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3516 askrelhighlight $row $id
3518 if {[info exists iddrawn($id)]} return
3519 set col [lsearch -exact [lindex $rowidlist $row] $id]
3520 if {$col < 0} {
3521 puts "oops, row $row id $id not in list"
3522 return
3524 if {![info exists commitinfo($id)]} {
3525 getcommit $id
3527 assigncolor $id
3528 drawcmittext $id $row $col
3529 set iddrawn($id) 1
3532 proc drawcommits {row {endrow {}}} {
3533 global numcommits iddrawn displayorder curview
3534 global parentlist rowidlist
3536 if {$row < 0} {
3537 set row 0
3539 if {$endrow eq {}} {
3540 set endrow $row
3542 if {$endrow >= $numcommits} {
3543 set endrow [expr {$numcommits - 1}]
3546 # make the lines join to already-drawn rows either side
3547 set r [expr {$row - 1}]
3548 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3549 set r $row
3551 set er [expr {$endrow + 1}]
3552 if {$er >= $numcommits ||
3553 ![info exists iddrawn([lindex $displayorder $er])]} {
3554 set er $endrow
3556 for {} {$r <= $er} {incr r} {
3557 set id [lindex $displayorder $r]
3558 set wasdrawn [info exists iddrawn($id)]
3559 drawcmitrow $r
3560 if {$r == $er} break
3561 set nextid [lindex $displayorder [expr {$r + 1}]]
3562 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3563 catch {unset prevlines}
3564 continue
3566 drawparentlinks $id $r
3568 if {[info exists lineends($r)]} {
3569 foreach lid $lineends($r) {
3570 unset prevlines($lid)
3573 set rowids [lindex $rowidlist $r]
3574 foreach lid $rowids {
3575 if {$lid eq {}} continue
3576 if {$lid eq $id} {
3577 # see if this is the first child of any of its parents
3578 foreach p [lindex $parentlist $r] {
3579 if {[lsearch -exact $rowids $p] < 0} {
3580 # make this line extend up to the child
3581 set le [drawlineseg $p $r $er 0]
3582 lappend lineends($le) $p
3583 set prevlines($p) 1
3586 } elseif {![info exists prevlines($lid)]} {
3587 set le [drawlineseg $lid $r $er 1]
3588 lappend lineends($le) $lid
3589 set prevlines($lid) 1
3595 proc drawfrac {f0 f1} {
3596 global canv linespc
3598 set ymax [lindex [$canv cget -scrollregion] 3]
3599 if {$ymax eq {} || $ymax == 0} return
3600 set y0 [expr {int($f0 * $ymax)}]
3601 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3602 set y1 [expr {int($f1 * $ymax)}]
3603 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3604 drawcommits $row $endrow
3607 proc drawvisible {} {
3608 global canv
3609 eval drawfrac [$canv yview]
3612 proc clear_display {} {
3613 global iddrawn linesegs
3614 global vhighlights fhighlights nhighlights rhighlights
3616 allcanvs delete all
3617 catch {unset iddrawn}
3618 catch {unset linesegs}
3619 catch {unset vhighlights}
3620 catch {unset fhighlights}
3621 catch {unset nhighlights}
3622 catch {unset rhighlights}
3625 proc findcrossings {id} {
3626 global rowidlist parentlist numcommits rowoffsets displayorder
3628 set cross {}
3629 set ccross {}
3630 foreach {s e} [rowranges $id] {
3631 if {$e >= $numcommits} {
3632 set e [expr {$numcommits - 1}]
3634 if {$e <= $s} continue
3635 set x [lsearch -exact [lindex $rowidlist $e] $id]
3636 if {$x < 0} {
3637 puts "findcrossings: oops, no [shortids $id] in row $e"
3638 continue
3640 for {set row $e} {[incr row -1] >= $s} {} {
3641 set olds [lindex $parentlist $row]
3642 set kid [lindex $displayorder $row]
3643 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3644 if {$kidx < 0} continue
3645 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3646 foreach p $olds {
3647 set px [lsearch -exact $nextrow $p]
3648 if {$px < 0} continue
3649 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3650 if {[lsearch -exact $ccross $p] >= 0} continue
3651 if {$x == $px + ($kidx < $px? -1: 1)} {
3652 lappend ccross $p
3653 } elseif {[lsearch -exact $cross $p] < 0} {
3654 lappend cross $p
3658 set inc [lindex $rowoffsets $row $x]
3659 if {$inc eq {}} break
3660 incr x $inc
3663 return [concat $ccross {{}} $cross]
3666 proc assigncolor {id} {
3667 global colormap colors nextcolor
3668 global commitrow parentlist children children curview
3670 if {[info exists colormap($id)]} return
3671 set ncolors [llength $colors]
3672 if {[info exists children($curview,$id)]} {
3673 set kids $children($curview,$id)
3674 } else {
3675 set kids {}
3677 if {[llength $kids] == 1} {
3678 set child [lindex $kids 0]
3679 if {[info exists colormap($child)]
3680 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3681 set colormap($id) $colormap($child)
3682 return
3685 set badcolors {}
3686 set origbad {}
3687 foreach x [findcrossings $id] {
3688 if {$x eq {}} {
3689 # delimiter between corner crossings and other crossings
3690 if {[llength $badcolors] >= $ncolors - 1} break
3691 set origbad $badcolors
3693 if {[info exists colormap($x)]
3694 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3695 lappend badcolors $colormap($x)
3698 if {[llength $badcolors] >= $ncolors} {
3699 set badcolors $origbad
3701 set origbad $badcolors
3702 if {[llength $badcolors] < $ncolors - 1} {
3703 foreach child $kids {
3704 if {[info exists colormap($child)]
3705 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3706 lappend badcolors $colormap($child)
3708 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3709 if {[info exists colormap($p)]
3710 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3711 lappend badcolors $colormap($p)
3715 if {[llength $badcolors] >= $ncolors} {
3716 set badcolors $origbad
3719 for {set i 0} {$i <= $ncolors} {incr i} {
3720 set c [lindex $colors $nextcolor]
3721 if {[incr nextcolor] >= $ncolors} {
3722 set nextcolor 0
3724 if {[lsearch -exact $badcolors $c]} break
3726 set colormap($id) $c
3729 proc bindline {t id} {
3730 global canv
3732 $canv bind $t <Enter> "lineenter %x %y $id"
3733 $canv bind $t <Motion> "linemotion %x %y $id"
3734 $canv bind $t <Leave> "lineleave $id"
3735 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3738 proc drawtags {id x xt y1} {
3739 global idtags idheads idotherrefs mainhead
3740 global linespc lthickness
3741 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3743 set marks {}
3744 set ntags 0
3745 set nheads 0
3746 if {[info exists idtags($id)]} {
3747 set marks $idtags($id)
3748 set ntags [llength $marks]
3750 if {[info exists idheads($id)]} {
3751 set marks [concat $marks $idheads($id)]
3752 set nheads [llength $idheads($id)]
3754 if {[info exists idotherrefs($id)]} {
3755 set marks [concat $marks $idotherrefs($id)]
3757 if {$marks eq {}} {
3758 return $xt
3761 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3762 set yt [expr {$y1 - 0.5 * $linespc}]
3763 set yb [expr {$yt + $linespc - 1}]
3764 set xvals {}
3765 set wvals {}
3766 set i -1
3767 foreach tag $marks {
3768 incr i
3769 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3770 set wid [font measure [concat $mainfont bold] $tag]
3771 } else {
3772 set wid [font measure $mainfont $tag]
3774 lappend xvals $xt
3775 lappend wvals $wid
3776 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3778 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3779 -width $lthickness -fill black -tags tag.$id]
3780 $canv lower $t
3781 foreach tag $marks x $xvals wid $wvals {
3782 set xl [expr {$x + $delta}]
3783 set xr [expr {$x + $delta + $wid + $lthickness}]
3784 set font $mainfont
3785 if {[incr ntags -1] >= 0} {
3786 # draw a tag
3787 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3788 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3789 -width 1 -outline black -fill yellow -tags tag.$id]
3790 $canv bind $t <1> [list showtag $tag 1]
3791 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3792 } else {
3793 # draw a head or other ref
3794 if {[incr nheads -1] >= 0} {
3795 set col green
3796 if {$tag eq $mainhead} {
3797 lappend font bold
3799 } else {
3800 set col "#ddddff"
3802 set xl [expr {$xl - $delta/2}]
3803 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3804 -width 1 -outline black -fill $col -tags tag.$id
3805 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3806 set rwid [font measure $mainfont $remoteprefix]
3807 set xi [expr {$x + 1}]
3808 set yti [expr {$yt + 1}]
3809 set xri [expr {$x + $rwid}]
3810 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3811 -width 0 -fill "#ffddaa" -tags tag.$id
3814 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3815 -font $font -tags [list tag.$id text]]
3816 if {$ntags >= 0} {
3817 $canv bind $t <1> [list showtag $tag 1]
3818 } elseif {$nheads >= 0} {
3819 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3822 return $xt
3825 proc xcoord {i level ln} {
3826 global canvx0 xspc1 xspc2
3828 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3829 if {$i > 0 && $i == $level} {
3830 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3831 } elseif {$i > $level} {
3832 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3834 return $x
3837 proc show_status {msg} {
3838 global canv mainfont fgcolor
3840 clear_display
3841 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3842 -tags text -fill $fgcolor
3845 # Insert a new commit as the child of the commit on row $row.
3846 # The new commit will be displayed on row $row and the commits
3847 # on that row and below will move down one row.
3848 proc insertrow {row newcmit} {
3849 global displayorder parentlist commitlisted children
3850 global commitrow curview rowidlist rowoffsets numcommits
3851 global rowrangelist rowlaidout rowoptim numcommits
3852 global selectedline rowchk commitidx
3854 if {$row >= $numcommits} {
3855 puts "oops, inserting new row $row but only have $numcommits rows"
3856 return
3858 set p [lindex $displayorder $row]
3859 set displayorder [linsert $displayorder $row $newcmit]
3860 set parentlist [linsert $parentlist $row $p]
3861 set kids $children($curview,$p)
3862 lappend kids $newcmit
3863 set children($curview,$p) $kids
3864 set children($curview,$newcmit) {}
3865 set commitlisted [linsert $commitlisted $row 1]
3866 set l [llength $displayorder]
3867 for {set r $row} {$r < $l} {incr r} {
3868 set id [lindex $displayorder $r]
3869 set commitrow($curview,$id) $r
3871 incr commitidx($curview)
3873 set idlist [lindex $rowidlist $row]
3874 set offs [lindex $rowoffsets $row]
3875 set newoffs {}
3876 foreach x $idlist {
3877 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3878 lappend newoffs {}
3879 } else {
3880 lappend newoffs 0
3883 if {[llength $kids] == 1} {
3884 set col [lsearch -exact $idlist $p]
3885 lset idlist $col $newcmit
3886 } else {
3887 set col [llength $idlist]
3888 lappend idlist $newcmit
3889 lappend offs {}
3890 lset rowoffsets $row $offs
3892 set rowidlist [linsert $rowidlist $row $idlist]
3893 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3895 set rowrangelist [linsert $rowrangelist $row {}]
3896 if {[llength $kids] > 1} {
3897 set rp1 [expr {$row + 1}]
3898 set ranges [lindex $rowrangelist $rp1]
3899 if {$ranges eq {}} {
3900 set ranges [list $newcmit $p]
3901 } elseif {[lindex $ranges end-1] eq $p} {
3902 lset ranges end-1 $newcmit
3904 lset rowrangelist $rp1 $ranges
3907 catch {unset rowchk}
3909 incr rowlaidout
3910 incr rowoptim
3911 incr numcommits
3913 if {[info exists selectedline] && $selectedline >= $row} {
3914 incr selectedline
3916 redisplay
3919 # Remove a commit that was inserted with insertrow on row $row.
3920 proc removerow {row} {
3921 global displayorder parentlist commitlisted children
3922 global commitrow curview rowidlist rowoffsets numcommits
3923 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3924 global linesegends selectedline rowchk commitidx
3926 if {$row >= $numcommits} {
3927 puts "oops, removing row $row but only have $numcommits rows"
3928 return
3930 set rp1 [expr {$row + 1}]
3931 set id [lindex $displayorder $row]
3932 set p [lindex $parentlist $row]
3933 set displayorder [lreplace $displayorder $row $row]
3934 set parentlist [lreplace $parentlist $row $row]
3935 set commitlisted [lreplace $commitlisted $row $row]
3936 set kids $children($curview,$p)
3937 set i [lsearch -exact $kids $id]
3938 if {$i >= 0} {
3939 set kids [lreplace $kids $i $i]
3940 set children($curview,$p) $kids
3942 set l [llength $displayorder]
3943 for {set r $row} {$r < $l} {incr r} {
3944 set id [lindex $displayorder $r]
3945 set commitrow($curview,$id) $r
3947 incr commitidx($curview) -1
3949 set rowidlist [lreplace $rowidlist $row $row]
3950 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3951 if {$kids ne {}} {
3952 set offs [lindex $rowoffsets $row]
3953 set offs [lreplace $offs end end]
3954 lset rowoffsets $row $offs
3957 set rowrangelist [lreplace $rowrangelist $row $row]
3958 if {[llength $kids] > 0} {
3959 set ranges [lindex $rowrangelist $row]
3960 if {[lindex $ranges end-1] eq $id} {
3961 set ranges [lreplace $ranges end-1 end]
3962 lset rowrangelist $row $ranges
3966 catch {unset rowchk}
3968 incr rowlaidout -1
3969 incr rowoptim -1
3970 incr numcommits -1
3972 if {[info exists selectedline] && $selectedline > $row} {
3973 incr selectedline -1
3975 redisplay
3978 # Don't change the text pane cursor if it is currently the hand cursor,
3979 # showing that we are over a sha1 ID link.
3980 proc settextcursor {c} {
3981 global ctext curtextcursor
3983 if {[$ctext cget -cursor] == $curtextcursor} {
3984 $ctext config -cursor $c
3986 set curtextcursor $c
3989 proc nowbusy {what} {
3990 global isbusy
3992 if {[array names isbusy] eq {}} {
3993 . config -cursor watch
3994 settextcursor watch
3996 set isbusy($what) 1
3999 proc notbusy {what} {
4000 global isbusy maincursor textcursor
4002 catch {unset isbusy($what)}
4003 if {[array names isbusy] eq {}} {
4004 . config -cursor $maincursor
4005 settextcursor $textcursor
4009 proc findmatches {f} {
4010 global findtype findstring
4011 if {$findtype == "Regexp"} {
4012 set matches [regexp -indices -all -inline $findstring $f]
4013 } else {
4014 set fs $findstring
4015 if {$findtype == "IgnCase"} {
4016 set f [string tolower $f]
4017 set fs [string tolower $fs]
4019 set matches {}
4020 set i 0
4021 set l [string length $fs]
4022 while {[set j [string first $fs $f $i]] >= 0} {
4023 lappend matches [list $j [expr {$j+$l-1}]]
4024 set i [expr {$j + $l}]
4027 return $matches
4030 proc dofind {{rev 0}} {
4031 global findstring findstartline findcurline selectedline numcommits
4033 unmarkmatches
4034 cancel_next_highlight
4035 focus .
4036 if {$findstring eq {} || $numcommits == 0} return
4037 if {![info exists selectedline]} {
4038 set findstartline [lindex [visiblerows] $rev]
4039 } else {
4040 set findstartline $selectedline
4042 set findcurline $findstartline
4043 nowbusy finding
4044 if {!$rev} {
4045 run findmore
4046 } else {
4047 set findcurline $findstartline
4048 if {$findcurline == 0} {
4049 set findcurline $numcommits
4051 incr findcurline -1
4052 run findmorerev
4056 proc findnext {restart} {
4057 global findcurline
4058 if {![info exists findcurline]} {
4059 if {$restart} {
4060 dofind
4061 } else {
4062 bell
4064 } else {
4065 run findmore
4066 nowbusy finding
4070 proc findprev {} {
4071 global findcurline
4072 if {![info exists findcurline]} {
4073 dofind 1
4074 } else {
4075 run findmorerev
4076 nowbusy finding
4080 proc findmore {} {
4081 global commitdata commitinfo numcommits findstring findpattern findloc
4082 global findstartline findcurline markingmatches displayorder
4084 set fldtypes {Headline Author Date Committer CDate Comments}
4085 set l [expr {$findcurline + 1}]
4086 if {$l >= $numcommits} {
4087 set l 0
4089 if {$l <= $findstartline} {
4090 set lim [expr {$findstartline + 1}]
4091 } else {
4092 set lim $numcommits
4094 if {$lim - $l > 500} {
4095 set lim [expr {$l + 500}]
4097 set last 0
4098 for {} {$l < $lim} {incr l} {
4099 set id [lindex $displayorder $l]
4100 if {![doesmatch $commitdata($id)]} continue
4101 if {![info exists commitinfo($id)]} {
4102 getcommit $id
4104 set info $commitinfo($id)
4105 foreach f $info ty $fldtypes {
4106 if {($findloc eq "All fields" || $findloc eq $ty) &&
4107 [doesmatch $f]} {
4108 set markingmatches 1
4109 findselectline $l
4110 notbusy finding
4111 return 0
4115 if {$l == $findstartline + 1} {
4116 bell
4117 unset findcurline
4118 notbusy finding
4119 return 0
4121 set findcurline [expr {$l - 1}]
4122 return 1
4125 proc findmorerev {} {
4126 global commitdata commitinfo numcommits findstring findpattern findloc
4127 global findstartline findcurline markingmatches displayorder
4129 set fldtypes {Headline Author Date Committer CDate Comments}
4130 set l $findcurline
4131 if {$l == 0} {
4132 set l $numcommits
4134 incr l -1
4135 if {$l >= $findstartline} {
4136 set lim [expr {$findstartline - 1}]
4137 } else {
4138 set lim -1
4140 if {$l - $lim > 500} {
4141 set lim [expr {$l - 500}]
4143 set last 0
4144 for {} {$l > $lim} {incr l -1} {
4145 set id [lindex $displayorder $l]
4146 if {![doesmatch $commitdata($id)]} continue
4147 if {![info exists commitinfo($id)]} {
4148 getcommit $id
4150 set info $commitinfo($id)
4151 foreach f $info ty $fldtypes {
4152 if {($findloc eq "All fields" || $findloc eq $ty) &&
4153 [doesmatch $f]} {
4154 set markingmatches 1
4155 findselectline $l
4156 notbusy finding
4157 return 0
4161 if {$l == -1} {
4162 bell
4163 unset findcurline
4164 notbusy finding
4165 return 0
4167 set findcurline [expr {$l + 1}]
4168 return 1
4171 proc findselectline {l} {
4172 global findloc commentend ctext
4173 selectline $l 1
4174 if {$findloc == "All fields" || $findloc == "Comments"} {
4175 # highlight the matches in the comments
4176 set f [$ctext get 1.0 $commentend]
4177 set matches [findmatches $f]
4178 foreach match $matches {
4179 set start [lindex $match 0]
4180 set end [expr {[lindex $match 1] + 1}]
4181 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4186 # mark the bits of a headline or author that match a find string
4187 proc markmatches {canv l str tag matches font} {
4188 set bbox [$canv bbox $tag]
4189 set x0 [lindex $bbox 0]
4190 set y0 [lindex $bbox 1]
4191 set y1 [lindex $bbox 3]
4192 foreach match $matches {
4193 set start [lindex $match 0]
4194 set end [lindex $match 1]
4195 if {$start > $end} continue
4196 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4197 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4198 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4199 [expr {$x0+$xlen+2}] $y1 \
4200 -outline {} -tags [list match$l matches] -fill yellow]
4201 $canv lower $t
4205 proc unmarkmatches {} {
4206 global findids markingmatches findcurline
4208 allcanvs delete matches
4209 catch {unset findids}
4210 set markingmatches 0
4211 catch {unset findcurline}
4214 proc selcanvline {w x y} {
4215 global canv canvy0 ctext linespc
4216 global rowtextx
4217 set ymax [lindex [$canv cget -scrollregion] 3]
4218 if {$ymax == {}} return
4219 set yfrac [lindex [$canv yview] 0]
4220 set y [expr {$y + $yfrac * $ymax}]
4221 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4222 if {$l < 0} {
4223 set l 0
4225 if {$w eq $canv} {
4226 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4228 unmarkmatches
4229 selectline $l 1
4232 proc commit_descriptor {p} {
4233 global commitinfo
4234 if {![info exists commitinfo($p)]} {
4235 getcommit $p
4237 set l "..."
4238 if {[llength $commitinfo($p)] > 1} {
4239 set l [lindex $commitinfo($p) 0]
4241 return "$p ($l)\n"
4244 # append some text to the ctext widget, and make any SHA1 ID
4245 # that we know about be a clickable link.
4246 proc appendwithlinks {text tags} {
4247 global ctext commitrow linknum curview
4249 set start [$ctext index "end - 1c"]
4250 $ctext insert end $text $tags
4251 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4252 foreach l $links {
4253 set s [lindex $l 0]
4254 set e [lindex $l 1]
4255 set linkid [string range $text $s $e]
4256 if {![info exists commitrow($curview,$linkid)]} continue
4257 incr e
4258 $ctext tag add link "$start + $s c" "$start + $e c"
4259 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4260 $ctext tag bind link$linknum <1> \
4261 [list selectline $commitrow($curview,$linkid) 1]
4262 incr linknum
4264 $ctext tag conf link -foreground blue -underline 1
4265 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4266 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4269 proc viewnextline {dir} {
4270 global canv linespc
4272 $canv delete hover
4273 set ymax [lindex [$canv cget -scrollregion] 3]
4274 set wnow [$canv yview]
4275 set wtop [expr {[lindex $wnow 0] * $ymax}]
4276 set newtop [expr {$wtop + $dir * $linespc}]
4277 if {$newtop < 0} {
4278 set newtop 0
4279 } elseif {$newtop > $ymax} {
4280 set newtop $ymax
4282 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4285 # add a list of tag or branch names at position pos
4286 # returns the number of names inserted
4287 proc appendrefs {pos ids var} {
4288 global ctext commitrow linknum curview $var maxrefs
4290 if {[catch {$ctext index $pos}]} {
4291 return 0
4293 $ctext conf -state normal
4294 $ctext delete $pos "$pos lineend"
4295 set tags {}
4296 foreach id $ids {
4297 foreach tag [set $var\($id\)] {
4298 lappend tags [list $tag $id]
4301 if {[llength $tags] > $maxrefs} {
4302 $ctext insert $pos "many ([llength $tags])"
4303 } else {
4304 set tags [lsort -index 0 -decreasing $tags]
4305 set sep {}
4306 foreach ti $tags {
4307 set id [lindex $ti 1]
4308 set lk link$linknum
4309 incr linknum
4310 $ctext tag delete $lk
4311 $ctext insert $pos $sep
4312 $ctext insert $pos [lindex $ti 0] $lk
4313 if {[info exists commitrow($curview,$id)]} {
4314 $ctext tag conf $lk -foreground blue
4315 $ctext tag bind $lk <1> \
4316 [list selectline $commitrow($curview,$id) 1]
4317 $ctext tag conf $lk -underline 1
4318 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4319 $ctext tag bind $lk <Leave> \
4320 { %W configure -cursor $curtextcursor }
4322 set sep ", "
4325 $ctext conf -state disabled
4326 return [llength $tags]
4329 # called when we have finished computing the nearby tags
4330 proc dispneartags {delay} {
4331 global selectedline currentid showneartags tagphase
4333 if {![info exists selectedline] || !$showneartags} return
4334 after cancel dispnexttag
4335 if {$delay} {
4336 after 200 dispnexttag
4337 set tagphase -1
4338 } else {
4339 after idle dispnexttag
4340 set tagphase 0
4344 proc dispnexttag {} {
4345 global selectedline currentid showneartags tagphase ctext
4347 if {![info exists selectedline] || !$showneartags} return
4348 switch -- $tagphase {
4350 set dtags [desctags $currentid]
4351 if {$dtags ne {}} {
4352 appendrefs precedes $dtags idtags
4356 set atags [anctags $currentid]
4357 if {$atags ne {}} {
4358 appendrefs follows $atags idtags
4362 set dheads [descheads $currentid]
4363 if {$dheads ne {}} {
4364 if {[appendrefs branch $dheads idheads] > 1
4365 && [$ctext get "branch -3c"] eq "h"} {
4366 # turn "Branch" into "Branches"
4367 $ctext conf -state normal
4368 $ctext insert "branch -2c" "es"
4369 $ctext conf -state disabled
4374 if {[incr tagphase] <= 2} {
4375 after idle dispnexttag
4379 proc selectline {l isnew} {
4380 global canv canv2 canv3 ctext commitinfo selectedline
4381 global displayorder linehtag linentag linedtag
4382 global canvy0 linespc parentlist children curview
4383 global currentid sha1entry
4384 global commentend idtags linknum
4385 global mergemax numcommits pending_select
4386 global cmitmode showneartags allcommits
4388 catch {unset pending_select}
4389 $canv delete hover
4390 normalline
4391 cancel_next_highlight
4392 if {$l < 0 || $l >= $numcommits} return
4393 set y [expr {$canvy0 + $l * $linespc}]
4394 set ymax [lindex [$canv cget -scrollregion] 3]
4395 set ytop [expr {$y - $linespc - 1}]
4396 set ybot [expr {$y + $linespc + 1}]
4397 set wnow [$canv yview]
4398 set wtop [expr {[lindex $wnow 0] * $ymax}]
4399 set wbot [expr {[lindex $wnow 1] * $ymax}]
4400 set wh [expr {$wbot - $wtop}]
4401 set newtop $wtop
4402 if {$ytop < $wtop} {
4403 if {$ybot < $wtop} {
4404 set newtop [expr {$y - $wh / 2.0}]
4405 } else {
4406 set newtop $ytop
4407 if {$newtop > $wtop - $linespc} {
4408 set newtop [expr {$wtop - $linespc}]
4411 } elseif {$ybot > $wbot} {
4412 if {$ytop > $wbot} {
4413 set newtop [expr {$y - $wh / 2.0}]
4414 } else {
4415 set newtop [expr {$ybot - $wh}]
4416 if {$newtop < $wtop + $linespc} {
4417 set newtop [expr {$wtop + $linespc}]
4421 if {$newtop != $wtop} {
4422 if {$newtop < 0} {
4423 set newtop 0
4425 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4426 drawvisible
4429 if {![info exists linehtag($l)]} return
4430 $canv delete secsel
4431 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4432 -tags secsel -fill [$canv cget -selectbackground]]
4433 $canv lower $t
4434 $canv2 delete secsel
4435 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4436 -tags secsel -fill [$canv2 cget -selectbackground]]
4437 $canv2 lower $t
4438 $canv3 delete secsel
4439 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4440 -tags secsel -fill [$canv3 cget -selectbackground]]
4441 $canv3 lower $t
4443 if {$isnew} {
4444 addtohistory [list selectline $l 0]
4447 set selectedline $l
4449 set id [lindex $displayorder $l]
4450 set currentid $id
4451 $sha1entry delete 0 end
4452 $sha1entry insert 0 $id
4453 $sha1entry selection from 0
4454 $sha1entry selection to end
4455 rhighlight_sel $id
4457 $ctext conf -state normal
4458 clear_ctext
4459 set linknum 0
4460 set info $commitinfo($id)
4461 set date [formatdate [lindex $info 2]]
4462 $ctext insert end "Author: [lindex $info 1] $date\n"
4463 set date [formatdate [lindex $info 4]]
4464 $ctext insert end "Committer: [lindex $info 3] $date\n"
4465 if {[info exists idtags($id)]} {
4466 $ctext insert end "Tags:"
4467 foreach tag $idtags($id) {
4468 $ctext insert end " $tag"
4470 $ctext insert end "\n"
4473 set headers {}
4474 set olds [lindex $parentlist $l]
4475 if {[llength $olds] > 1} {
4476 set np 0
4477 foreach p $olds {
4478 if {$np >= $mergemax} {
4479 set tag mmax
4480 } else {
4481 set tag m$np
4483 $ctext insert end "Parent: " $tag
4484 appendwithlinks [commit_descriptor $p] {}
4485 incr np
4487 } else {
4488 foreach p $olds {
4489 append headers "Parent: [commit_descriptor $p]"
4493 foreach c $children($curview,$id) {
4494 append headers "Child: [commit_descriptor $c]"
4497 # make anything that looks like a SHA1 ID be a clickable link
4498 appendwithlinks $headers {}
4499 if {$showneartags} {
4500 if {![info exists allcommits]} {
4501 getallcommits
4503 $ctext insert end "Branch: "
4504 $ctext mark set branch "end -1c"
4505 $ctext mark gravity branch left
4506 $ctext insert end "\nFollows: "
4507 $ctext mark set follows "end -1c"
4508 $ctext mark gravity follows left
4509 $ctext insert end "\nPrecedes: "
4510 $ctext mark set precedes "end -1c"
4511 $ctext mark gravity precedes left
4512 $ctext insert end "\n"
4513 dispneartags 1
4515 $ctext insert end "\n"
4516 set comment [lindex $info 5]
4517 if {[string first "\r" $comment] >= 0} {
4518 set comment [string map {"\r" "\n "} $comment]
4520 appendwithlinks $comment {comment}
4522 $ctext tag remove found 1.0 end
4523 $ctext conf -state disabled
4524 set commentend [$ctext index "end - 1c"]
4526 init_flist "Comments"
4527 if {$cmitmode eq "tree"} {
4528 gettree $id
4529 } elseif {[llength $olds] <= 1} {
4530 startdiff $id
4531 } else {
4532 mergediff $id $l
4536 proc selfirstline {} {
4537 unmarkmatches
4538 selectline 0 1
4541 proc sellastline {} {
4542 global numcommits
4543 unmarkmatches
4544 set l [expr {$numcommits - 1}]
4545 selectline $l 1
4548 proc selnextline {dir} {
4549 global selectedline
4550 if {![info exists selectedline]} return
4551 set l [expr {$selectedline + $dir}]
4552 unmarkmatches
4553 selectline $l 1
4556 proc selnextpage {dir} {
4557 global canv linespc selectedline numcommits
4559 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4560 if {$lpp < 1} {
4561 set lpp 1
4563 allcanvs yview scroll [expr {$dir * $lpp}] units
4564 drawvisible
4565 if {![info exists selectedline]} return
4566 set l [expr {$selectedline + $dir * $lpp}]
4567 if {$l < 0} {
4568 set l 0
4569 } elseif {$l >= $numcommits} {
4570 set l [expr $numcommits - 1]
4572 unmarkmatches
4573 selectline $l 1
4576 proc unselectline {} {
4577 global selectedline currentid
4579 catch {unset selectedline}
4580 catch {unset currentid}
4581 allcanvs delete secsel
4582 rhighlight_none
4583 cancel_next_highlight
4586 proc reselectline {} {
4587 global selectedline
4589 if {[info exists selectedline]} {
4590 selectline $selectedline 0
4594 proc addtohistory {cmd} {
4595 global history historyindex curview
4597 set elt [list $curview $cmd]
4598 if {$historyindex > 0
4599 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4600 return
4603 if {$historyindex < [llength $history]} {
4604 set history [lreplace $history $historyindex end $elt]
4605 } else {
4606 lappend history $elt
4608 incr historyindex
4609 if {$historyindex > 1} {
4610 .tf.bar.leftbut conf -state normal
4611 } else {
4612 .tf.bar.leftbut conf -state disabled
4614 .tf.bar.rightbut conf -state disabled
4617 proc godo {elt} {
4618 global curview
4620 set view [lindex $elt 0]
4621 set cmd [lindex $elt 1]
4622 if {$curview != $view} {
4623 showview $view
4625 eval $cmd
4628 proc goback {} {
4629 global history historyindex
4631 if {$historyindex > 1} {
4632 incr historyindex -1
4633 godo [lindex $history [expr {$historyindex - 1}]]
4634 .tf.bar.rightbut conf -state normal
4636 if {$historyindex <= 1} {
4637 .tf.bar.leftbut conf -state disabled
4641 proc goforw {} {
4642 global history historyindex
4644 if {$historyindex < [llength $history]} {
4645 set cmd [lindex $history $historyindex]
4646 incr historyindex
4647 godo $cmd
4648 .tf.bar.leftbut conf -state normal
4650 if {$historyindex >= [llength $history]} {
4651 .tf.bar.rightbut conf -state disabled
4655 proc gettree {id} {
4656 global treefilelist treeidlist diffids diffmergeid treepending
4657 global nullid nullid2
4659 set diffids $id
4660 catch {unset diffmergeid}
4661 if {![info exists treefilelist($id)]} {
4662 if {![info exists treepending]} {
4663 if {$id eq $nullid} {
4664 set cmd [list | git ls-files]
4665 } elseif {$id eq $nullid2} {
4666 set cmd [list | git ls-files --stage -t]
4667 } else {
4668 set cmd [list | git ls-tree -r $id]
4670 if {[catch {set gtf [open $cmd r]}]} {
4671 return
4673 set treepending $id
4674 set treefilelist($id) {}
4675 set treeidlist($id) {}
4676 fconfigure $gtf -blocking 0
4677 filerun $gtf [list gettreeline $gtf $id]
4679 } else {
4680 setfilelist $id
4684 proc gettreeline {gtf id} {
4685 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4687 set nl 0
4688 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4689 if {$diffids eq $nullid} {
4690 set fname $line
4691 } else {
4692 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4693 set i [string first "\t" $line]
4694 if {$i < 0} continue
4695 set sha1 [lindex $line 2]
4696 set fname [string range $line [expr {$i+1}] end]
4697 if {[string index $fname 0] eq "\""} {
4698 set fname [lindex $fname 0]
4700 lappend treeidlist($id) $sha1
4702 lappend treefilelist($id) $fname
4704 if {![eof $gtf]} {
4705 return [expr {$nl >= 1000? 2: 1}]
4707 close $gtf
4708 unset treepending
4709 if {$cmitmode ne "tree"} {
4710 if {![info exists diffmergeid]} {
4711 gettreediffs $diffids
4713 } elseif {$id ne $diffids} {
4714 gettree $diffids
4715 } else {
4716 setfilelist $id
4718 return 0
4721 proc showfile {f} {
4722 global treefilelist treeidlist diffids nullid nullid2
4723 global ctext commentend
4725 set i [lsearch -exact $treefilelist($diffids) $f]
4726 if {$i < 0} {
4727 puts "oops, $f not in list for id $diffids"
4728 return
4730 if {$diffids eq $nullid} {
4731 if {[catch {set bf [open $f r]} err]} {
4732 puts "oops, can't read $f: $err"
4733 return
4735 } else {
4736 set blob [lindex $treeidlist($diffids) $i]
4737 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4738 puts "oops, error reading blob $blob: $err"
4739 return
4742 fconfigure $bf -blocking 0
4743 filerun $bf [list getblobline $bf $diffids]
4744 $ctext config -state normal
4745 clear_ctext $commentend
4746 $ctext insert end "\n"
4747 $ctext insert end "$f\n" filesep
4748 $ctext config -state disabled
4749 $ctext yview $commentend
4752 proc getblobline {bf id} {
4753 global diffids cmitmode ctext
4755 if {$id ne $diffids || $cmitmode ne "tree"} {
4756 catch {close $bf}
4757 return 0
4759 $ctext config -state normal
4760 set nl 0
4761 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4762 $ctext insert end "$line\n"
4764 if {[eof $bf]} {
4765 # delete last newline
4766 $ctext delete "end - 2c" "end - 1c"
4767 close $bf
4768 return 0
4770 $ctext config -state disabled
4771 return [expr {$nl >= 1000? 2: 1}]
4774 proc mergediff {id l} {
4775 global diffmergeid diffopts mdifffd
4776 global diffids
4777 global parentlist
4779 set diffmergeid $id
4780 set diffids $id
4781 # this doesn't seem to actually affect anything...
4782 set env(GIT_DIFF_OPTS) $diffopts
4783 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4784 if {[catch {set mdf [open $cmd r]} err]} {
4785 error_popup "Error getting merge diffs: $err"
4786 return
4788 fconfigure $mdf -blocking 0
4789 set mdifffd($id) $mdf
4790 set np [llength [lindex $parentlist $l]]
4791 filerun $mdf [list getmergediffline $mdf $id $np]
4794 proc getmergediffline {mdf id np} {
4795 global diffmergeid ctext cflist mergemax
4796 global difffilestart mdifffd
4798 $ctext conf -state normal
4799 set nr 0
4800 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4801 if {![info exists diffmergeid] || $id != $diffmergeid
4802 || $mdf != $mdifffd($id)} {
4803 close $mdf
4804 return 0
4806 if {[regexp {^diff --cc (.*)} $line match fname]} {
4807 # start of a new file
4808 $ctext insert end "\n"
4809 set here [$ctext index "end - 1c"]
4810 lappend difffilestart $here
4811 add_flist [list $fname]
4812 set l [expr {(78 - [string length $fname]) / 2}]
4813 set pad [string range "----------------------------------------" 1 $l]
4814 $ctext insert end "$pad $fname $pad\n" filesep
4815 } elseif {[regexp {^@@} $line]} {
4816 $ctext insert end "$line\n" hunksep
4817 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4818 # do nothing
4819 } else {
4820 # parse the prefix - one ' ', '-' or '+' for each parent
4821 set spaces {}
4822 set minuses {}
4823 set pluses {}
4824 set isbad 0
4825 for {set j 0} {$j < $np} {incr j} {
4826 set c [string range $line $j $j]
4827 if {$c == " "} {
4828 lappend spaces $j
4829 } elseif {$c == "-"} {
4830 lappend minuses $j
4831 } elseif {$c == "+"} {
4832 lappend pluses $j
4833 } else {
4834 set isbad 1
4835 break
4838 set tags {}
4839 set num {}
4840 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4841 # line doesn't appear in result, parents in $minuses have the line
4842 set num [lindex $minuses 0]
4843 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4844 # line appears in result, parents in $pluses don't have the line
4845 lappend tags mresult
4846 set num [lindex $spaces 0]
4848 if {$num ne {}} {
4849 if {$num >= $mergemax} {
4850 set num "max"
4852 lappend tags m$num
4854 $ctext insert end "$line\n" $tags
4857 $ctext conf -state disabled
4858 if {[eof $mdf]} {
4859 close $mdf
4860 return 0
4862 return [expr {$nr >= 1000? 2: 1}]
4865 proc startdiff {ids} {
4866 global treediffs diffids treepending diffmergeid nullid nullid2
4868 set diffids $ids
4869 catch {unset diffmergeid}
4870 if {![info exists treediffs($ids)] ||
4871 [lsearch -exact $ids $nullid] >= 0 ||
4872 [lsearch -exact $ids $nullid2] >= 0} {
4873 if {![info exists treepending]} {
4874 gettreediffs $ids
4876 } else {
4877 addtocflist $ids
4881 proc addtocflist {ids} {
4882 global treediffs cflist
4883 add_flist $treediffs($ids)
4884 getblobdiffs $ids
4887 proc diffcmd {ids flags} {
4888 global nullid nullid2
4890 set i [lsearch -exact $ids $nullid]
4891 set j [lsearch -exact $ids $nullid2]
4892 if {$i >= 0} {
4893 if {[llength $ids] > 1 && $j < 0} {
4894 # comparing working directory with some specific revision
4895 set cmd [concat | git diff-index $flags]
4896 if {$i == 0} {
4897 lappend cmd -R [lindex $ids 1]
4898 } else {
4899 lappend cmd [lindex $ids 0]
4901 } else {
4902 # comparing working directory with index
4903 set cmd [concat | git diff-files $flags]
4904 if {$j == 1} {
4905 lappend cmd -R
4908 } elseif {$j >= 0} {
4909 set cmd [concat | git diff-index --cached $flags]
4910 if {[llength $ids] > 1} {
4911 # comparing index with specific revision
4912 if {$i == 0} {
4913 lappend cmd -R [lindex $ids 1]
4914 } else {
4915 lappend cmd [lindex $ids 0]
4917 } else {
4918 # comparing index with HEAD
4919 lappend cmd HEAD
4921 } else {
4922 set cmd [concat | git diff-tree -r $flags $ids]
4924 return $cmd
4927 proc gettreediffs {ids} {
4928 global treediff treepending
4930 set treepending $ids
4931 set treediff {}
4932 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4933 fconfigure $gdtf -blocking 0
4934 filerun $gdtf [list gettreediffline $gdtf $ids]
4937 proc gettreediffline {gdtf ids} {
4938 global treediff treediffs treepending diffids diffmergeid
4939 global cmitmode
4941 set nr 0
4942 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4943 set i [string first "\t" $line]
4944 if {$i >= 0} {
4945 set file [string range $line [expr {$i+1}] end]
4946 if {[string index $file 0] eq "\""} {
4947 set file [lindex $file 0]
4949 lappend treediff $file
4952 if {![eof $gdtf]} {
4953 return [expr {$nr >= 1000? 2: 1}]
4955 close $gdtf
4956 set treediffs($ids) $treediff
4957 unset treepending
4958 if {$cmitmode eq "tree"} {
4959 gettree $diffids
4960 } elseif {$ids != $diffids} {
4961 if {![info exists diffmergeid]} {
4962 gettreediffs $diffids
4964 } else {
4965 addtocflist $ids
4967 return 0
4970 proc getblobdiffs {ids} {
4971 global diffopts blobdifffd diffids env
4972 global diffinhdr treediffs
4974 set env(GIT_DIFF_OPTS) $diffopts
4975 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4976 puts "error getting diffs: $err"
4977 return
4979 set diffinhdr 0
4980 fconfigure $bdf -blocking 0
4981 set blobdifffd($ids) $bdf
4982 filerun $bdf [list getblobdiffline $bdf $diffids]
4985 proc setinlist {var i val} {
4986 global $var
4988 while {[llength [set $var]] < $i} {
4989 lappend $var {}
4991 if {[llength [set $var]] == $i} {
4992 lappend $var $val
4993 } else {
4994 lset $var $i $val
4998 proc makediffhdr {fname ids} {
4999 global ctext curdiffstart treediffs
5001 set i [lsearch -exact $treediffs($ids) $fname]
5002 if {$i >= 0} {
5003 setinlist difffilestart $i $curdiffstart
5005 set l [expr {(78 - [string length $fname]) / 2}]
5006 set pad [string range "----------------------------------------" 1 $l]
5007 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5010 proc getblobdiffline {bdf ids} {
5011 global diffids blobdifffd ctext curdiffstart
5012 global diffnexthead diffnextnote difffilestart
5013 global diffinhdr treediffs
5015 set nr 0
5016 $ctext conf -state normal
5017 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5018 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5019 close $bdf
5020 return 0
5022 if {![string compare -length 11 "diff --git " $line]} {
5023 # trim off "diff --git "
5024 set line [string range $line 11 end]
5025 set diffinhdr 1
5026 # start of a new file
5027 $ctext insert end "\n"
5028 set curdiffstart [$ctext index "end - 1c"]
5029 $ctext insert end "\n" filesep
5030 # If the name hasn't changed the length will be odd,
5031 # the middle char will be a space, and the two bits either
5032 # side will be a/name and b/name, or "a/name" and "b/name".
5033 # If the name has changed we'll get "rename from" and
5034 # "rename to" lines following this, and we'll use them
5035 # to get the filenames.
5036 # This complexity is necessary because spaces in the filename(s)
5037 # don't get escaped.
5038 set l [string length $line]
5039 set i [expr {$l / 2}]
5040 if {!(($l & 1) && [string index $line $i] eq " " &&
5041 [string range $line 2 [expr {$i - 1}]] eq \
5042 [string range $line [expr {$i + 3}] end])} {
5043 continue
5045 # unescape if quoted and chop off the a/ from the front
5046 if {[string index $line 0] eq "\""} {
5047 set fname [string range [lindex $line 0] 2 end]
5048 } else {
5049 set fname [string range $line 2 [expr {$i - 1}]]
5051 makediffhdr $fname $ids
5053 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5054 $line match f1l f1c f2l f2c rest]} {
5055 $ctext insert end "$line\n" hunksep
5056 set diffinhdr 0
5058 } elseif {$diffinhdr} {
5059 if {![string compare -length 12 "rename from " $line]} {
5060 set fname [string range $line 12 end]
5061 if {[string index $fname 0] eq "\""} {
5062 set fname [lindex $fname 0]
5064 set i [lsearch -exact $treediffs($ids) $fname]
5065 if {$i >= 0} {
5066 setinlist difffilestart $i $curdiffstart
5068 } elseif {![string compare -length 10 $line "rename to "]} {
5069 set fname [string range $line 10 end]
5070 if {[string index $fname 0] eq "\""} {
5071 set fname [lindex $fname 0]
5073 makediffhdr $fname $ids
5074 } elseif {[string compare -length 3 $line "---"] == 0} {
5075 # do nothing
5076 continue
5077 } elseif {[string compare -length 3 $line "+++"] == 0} {
5078 set diffinhdr 0
5079 continue
5081 $ctext insert end "$line\n" filesep
5083 } else {
5084 set x [string range $line 0 0]
5085 if {$x == "-" || $x == "+"} {
5086 set tag [expr {$x == "+"}]
5087 $ctext insert end "$line\n" d$tag
5088 } elseif {$x == " "} {
5089 $ctext insert end "$line\n"
5090 } else {
5091 # "\ No newline at end of file",
5092 # or something else we don't recognize
5093 $ctext insert end "$line\n" hunksep
5097 $ctext conf -state disabled
5098 if {[eof $bdf]} {
5099 close $bdf
5100 return 0
5102 return [expr {$nr >= 1000? 2: 1}]
5105 proc changediffdisp {} {
5106 global ctext diffelide
5108 $ctext tag conf d0 -elide [lindex $diffelide 0]
5109 $ctext tag conf d1 -elide [lindex $diffelide 1]
5112 proc prevfile {} {
5113 global difffilestart ctext
5114 set prev [lindex $difffilestart 0]
5115 set here [$ctext index @0,0]
5116 foreach loc $difffilestart {
5117 if {[$ctext compare $loc >= $here]} {
5118 $ctext yview $prev
5119 return
5121 set prev $loc
5123 $ctext yview $prev
5126 proc nextfile {} {
5127 global difffilestart ctext
5128 set here [$ctext index @0,0]
5129 foreach loc $difffilestart {
5130 if {[$ctext compare $loc > $here]} {
5131 $ctext yview $loc
5132 return
5137 proc clear_ctext {{first 1.0}} {
5138 global ctext smarktop smarkbot
5140 set l [lindex [split $first .] 0]
5141 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5142 set smarktop $l
5144 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5145 set smarkbot $l
5147 $ctext delete $first end
5150 proc incrsearch {name ix op} {
5151 global ctext searchstring searchdirn
5153 $ctext tag remove found 1.0 end
5154 if {[catch {$ctext index anchor}]} {
5155 # no anchor set, use start of selection, or of visible area
5156 set sel [$ctext tag ranges sel]
5157 if {$sel ne {}} {
5158 $ctext mark set anchor [lindex $sel 0]
5159 } elseif {$searchdirn eq "-forwards"} {
5160 $ctext mark set anchor @0,0
5161 } else {
5162 $ctext mark set anchor @0,[winfo height $ctext]
5165 if {$searchstring ne {}} {
5166 set here [$ctext search $searchdirn -- $searchstring anchor]
5167 if {$here ne {}} {
5168 $ctext see $here
5170 searchmarkvisible 1
5174 proc dosearch {} {
5175 global sstring ctext searchstring searchdirn
5177 focus $sstring
5178 $sstring icursor end
5179 set searchdirn -forwards
5180 if {$searchstring ne {}} {
5181 set sel [$ctext tag ranges sel]
5182 if {$sel ne {}} {
5183 set start "[lindex $sel 0] + 1c"
5184 } elseif {[catch {set start [$ctext index anchor]}]} {
5185 set start "@0,0"
5187 set match [$ctext search -count mlen -- $searchstring $start]
5188 $ctext tag remove sel 1.0 end
5189 if {$match eq {}} {
5190 bell
5191 return
5193 $ctext see $match
5194 set mend "$match + $mlen c"
5195 $ctext tag add sel $match $mend
5196 $ctext mark unset anchor
5200 proc dosearchback {} {
5201 global sstring ctext searchstring searchdirn
5203 focus $sstring
5204 $sstring icursor end
5205 set searchdirn -backwards
5206 if {$searchstring ne {}} {
5207 set sel [$ctext tag ranges sel]
5208 if {$sel ne {}} {
5209 set start [lindex $sel 0]
5210 } elseif {[catch {set start [$ctext index anchor]}]} {
5211 set start @0,[winfo height $ctext]
5213 set match [$ctext search -backwards -count ml -- $searchstring $start]
5214 $ctext tag remove sel 1.0 end
5215 if {$match eq {}} {
5216 bell
5217 return
5219 $ctext see $match
5220 set mend "$match + $ml c"
5221 $ctext tag add sel $match $mend
5222 $ctext mark unset anchor
5226 proc searchmark {first last} {
5227 global ctext searchstring
5229 set mend $first.0
5230 while {1} {
5231 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5232 if {$match eq {}} break
5233 set mend "$match + $mlen c"
5234 $ctext tag add found $match $mend
5238 proc searchmarkvisible {doall} {
5239 global ctext smarktop smarkbot
5241 set topline [lindex [split [$ctext index @0,0] .] 0]
5242 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5243 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5244 # no overlap with previous
5245 searchmark $topline $botline
5246 set smarktop $topline
5247 set smarkbot $botline
5248 } else {
5249 if {$topline < $smarktop} {
5250 searchmark $topline [expr {$smarktop-1}]
5251 set smarktop $topline
5253 if {$botline > $smarkbot} {
5254 searchmark [expr {$smarkbot+1}] $botline
5255 set smarkbot $botline
5260 proc scrolltext {f0 f1} {
5261 global searchstring
5263 .bleft.sb set $f0 $f1
5264 if {$searchstring ne {}} {
5265 searchmarkvisible 0
5269 proc setcoords {} {
5270 global linespc charspc canvx0 canvy0 mainfont
5271 global xspc1 xspc2 lthickness
5273 set linespc [font metrics $mainfont -linespace]
5274 set charspc [font measure $mainfont "m"]
5275 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5276 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5277 set lthickness [expr {int($linespc / 9) + 1}]
5278 set xspc1(0) $linespc
5279 set xspc2 $linespc
5282 proc redisplay {} {
5283 global canv
5284 global selectedline
5286 set ymax [lindex [$canv cget -scrollregion] 3]
5287 if {$ymax eq {} || $ymax == 0} return
5288 set span [$canv yview]
5289 clear_display
5290 setcanvscroll
5291 allcanvs yview moveto [lindex $span 0]
5292 drawvisible
5293 if {[info exists selectedline]} {
5294 selectline $selectedline 0
5295 allcanvs yview moveto [lindex $span 0]
5299 proc incrfont {inc} {
5300 global mainfont textfont ctext canv phase cflist
5301 global charspc tabstop
5302 global stopped entries
5303 unmarkmatches
5304 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5305 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5306 setcoords
5307 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5308 $cflist conf -font $textfont
5309 $ctext tag conf filesep -font [concat $textfont bold]
5310 foreach e $entries {
5311 $e conf -font $mainfont
5313 if {$phase eq "getcommits"} {
5314 $canv itemconf textitems -font $mainfont
5316 redisplay
5319 proc clearsha1 {} {
5320 global sha1entry sha1string
5321 if {[string length $sha1string] == 40} {
5322 $sha1entry delete 0 end
5326 proc sha1change {n1 n2 op} {
5327 global sha1string currentid sha1but
5328 if {$sha1string == {}
5329 || ([info exists currentid] && $sha1string == $currentid)} {
5330 set state disabled
5331 } else {
5332 set state normal
5334 if {[$sha1but cget -state] == $state} return
5335 if {$state == "normal"} {
5336 $sha1but conf -state normal -relief raised -text "Goto: "
5337 } else {
5338 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5342 proc gotocommit {} {
5343 global sha1string currentid commitrow tagids headids
5344 global displayorder numcommits curview
5346 if {$sha1string == {}
5347 || ([info exists currentid] && $sha1string == $currentid)} return
5348 if {[info exists tagids($sha1string)]} {
5349 set id $tagids($sha1string)
5350 } elseif {[info exists headids($sha1string)]} {
5351 set id $headids($sha1string)
5352 } else {
5353 set id [string tolower $sha1string]
5354 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5355 set matches {}
5356 foreach i $displayorder {
5357 if {[string match $id* $i]} {
5358 lappend matches $i
5361 if {$matches ne {}} {
5362 if {[llength $matches] > 1} {
5363 error_popup "Short SHA1 id $id is ambiguous"
5364 return
5366 set id [lindex $matches 0]
5370 if {[info exists commitrow($curview,$id)]} {
5371 selectline $commitrow($curview,$id) 1
5372 return
5374 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5375 set type "SHA1 id"
5376 } else {
5377 set type "Tag/Head"
5379 error_popup "$type $sha1string is not known"
5382 proc lineenter {x y id} {
5383 global hoverx hovery hoverid hovertimer
5384 global commitinfo canv
5386 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5387 set hoverx $x
5388 set hovery $y
5389 set hoverid $id
5390 if {[info exists hovertimer]} {
5391 after cancel $hovertimer
5393 set hovertimer [after 500 linehover]
5394 $canv delete hover
5397 proc linemotion {x y id} {
5398 global hoverx hovery hoverid hovertimer
5400 if {[info exists hoverid] && $id == $hoverid} {
5401 set hoverx $x
5402 set hovery $y
5403 if {[info exists hovertimer]} {
5404 after cancel $hovertimer
5406 set hovertimer [after 500 linehover]
5410 proc lineleave {id} {
5411 global hoverid hovertimer canv
5413 if {[info exists hoverid] && $id == $hoverid} {
5414 $canv delete hover
5415 if {[info exists hovertimer]} {
5416 after cancel $hovertimer
5417 unset hovertimer
5419 unset hoverid
5423 proc linehover {} {
5424 global hoverx hovery hoverid hovertimer
5425 global canv linespc lthickness
5426 global commitinfo mainfont
5428 set text [lindex $commitinfo($hoverid) 0]
5429 set ymax [lindex [$canv cget -scrollregion] 3]
5430 if {$ymax == {}} return
5431 set yfrac [lindex [$canv yview] 0]
5432 set x [expr {$hoverx + 2 * $linespc}]
5433 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5434 set x0 [expr {$x - 2 * $lthickness}]
5435 set y0 [expr {$y - 2 * $lthickness}]
5436 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5437 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5438 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5439 -fill \#ffff80 -outline black -width 1 -tags hover]
5440 $canv raise $t
5441 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5442 -font $mainfont]
5443 $canv raise $t
5446 proc clickisonarrow {id y} {
5447 global lthickness
5449 set ranges [rowranges $id]
5450 set thresh [expr {2 * $lthickness + 6}]
5451 set n [expr {[llength $ranges] - 1}]
5452 for {set i 1} {$i < $n} {incr i} {
5453 set row [lindex $ranges $i]
5454 if {abs([yc $row] - $y) < $thresh} {
5455 return $i
5458 return {}
5461 proc arrowjump {id n y} {
5462 global canv
5464 # 1 <-> 2, 3 <-> 4, etc...
5465 set n [expr {(($n - 1) ^ 1) + 1}]
5466 set row [lindex [rowranges $id] $n]
5467 set yt [yc $row]
5468 set ymax [lindex [$canv cget -scrollregion] 3]
5469 if {$ymax eq {} || $ymax <= 0} return
5470 set view [$canv yview]
5471 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5472 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5473 if {$yfrac < 0} {
5474 set yfrac 0
5476 allcanvs yview moveto $yfrac
5479 proc lineclick {x y id isnew} {
5480 global ctext commitinfo children canv thickerline curview
5482 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5483 unmarkmatches
5484 unselectline
5485 normalline
5486 $canv delete hover
5487 # draw this line thicker than normal
5488 set thickerline $id
5489 drawlines $id
5490 if {$isnew} {
5491 set ymax [lindex [$canv cget -scrollregion] 3]
5492 if {$ymax eq {}} return
5493 set yfrac [lindex [$canv yview] 0]
5494 set y [expr {$y + $yfrac * $ymax}]
5496 set dirn [clickisonarrow $id $y]
5497 if {$dirn ne {}} {
5498 arrowjump $id $dirn $y
5499 return
5502 if {$isnew} {
5503 addtohistory [list lineclick $x $y $id 0]
5505 # fill the details pane with info about this line
5506 $ctext conf -state normal
5507 clear_ctext
5508 $ctext tag conf link -foreground blue -underline 1
5509 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5510 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5511 $ctext insert end "Parent:\t"
5512 $ctext insert end $id [list link link0]
5513 $ctext tag bind link0 <1> [list selbyid $id]
5514 set info $commitinfo($id)
5515 $ctext insert end "\n\t[lindex $info 0]\n"
5516 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5517 set date [formatdate [lindex $info 2]]
5518 $ctext insert end "\tDate:\t$date\n"
5519 set kids $children($curview,$id)
5520 if {$kids ne {}} {
5521 $ctext insert end "\nChildren:"
5522 set i 0
5523 foreach child $kids {
5524 incr i
5525 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5526 set info $commitinfo($child)
5527 $ctext insert end "\n\t"
5528 $ctext insert end $child [list link link$i]
5529 $ctext tag bind link$i <1> [list selbyid $child]
5530 $ctext insert end "\n\t[lindex $info 0]"
5531 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5532 set date [formatdate [lindex $info 2]]
5533 $ctext insert end "\n\tDate:\t$date\n"
5536 $ctext conf -state disabled
5537 init_flist {}
5540 proc normalline {} {
5541 global thickerline
5542 if {[info exists thickerline]} {
5543 set id $thickerline
5544 unset thickerline
5545 drawlines $id
5549 proc selbyid {id} {
5550 global commitrow curview
5551 if {[info exists commitrow($curview,$id)]} {
5552 selectline $commitrow($curview,$id) 1
5556 proc mstime {} {
5557 global startmstime
5558 if {![info exists startmstime]} {
5559 set startmstime [clock clicks -milliseconds]
5561 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5564 proc rowmenu {x y id} {
5565 global rowctxmenu commitrow selectedline rowmenuid curview
5566 global nullid nullid2 fakerowmenu mainhead
5568 set rowmenuid $id
5569 if {![info exists selectedline]
5570 || $commitrow($curview,$id) eq $selectedline} {
5571 set state disabled
5572 } else {
5573 set state normal
5575 if {$id ne $nullid && $id ne $nullid2} {
5576 set menu $rowctxmenu
5577 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5578 } else {
5579 set menu $fakerowmenu
5581 $menu entryconfigure "Diff this*" -state $state
5582 $menu entryconfigure "Diff selected*" -state $state
5583 $menu entryconfigure "Make patch" -state $state
5584 tk_popup $menu $x $y
5587 proc diffvssel {dirn} {
5588 global rowmenuid selectedline displayorder
5590 if {![info exists selectedline]} return
5591 if {$dirn} {
5592 set oldid [lindex $displayorder $selectedline]
5593 set newid $rowmenuid
5594 } else {
5595 set oldid $rowmenuid
5596 set newid [lindex $displayorder $selectedline]
5598 addtohistory [list doseldiff $oldid $newid]
5599 doseldiff $oldid $newid
5602 proc doseldiff {oldid newid} {
5603 global ctext
5604 global commitinfo
5606 $ctext conf -state normal
5607 clear_ctext
5608 init_flist "Top"
5609 $ctext insert end "From "
5610 $ctext tag conf link -foreground blue -underline 1
5611 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5612 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5613 $ctext tag bind link0 <1> [list selbyid $oldid]
5614 $ctext insert end $oldid [list link link0]
5615 $ctext insert end "\n "
5616 $ctext insert end [lindex $commitinfo($oldid) 0]
5617 $ctext insert end "\n\nTo "
5618 $ctext tag bind link1 <1> [list selbyid $newid]
5619 $ctext insert end $newid [list link link1]
5620 $ctext insert end "\n "
5621 $ctext insert end [lindex $commitinfo($newid) 0]
5622 $ctext insert end "\n"
5623 $ctext conf -state disabled
5624 $ctext tag remove found 1.0 end
5625 startdiff [list $oldid $newid]
5628 proc mkpatch {} {
5629 global rowmenuid currentid commitinfo patchtop patchnum
5631 if {![info exists currentid]} return
5632 set oldid $currentid
5633 set oldhead [lindex $commitinfo($oldid) 0]
5634 set newid $rowmenuid
5635 set newhead [lindex $commitinfo($newid) 0]
5636 set top .patch
5637 set patchtop $top
5638 catch {destroy $top}
5639 toplevel $top
5640 label $top.title -text "Generate patch"
5641 grid $top.title - -pady 10
5642 label $top.from -text "From:"
5643 entry $top.fromsha1 -width 40 -relief flat
5644 $top.fromsha1 insert 0 $oldid
5645 $top.fromsha1 conf -state readonly
5646 grid $top.from $top.fromsha1 -sticky w
5647 entry $top.fromhead -width 60 -relief flat
5648 $top.fromhead insert 0 $oldhead
5649 $top.fromhead conf -state readonly
5650 grid x $top.fromhead -sticky w
5651 label $top.to -text "To:"
5652 entry $top.tosha1 -width 40 -relief flat
5653 $top.tosha1 insert 0 $newid
5654 $top.tosha1 conf -state readonly
5655 grid $top.to $top.tosha1 -sticky w
5656 entry $top.tohead -width 60 -relief flat
5657 $top.tohead insert 0 $newhead
5658 $top.tohead conf -state readonly
5659 grid x $top.tohead -sticky w
5660 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5661 grid $top.rev x -pady 10
5662 label $top.flab -text "Output file:"
5663 entry $top.fname -width 60
5664 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5665 incr patchnum
5666 grid $top.flab $top.fname -sticky w
5667 frame $top.buts
5668 button $top.buts.gen -text "Generate" -command mkpatchgo
5669 button $top.buts.can -text "Cancel" -command mkpatchcan
5670 grid $top.buts.gen $top.buts.can
5671 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5672 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5673 grid $top.buts - -pady 10 -sticky ew
5674 focus $top.fname
5677 proc mkpatchrev {} {
5678 global patchtop
5680 set oldid [$patchtop.fromsha1 get]
5681 set oldhead [$patchtop.fromhead get]
5682 set newid [$patchtop.tosha1 get]
5683 set newhead [$patchtop.tohead get]
5684 foreach e [list fromsha1 fromhead tosha1 tohead] \
5685 v [list $newid $newhead $oldid $oldhead] {
5686 $patchtop.$e conf -state normal
5687 $patchtop.$e delete 0 end
5688 $patchtop.$e insert 0 $v
5689 $patchtop.$e conf -state readonly
5693 proc mkpatchgo {} {
5694 global patchtop nullid nullid2
5696 set oldid [$patchtop.fromsha1 get]
5697 set newid [$patchtop.tosha1 get]
5698 set fname [$patchtop.fname get]
5699 set cmd [diffcmd [list $oldid $newid] -p]
5700 lappend cmd >$fname &
5701 if {[catch {eval exec $cmd} err]} {
5702 error_popup "Error creating patch: $err"
5704 catch {destroy $patchtop}
5705 unset patchtop
5708 proc mkpatchcan {} {
5709 global patchtop
5711 catch {destroy $patchtop}
5712 unset patchtop
5715 proc mktag {} {
5716 global rowmenuid mktagtop commitinfo
5718 set top .maketag
5719 set mktagtop $top
5720 catch {destroy $top}
5721 toplevel $top
5722 label $top.title -text "Create tag"
5723 grid $top.title - -pady 10
5724 label $top.id -text "ID:"
5725 entry $top.sha1 -width 40 -relief flat
5726 $top.sha1 insert 0 $rowmenuid
5727 $top.sha1 conf -state readonly
5728 grid $top.id $top.sha1 -sticky w
5729 entry $top.head -width 60 -relief flat
5730 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5731 $top.head conf -state readonly
5732 grid x $top.head -sticky w
5733 label $top.tlab -text "Tag name:"
5734 entry $top.tag -width 60
5735 grid $top.tlab $top.tag -sticky w
5736 frame $top.buts
5737 button $top.buts.gen -text "Create" -command mktaggo
5738 button $top.buts.can -text "Cancel" -command mktagcan
5739 grid $top.buts.gen $top.buts.can
5740 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5741 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5742 grid $top.buts - -pady 10 -sticky ew
5743 focus $top.tag
5746 proc domktag {} {
5747 global mktagtop env tagids idtags
5749 set id [$mktagtop.sha1 get]
5750 set tag [$mktagtop.tag get]
5751 if {$tag == {}} {
5752 error_popup "No tag name specified"
5753 return
5755 if {[info exists tagids($tag)]} {
5756 error_popup "Tag \"$tag\" already exists"
5757 return
5759 if {[catch {
5760 set dir [gitdir]
5761 set fname [file join $dir "refs/tags" $tag]
5762 set f [open $fname w]
5763 puts $f $id
5764 close $f
5765 } err]} {
5766 error_popup "Error creating tag: $err"
5767 return
5770 set tagids($tag) $id
5771 lappend idtags($id) $tag
5772 redrawtags $id
5773 addedtag $id
5776 proc redrawtags {id} {
5777 global canv linehtag commitrow idpos selectedline curview
5778 global mainfont canvxmax iddrawn
5780 if {![info exists commitrow($curview,$id)]} return
5781 if {![info exists iddrawn($id)]} return
5782 drawcommits $commitrow($curview,$id)
5783 $canv delete tag.$id
5784 set xt [eval drawtags $id $idpos($id)]
5785 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5786 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5787 set xr [expr {$xt + [font measure $mainfont $text]}]
5788 if {$xr > $canvxmax} {
5789 set canvxmax $xr
5790 setcanvscroll
5792 if {[info exists selectedline]
5793 && $selectedline == $commitrow($curview,$id)} {
5794 selectline $selectedline 0
5798 proc mktagcan {} {
5799 global mktagtop
5801 catch {destroy $mktagtop}
5802 unset mktagtop
5805 proc mktaggo {} {
5806 domktag
5807 mktagcan
5810 proc writecommit {} {
5811 global rowmenuid wrcomtop commitinfo wrcomcmd
5813 set top .writecommit
5814 set wrcomtop $top
5815 catch {destroy $top}
5816 toplevel $top
5817 label $top.title -text "Write commit to file"
5818 grid $top.title - -pady 10
5819 label $top.id -text "ID:"
5820 entry $top.sha1 -width 40 -relief flat
5821 $top.sha1 insert 0 $rowmenuid
5822 $top.sha1 conf -state readonly
5823 grid $top.id $top.sha1 -sticky w
5824 entry $top.head -width 60 -relief flat
5825 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5826 $top.head conf -state readonly
5827 grid x $top.head -sticky w
5828 label $top.clab -text "Command:"
5829 entry $top.cmd -width 60 -textvariable wrcomcmd
5830 grid $top.clab $top.cmd -sticky w -pady 10
5831 label $top.flab -text "Output file:"
5832 entry $top.fname -width 60
5833 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5834 grid $top.flab $top.fname -sticky w
5835 frame $top.buts
5836 button $top.buts.gen -text "Write" -command wrcomgo
5837 button $top.buts.can -text "Cancel" -command wrcomcan
5838 grid $top.buts.gen $top.buts.can
5839 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5840 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5841 grid $top.buts - -pady 10 -sticky ew
5842 focus $top.fname
5845 proc wrcomgo {} {
5846 global wrcomtop
5848 set id [$wrcomtop.sha1 get]
5849 set cmd "echo $id | [$wrcomtop.cmd get]"
5850 set fname [$wrcomtop.fname get]
5851 if {[catch {exec sh -c $cmd >$fname &} err]} {
5852 error_popup "Error writing commit: $err"
5854 catch {destroy $wrcomtop}
5855 unset wrcomtop
5858 proc wrcomcan {} {
5859 global wrcomtop
5861 catch {destroy $wrcomtop}
5862 unset wrcomtop
5865 proc mkbranch {} {
5866 global rowmenuid mkbrtop
5868 set top .makebranch
5869 catch {destroy $top}
5870 toplevel $top
5871 label $top.title -text "Create new branch"
5872 grid $top.title - -pady 10
5873 label $top.id -text "ID:"
5874 entry $top.sha1 -width 40 -relief flat
5875 $top.sha1 insert 0 $rowmenuid
5876 $top.sha1 conf -state readonly
5877 grid $top.id $top.sha1 -sticky w
5878 label $top.nlab -text "Name:"
5879 entry $top.name -width 40
5880 grid $top.nlab $top.name -sticky w
5881 frame $top.buts
5882 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5883 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5884 grid $top.buts.go $top.buts.can
5885 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5886 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5887 grid $top.buts - -pady 10 -sticky ew
5888 focus $top.name
5891 proc mkbrgo {top} {
5892 global headids idheads
5894 set name [$top.name get]
5895 set id [$top.sha1 get]
5896 if {$name eq {}} {
5897 error_popup "Please specify a name for the new branch"
5898 return
5900 catch {destroy $top}
5901 nowbusy newbranch
5902 update
5903 if {[catch {
5904 exec git branch $name $id
5905 } err]} {
5906 notbusy newbranch
5907 error_popup $err
5908 } else {
5909 set headids($name) $id
5910 lappend idheads($id) $name
5911 addedhead $id $name
5912 notbusy newbranch
5913 redrawtags $id
5914 dispneartags 0
5918 proc cherrypick {} {
5919 global rowmenuid curview commitrow
5920 global mainhead
5922 set oldhead [exec git rev-parse HEAD]
5923 set dheads [descheads $rowmenuid]
5924 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5925 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5926 included in branch $mainhead -- really re-apply it?"]
5927 if {!$ok} return
5929 nowbusy cherrypick
5930 update
5931 # Unfortunately git-cherry-pick writes stuff to stderr even when
5932 # no error occurs, and exec takes that as an indication of error...
5933 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5934 notbusy cherrypick
5935 error_popup $err
5936 return
5938 set newhead [exec git rev-parse HEAD]
5939 if {$newhead eq $oldhead} {
5940 notbusy cherrypick
5941 error_popup "No changes committed"
5942 return
5944 addnewchild $newhead $oldhead
5945 if {[info exists commitrow($curview,$oldhead)]} {
5946 insertrow $commitrow($curview,$oldhead) $newhead
5947 if {$mainhead ne {}} {
5948 movehead $newhead $mainhead
5949 movedhead $newhead $mainhead
5951 redrawtags $oldhead
5952 redrawtags $newhead
5954 notbusy cherrypick
5957 proc resethead {} {
5958 global mainheadid mainhead rowmenuid confirm_ok resettype
5959 global showlocalchanges
5961 set confirm_ok 0
5962 set w ".confirmreset"
5963 toplevel $w
5964 wm transient $w .
5965 wm title $w "Confirm reset"
5966 message $w.m -text \
5967 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5968 -justify center -aspect 1000
5969 pack $w.m -side top -fill x -padx 20 -pady 20
5970 frame $w.f -relief sunken -border 2
5971 message $w.f.rt -text "Reset type:" -aspect 1000
5972 grid $w.f.rt -sticky w
5973 set resettype mixed
5974 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5975 -text "Soft: Leave working tree and index untouched"
5976 grid $w.f.soft -sticky w
5977 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5978 -text "Mixed: Leave working tree untouched, reset index"
5979 grid $w.f.mixed -sticky w
5980 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5981 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5982 grid $w.f.hard -sticky w
5983 pack $w.f -side top -fill x
5984 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5985 pack $w.ok -side left -fill x -padx 20 -pady 20
5986 button $w.cancel -text Cancel -command "destroy $w"
5987 pack $w.cancel -side right -fill x -padx 20 -pady 20
5988 bind $w <Visibility> "grab $w; focus $w"
5989 tkwait window $w
5990 if {!$confirm_ok} return
5991 if {[catch {set fd [open \
5992 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5993 error_popup $err
5994 } else {
5995 dohidelocalchanges
5996 set w ".resetprogress"
5997 filerun $fd [list readresetstat $fd $w]
5998 toplevel $w
5999 wm transient $w
6000 wm title $w "Reset progress"
6001 message $w.m -text "Reset in progress, please wait..." \
6002 -justify center -aspect 1000
6003 pack $w.m -side top -fill x -padx 20 -pady 5
6004 canvas $w.c -width 150 -height 20 -bg white
6005 $w.c create rect 0 0 0 20 -fill green -tags rect
6006 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6007 nowbusy reset
6011 proc readresetstat {fd w} {
6012 global mainhead mainheadid showlocalchanges
6014 if {[gets $fd line] >= 0} {
6015 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6016 set x [expr {($m * 150) / $n}]
6017 $w.c coords rect 0 0 $x 20
6019 return 1
6021 destroy $w
6022 notbusy reset
6023 if {[catch {close $fd} err]} {
6024 error_popup $err
6026 set oldhead $mainheadid
6027 set newhead [exec git rev-parse HEAD]
6028 if {$newhead ne $oldhead} {
6029 movehead $newhead $mainhead
6030 movedhead $newhead $mainhead
6031 set mainheadid $newhead
6032 redrawtags $oldhead
6033 redrawtags $newhead
6035 if {$showlocalchanges} {
6036 doshowlocalchanges
6038 return 0
6041 # context menu for a head
6042 proc headmenu {x y id head} {
6043 global headmenuid headmenuhead headctxmenu mainhead
6045 set headmenuid $id
6046 set headmenuhead $head
6047 set state normal
6048 if {$head eq $mainhead} {
6049 set state disabled
6051 $headctxmenu entryconfigure 0 -state $state
6052 $headctxmenu entryconfigure 1 -state $state
6053 tk_popup $headctxmenu $x $y
6056 proc cobranch {} {
6057 global headmenuid headmenuhead mainhead headids
6058 global showlocalchanges mainheadid
6060 # check the tree is clean first??
6061 set oldmainhead $mainhead
6062 nowbusy checkout
6063 update
6064 dohidelocalchanges
6065 if {[catch {
6066 exec git checkout -q $headmenuhead
6067 } err]} {
6068 notbusy checkout
6069 error_popup $err
6070 } else {
6071 notbusy checkout
6072 set mainhead $headmenuhead
6073 set mainheadid $headmenuid
6074 if {[info exists headids($oldmainhead)]} {
6075 redrawtags $headids($oldmainhead)
6077 redrawtags $headmenuid
6079 if {$showlocalchanges} {
6080 dodiffindex
6084 proc rmbranch {} {
6085 global headmenuid headmenuhead mainhead
6086 global headids idheads
6088 set head $headmenuhead
6089 set id $headmenuid
6090 # this check shouldn't be needed any more...
6091 if {$head eq $mainhead} {
6092 error_popup "Cannot delete the currently checked-out branch"
6093 return
6095 set dheads [descheads $id]
6096 if {$dheads eq $headids($head)} {
6097 # the stuff on this branch isn't on any other branch
6098 if {![confirm_popup "The commits on branch $head aren't on any other\
6099 branch.\nReally delete branch $head?"]} return
6101 nowbusy rmbranch
6102 update
6103 if {[catch {exec git branch -D $head} err]} {
6104 notbusy rmbranch
6105 error_popup $err
6106 return
6108 removehead $id $head
6109 removedhead $id $head
6110 redrawtags $id
6111 notbusy rmbranch
6112 dispneartags 0
6115 # Stuff for finding nearby tags
6116 proc getallcommits {} {
6117 global allcommits allids nbmp nextarc seeds
6119 set allids {}
6120 set nbmp 0
6121 set nextarc 0
6122 set allcommits 0
6123 set seeds {}
6124 regetallcommits
6127 # Called when the graph might have changed
6128 proc regetallcommits {} {
6129 global allcommits seeds
6131 set cmd [concat | git rev-list --all --parents]
6132 foreach id $seeds {
6133 lappend cmd "^$id"
6135 set fd [open $cmd r]
6136 fconfigure $fd -blocking 0
6137 incr allcommits
6138 nowbusy allcommits
6139 filerun $fd [list getallclines $fd]
6142 # Since most commits have 1 parent and 1 child, we group strings of
6143 # such commits into "arcs" joining branch/merge points (BMPs), which
6144 # are commits that either don't have 1 parent or don't have 1 child.
6146 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6147 # arcout(id) - outgoing arcs for BMP
6148 # arcids(a) - list of IDs on arc including end but not start
6149 # arcstart(a) - BMP ID at start of arc
6150 # arcend(a) - BMP ID at end of arc
6151 # growing(a) - arc a is still growing
6152 # arctags(a) - IDs out of arcids (excluding end) that have tags
6153 # archeads(a) - IDs out of arcids (excluding end) that have heads
6154 # The start of an arc is at the descendent end, so "incoming" means
6155 # coming from descendents, and "outgoing" means going towards ancestors.
6157 proc getallclines {fd} {
6158 global allids allparents allchildren idtags idheads nextarc nbmp
6159 global arcnos arcids arctags arcout arcend arcstart archeads growing
6160 global seeds allcommits
6162 set nid 0
6163 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6164 set id [lindex $line 0]
6165 if {[info exists allparents($id)]} {
6166 # seen it already
6167 continue
6169 lappend allids $id
6170 set olds [lrange $line 1 end]
6171 set allparents($id) $olds
6172 if {![info exists allchildren($id)]} {
6173 set allchildren($id) {}
6174 set arcnos($id) {}
6175 lappend seeds $id
6176 } else {
6177 set a $arcnos($id)
6178 if {[llength $olds] == 1 && [llength $a] == 1} {
6179 lappend arcids($a) $id
6180 if {[info exists idtags($id)]} {
6181 lappend arctags($a) $id
6183 if {[info exists idheads($id)]} {
6184 lappend archeads($a) $id
6186 if {[info exists allparents($olds)]} {
6187 # seen parent already
6188 if {![info exists arcout($olds)]} {
6189 splitarc $olds
6191 lappend arcids($a) $olds
6192 set arcend($a) $olds
6193 unset growing($a)
6195 lappend allchildren($olds) $id
6196 lappend arcnos($olds) $a
6197 continue
6200 incr nbmp
6201 foreach a $arcnos($id) {
6202 lappend arcids($a) $id
6203 set arcend($a) $id
6204 unset growing($a)
6207 set ao {}
6208 foreach p $olds {
6209 lappend allchildren($p) $id
6210 set a [incr nextarc]
6211 set arcstart($a) $id
6212 set archeads($a) {}
6213 set arctags($a) {}
6214 set archeads($a) {}
6215 set arcids($a) {}
6216 lappend ao $a
6217 set growing($a) 1
6218 if {[info exists allparents($p)]} {
6219 # seen it already, may need to make a new branch
6220 if {![info exists arcout($p)]} {
6221 splitarc $p
6223 lappend arcids($a) $p
6224 set arcend($a) $p
6225 unset growing($a)
6227 lappend arcnos($p) $a
6229 set arcout($id) $ao
6231 if {$nid > 0} {
6232 global cached_dheads cached_dtags cached_atags
6233 catch {unset cached_dheads}
6234 catch {unset cached_dtags}
6235 catch {unset cached_atags}
6237 if {![eof $fd]} {
6238 return [expr {$nid >= 1000? 2: 1}]
6240 close $fd
6241 if {[incr allcommits -1] == 0} {
6242 notbusy allcommits
6244 dispneartags 0
6245 return 0
6248 proc recalcarc {a} {
6249 global arctags archeads arcids idtags idheads
6251 set at {}
6252 set ah {}
6253 foreach id [lrange $arcids($a) 0 end-1] {
6254 if {[info exists idtags($id)]} {
6255 lappend at $id
6257 if {[info exists idheads($id)]} {
6258 lappend ah $id
6261 set arctags($a) $at
6262 set archeads($a) $ah
6265 proc splitarc {p} {
6266 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6267 global arcstart arcend arcout allparents growing
6269 set a $arcnos($p)
6270 if {[llength $a] != 1} {
6271 puts "oops splitarc called but [llength $a] arcs already"
6272 return
6274 set a [lindex $a 0]
6275 set i [lsearch -exact $arcids($a) $p]
6276 if {$i < 0} {
6277 puts "oops splitarc $p not in arc $a"
6278 return
6280 set na [incr nextarc]
6281 if {[info exists arcend($a)]} {
6282 set arcend($na) $arcend($a)
6283 } else {
6284 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6285 set j [lsearch -exact $arcnos($l) $a]
6286 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6288 set tail [lrange $arcids($a) [expr {$i+1}] end]
6289 set arcids($a) [lrange $arcids($a) 0 $i]
6290 set arcend($a) $p
6291 set arcstart($na) $p
6292 set arcout($p) $na
6293 set arcids($na) $tail
6294 if {[info exists growing($a)]} {
6295 set growing($na) 1
6296 unset growing($a)
6298 incr nbmp
6300 foreach id $tail {
6301 if {[llength $arcnos($id)] == 1} {
6302 set arcnos($id) $na
6303 } else {
6304 set j [lsearch -exact $arcnos($id) $a]
6305 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6309 # reconstruct tags and heads lists
6310 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6311 recalcarc $a
6312 recalcarc $na
6313 } else {
6314 set arctags($na) {}
6315 set archeads($na) {}
6319 # Update things for a new commit added that is a child of one
6320 # existing commit. Used when cherry-picking.
6321 proc addnewchild {id p} {
6322 global allids allparents allchildren idtags nextarc nbmp
6323 global arcnos arcids arctags arcout arcend arcstart archeads growing
6324 global seeds
6326 lappend allids $id
6327 set allparents($id) [list $p]
6328 set allchildren($id) {}
6329 set arcnos($id) {}
6330 lappend seeds $id
6331 incr nbmp
6332 lappend allchildren($p) $id
6333 set a [incr nextarc]
6334 set arcstart($a) $id
6335 set archeads($a) {}
6336 set arctags($a) {}
6337 set arcids($a) [list $p]
6338 set arcend($a) $p
6339 if {![info exists arcout($p)]} {
6340 splitarc $p
6342 lappend arcnos($p) $a
6343 set arcout($id) [list $a]
6346 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6347 # or 0 if neither is true.
6348 proc anc_or_desc {a b} {
6349 global arcout arcstart arcend arcnos cached_isanc
6351 if {$arcnos($a) eq $arcnos($b)} {
6352 # Both are on the same arc(s); either both are the same BMP,
6353 # or if one is not a BMP, the other is also not a BMP or is
6354 # the BMP at end of the arc (and it only has 1 incoming arc).
6355 # Or both can be BMPs with no incoming arcs.
6356 if {$a eq $b || $arcnos($a) eq {}} {
6357 return 0
6359 # assert {[llength $arcnos($a)] == 1}
6360 set arc [lindex $arcnos($a) 0]
6361 set i [lsearch -exact $arcids($arc) $a]
6362 set j [lsearch -exact $arcids($arc) $b]
6363 if {$i < 0 || $i > $j} {
6364 return 1
6365 } else {
6366 return -1
6370 if {![info exists arcout($a)]} {
6371 set arc [lindex $arcnos($a) 0]
6372 if {[info exists arcend($arc)]} {
6373 set aend $arcend($arc)
6374 } else {
6375 set aend {}
6377 set a $arcstart($arc)
6378 } else {
6379 set aend $a
6381 if {![info exists arcout($b)]} {
6382 set arc [lindex $arcnos($b) 0]
6383 if {[info exists arcend($arc)]} {
6384 set bend $arcend($arc)
6385 } else {
6386 set bend {}
6388 set b $arcstart($arc)
6389 } else {
6390 set bend $b
6392 if {$a eq $bend} {
6393 return 1
6395 if {$b eq $aend} {
6396 return -1
6398 if {[info exists cached_isanc($a,$bend)]} {
6399 if {$cached_isanc($a,$bend)} {
6400 return 1
6403 if {[info exists cached_isanc($b,$aend)]} {
6404 if {$cached_isanc($b,$aend)} {
6405 return -1
6407 if {[info exists cached_isanc($a,$bend)]} {
6408 return 0
6412 set todo [list $a $b]
6413 set anc($a) a
6414 set anc($b) b
6415 for {set i 0} {$i < [llength $todo]} {incr i} {
6416 set x [lindex $todo $i]
6417 if {$anc($x) eq {}} {
6418 continue
6420 foreach arc $arcnos($x) {
6421 set xd $arcstart($arc)
6422 if {$xd eq $bend} {
6423 set cached_isanc($a,$bend) 1
6424 set cached_isanc($b,$aend) 0
6425 return 1
6426 } elseif {$xd eq $aend} {
6427 set cached_isanc($b,$aend) 1
6428 set cached_isanc($a,$bend) 0
6429 return -1
6431 if {![info exists anc($xd)]} {
6432 set anc($xd) $anc($x)
6433 lappend todo $xd
6434 } elseif {$anc($xd) ne $anc($x)} {
6435 set anc($xd) {}
6439 set cached_isanc($a,$bend) 0
6440 set cached_isanc($b,$aend) 0
6441 return 0
6444 # This identifies whether $desc has an ancestor that is
6445 # a growing tip of the graph and which is not an ancestor of $anc
6446 # and returns 0 if so and 1 if not.
6447 # If we subsequently discover a tag on such a growing tip, and that
6448 # turns out to be a descendent of $anc (which it could, since we
6449 # don't necessarily see children before parents), then $desc
6450 # isn't a good choice to display as a descendent tag of
6451 # $anc (since it is the descendent of another tag which is
6452 # a descendent of $anc). Similarly, $anc isn't a good choice to
6453 # display as a ancestor tag of $desc.
6455 proc is_certain {desc anc} {
6456 global arcnos arcout arcstart arcend growing problems
6458 set certain {}
6459 if {[llength $arcnos($anc)] == 1} {
6460 # tags on the same arc are certain
6461 if {$arcnos($desc) eq $arcnos($anc)} {
6462 return 1
6464 if {![info exists arcout($anc)]} {
6465 # if $anc is partway along an arc, use the start of the arc instead
6466 set a [lindex $arcnos($anc) 0]
6467 set anc $arcstart($a)
6470 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6471 set x $desc
6472 } else {
6473 set a [lindex $arcnos($desc) 0]
6474 set x $arcend($a)
6476 if {$x == $anc} {
6477 return 1
6479 set anclist [list $x]
6480 set dl($x) 1
6481 set nnh 1
6482 set ngrowanc 0
6483 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6484 set x [lindex $anclist $i]
6485 if {$dl($x)} {
6486 incr nnh -1
6488 set done($x) 1
6489 foreach a $arcout($x) {
6490 if {[info exists growing($a)]} {
6491 if {![info exists growanc($x)] && $dl($x)} {
6492 set growanc($x) 1
6493 incr ngrowanc
6495 } else {
6496 set y $arcend($a)
6497 if {[info exists dl($y)]} {
6498 if {$dl($y)} {
6499 if {!$dl($x)} {
6500 set dl($y) 0
6501 if {![info exists done($y)]} {
6502 incr nnh -1
6504 if {[info exists growanc($x)]} {
6505 incr ngrowanc -1
6507 set xl [list $y]
6508 for {set k 0} {$k < [llength $xl]} {incr k} {
6509 set z [lindex $xl $k]
6510 foreach c $arcout($z) {
6511 if {[info exists arcend($c)]} {
6512 set v $arcend($c)
6513 if {[info exists dl($v)] && $dl($v)} {
6514 set dl($v) 0
6515 if {![info exists done($v)]} {
6516 incr nnh -1
6518 if {[info exists growanc($v)]} {
6519 incr ngrowanc -1
6521 lappend xl $v
6528 } elseif {$y eq $anc || !$dl($x)} {
6529 set dl($y) 0
6530 lappend anclist $y
6531 } else {
6532 set dl($y) 1
6533 lappend anclist $y
6534 incr nnh
6539 foreach x [array names growanc] {
6540 if {$dl($x)} {
6541 return 0
6543 return 0
6545 return 1
6548 proc validate_arctags {a} {
6549 global arctags idtags
6551 set i -1
6552 set na $arctags($a)
6553 foreach id $arctags($a) {
6554 incr i
6555 if {![info exists idtags($id)]} {
6556 set na [lreplace $na $i $i]
6557 incr i -1
6560 set arctags($a) $na
6563 proc validate_archeads {a} {
6564 global archeads idheads
6566 set i -1
6567 set na $archeads($a)
6568 foreach id $archeads($a) {
6569 incr i
6570 if {![info exists idheads($id)]} {
6571 set na [lreplace $na $i $i]
6572 incr i -1
6575 set archeads($a) $na
6578 # Return the list of IDs that have tags that are descendents of id,
6579 # ignoring IDs that are descendents of IDs already reported.
6580 proc desctags {id} {
6581 global arcnos arcstart arcids arctags idtags allparents
6582 global growing cached_dtags
6584 if {![info exists allparents($id)]} {
6585 return {}
6587 set t1 [clock clicks -milliseconds]
6588 set argid $id
6589 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6590 # part-way along an arc; check that arc first
6591 set a [lindex $arcnos($id) 0]
6592 if {$arctags($a) ne {}} {
6593 validate_arctags $a
6594 set i [lsearch -exact $arcids($a) $id]
6595 set tid {}
6596 foreach t $arctags($a) {
6597 set j [lsearch -exact $arcids($a) $t]
6598 if {$j >= $i} break
6599 set tid $t
6601 if {$tid ne {}} {
6602 return $tid
6605 set id $arcstart($a)
6606 if {[info exists idtags($id)]} {
6607 return $id
6610 if {[info exists cached_dtags($id)]} {
6611 return $cached_dtags($id)
6614 set origid $id
6615 set todo [list $id]
6616 set queued($id) 1
6617 set nc 1
6618 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6619 set id [lindex $todo $i]
6620 set done($id) 1
6621 set ta [info exists hastaggedancestor($id)]
6622 if {!$ta} {
6623 incr nc -1
6625 # ignore tags on starting node
6626 if {!$ta && $i > 0} {
6627 if {[info exists idtags($id)]} {
6628 set tagloc($id) $id
6629 set ta 1
6630 } elseif {[info exists cached_dtags($id)]} {
6631 set tagloc($id) $cached_dtags($id)
6632 set ta 1
6635 foreach a $arcnos($id) {
6636 set d $arcstart($a)
6637 if {!$ta && $arctags($a) ne {}} {
6638 validate_arctags $a
6639 if {$arctags($a) ne {}} {
6640 lappend tagloc($id) [lindex $arctags($a) end]
6643 if {$ta || $arctags($a) ne {}} {
6644 set tomark [list $d]
6645 for {set j 0} {$j < [llength $tomark]} {incr j} {
6646 set dd [lindex $tomark $j]
6647 if {![info exists hastaggedancestor($dd)]} {
6648 if {[info exists done($dd)]} {
6649 foreach b $arcnos($dd) {
6650 lappend tomark $arcstart($b)
6652 if {[info exists tagloc($dd)]} {
6653 unset tagloc($dd)
6655 } elseif {[info exists queued($dd)]} {
6656 incr nc -1
6658 set hastaggedancestor($dd) 1
6662 if {![info exists queued($d)]} {
6663 lappend todo $d
6664 set queued($d) 1
6665 if {![info exists hastaggedancestor($d)]} {
6666 incr nc
6671 set tags {}
6672 foreach id [array names tagloc] {
6673 if {![info exists hastaggedancestor($id)]} {
6674 foreach t $tagloc($id) {
6675 if {[lsearch -exact $tags $t] < 0} {
6676 lappend tags $t
6681 set t2 [clock clicks -milliseconds]
6682 set loopix $i
6684 # remove tags that are descendents of other tags
6685 for {set i 0} {$i < [llength $tags]} {incr i} {
6686 set a [lindex $tags $i]
6687 for {set j 0} {$j < $i} {incr j} {
6688 set b [lindex $tags $j]
6689 set r [anc_or_desc $a $b]
6690 if {$r == 1} {
6691 set tags [lreplace $tags $j $j]
6692 incr j -1
6693 incr i -1
6694 } elseif {$r == -1} {
6695 set tags [lreplace $tags $i $i]
6696 incr i -1
6697 break
6702 if {[array names growing] ne {}} {
6703 # graph isn't finished, need to check if any tag could get
6704 # eclipsed by another tag coming later. Simply ignore any
6705 # tags that could later get eclipsed.
6706 set ctags {}
6707 foreach t $tags {
6708 if {[is_certain $t $origid]} {
6709 lappend ctags $t
6712 if {$tags eq $ctags} {
6713 set cached_dtags($origid) $tags
6714 } else {
6715 set tags $ctags
6717 } else {
6718 set cached_dtags($origid) $tags
6720 set t3 [clock clicks -milliseconds]
6721 if {0 && $t3 - $t1 >= 100} {
6722 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6723 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6725 return $tags
6728 proc anctags {id} {
6729 global arcnos arcids arcout arcend arctags idtags allparents
6730 global growing cached_atags
6732 if {![info exists allparents($id)]} {
6733 return {}
6735 set t1 [clock clicks -milliseconds]
6736 set argid $id
6737 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6738 # part-way along an arc; check that arc first
6739 set a [lindex $arcnos($id) 0]
6740 if {$arctags($a) ne {}} {
6741 validate_arctags $a
6742 set i [lsearch -exact $arcids($a) $id]
6743 foreach t $arctags($a) {
6744 set j [lsearch -exact $arcids($a) $t]
6745 if {$j > $i} {
6746 return $t
6750 if {![info exists arcend($a)]} {
6751 return {}
6753 set id $arcend($a)
6754 if {[info exists idtags($id)]} {
6755 return $id
6758 if {[info exists cached_atags($id)]} {
6759 return $cached_atags($id)
6762 set origid $id
6763 set todo [list $id]
6764 set queued($id) 1
6765 set taglist {}
6766 set nc 1
6767 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6768 set id [lindex $todo $i]
6769 set done($id) 1
6770 set td [info exists hastaggeddescendent($id)]
6771 if {!$td} {
6772 incr nc -1
6774 # ignore tags on starting node
6775 if {!$td && $i > 0} {
6776 if {[info exists idtags($id)]} {
6777 set tagloc($id) $id
6778 set td 1
6779 } elseif {[info exists cached_atags($id)]} {
6780 set tagloc($id) $cached_atags($id)
6781 set td 1
6784 foreach a $arcout($id) {
6785 if {!$td && $arctags($a) ne {}} {
6786 validate_arctags $a
6787 if {$arctags($a) ne {}} {
6788 lappend tagloc($id) [lindex $arctags($a) 0]
6791 if {![info exists arcend($a)]} continue
6792 set d $arcend($a)
6793 if {$td || $arctags($a) ne {}} {
6794 set tomark [list $d]
6795 for {set j 0} {$j < [llength $tomark]} {incr j} {
6796 set dd [lindex $tomark $j]
6797 if {![info exists hastaggeddescendent($dd)]} {
6798 if {[info exists done($dd)]} {
6799 foreach b $arcout($dd) {
6800 if {[info exists arcend($b)]} {
6801 lappend tomark $arcend($b)
6804 if {[info exists tagloc($dd)]} {
6805 unset tagloc($dd)
6807 } elseif {[info exists queued($dd)]} {
6808 incr nc -1
6810 set hastaggeddescendent($dd) 1
6814 if {![info exists queued($d)]} {
6815 lappend todo $d
6816 set queued($d) 1
6817 if {![info exists hastaggeddescendent($d)]} {
6818 incr nc
6823 set t2 [clock clicks -milliseconds]
6824 set loopix $i
6825 set tags {}
6826 foreach id [array names tagloc] {
6827 if {![info exists hastaggeddescendent($id)]} {
6828 foreach t $tagloc($id) {
6829 if {[lsearch -exact $tags $t] < 0} {
6830 lappend tags $t
6836 # remove tags that are ancestors of other tags
6837 for {set i 0} {$i < [llength $tags]} {incr i} {
6838 set a [lindex $tags $i]
6839 for {set j 0} {$j < $i} {incr j} {
6840 set b [lindex $tags $j]
6841 set r [anc_or_desc $a $b]
6842 if {$r == -1} {
6843 set tags [lreplace $tags $j $j]
6844 incr j -1
6845 incr i -1
6846 } elseif {$r == 1} {
6847 set tags [lreplace $tags $i $i]
6848 incr i -1
6849 break
6854 if {[array names growing] ne {}} {
6855 # graph isn't finished, need to check if any tag could get
6856 # eclipsed by another tag coming later. Simply ignore any
6857 # tags that could later get eclipsed.
6858 set ctags {}
6859 foreach t $tags {
6860 if {[is_certain $origid $t]} {
6861 lappend ctags $t
6864 if {$tags eq $ctags} {
6865 set cached_atags($origid) $tags
6866 } else {
6867 set tags $ctags
6869 } else {
6870 set cached_atags($origid) $tags
6872 set t3 [clock clicks -milliseconds]
6873 if {0 && $t3 - $t1 >= 100} {
6874 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6875 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6877 return $tags
6880 # Return the list of IDs that have heads that are descendents of id,
6881 # including id itself if it has a head.
6882 proc descheads {id} {
6883 global arcnos arcstart arcids archeads idheads cached_dheads
6884 global allparents
6886 if {![info exists allparents($id)]} {
6887 return {}
6889 set aret {}
6890 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6891 # part-way along an arc; check it first
6892 set a [lindex $arcnos($id) 0]
6893 if {$archeads($a) ne {}} {
6894 validate_archeads $a
6895 set i [lsearch -exact $arcids($a) $id]
6896 foreach t $archeads($a) {
6897 set j [lsearch -exact $arcids($a) $t]
6898 if {$j > $i} break
6899 lappend aret $t
6902 set id $arcstart($a)
6904 set origid $id
6905 set todo [list $id]
6906 set seen($id) 1
6907 set ret {}
6908 for {set i 0} {$i < [llength $todo]} {incr i} {
6909 set id [lindex $todo $i]
6910 if {[info exists cached_dheads($id)]} {
6911 set ret [concat $ret $cached_dheads($id)]
6912 } else {
6913 if {[info exists idheads($id)]} {
6914 lappend ret $id
6916 foreach a $arcnos($id) {
6917 if {$archeads($a) ne {}} {
6918 validate_archeads $a
6919 if {$archeads($a) ne {}} {
6920 set ret [concat $ret $archeads($a)]
6923 set d $arcstart($a)
6924 if {![info exists seen($d)]} {
6925 lappend todo $d
6926 set seen($d) 1
6931 set ret [lsort -unique $ret]
6932 set cached_dheads($origid) $ret
6933 return [concat $ret $aret]
6936 proc addedtag {id} {
6937 global arcnos arcout cached_dtags cached_atags
6939 if {![info exists arcnos($id)]} return
6940 if {![info exists arcout($id)]} {
6941 recalcarc [lindex $arcnos($id) 0]
6943 catch {unset cached_dtags}
6944 catch {unset cached_atags}
6947 proc addedhead {hid head} {
6948 global arcnos arcout cached_dheads
6950 if {![info exists arcnos($hid)]} return
6951 if {![info exists arcout($hid)]} {
6952 recalcarc [lindex $arcnos($hid) 0]
6954 catch {unset cached_dheads}
6957 proc removedhead {hid head} {
6958 global cached_dheads
6960 catch {unset cached_dheads}
6963 proc movedhead {hid head} {
6964 global arcnos arcout cached_dheads
6966 if {![info exists arcnos($hid)]} return
6967 if {![info exists arcout($hid)]} {
6968 recalcarc [lindex $arcnos($hid) 0]
6970 catch {unset cached_dheads}
6973 proc changedrefs {} {
6974 global cached_dheads cached_dtags cached_atags
6975 global arctags archeads arcnos arcout idheads idtags
6977 foreach id [concat [array names idheads] [array names idtags]] {
6978 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6979 set a [lindex $arcnos($id) 0]
6980 if {![info exists donearc($a)]} {
6981 recalcarc $a
6982 set donearc($a) 1
6986 catch {unset cached_dtags}
6987 catch {unset cached_atags}
6988 catch {unset cached_dheads}
6991 proc rereadrefs {} {
6992 global idtags idheads idotherrefs mainhead
6994 set refids [concat [array names idtags] \
6995 [array names idheads] [array names idotherrefs]]
6996 foreach id $refids {
6997 if {![info exists ref($id)]} {
6998 set ref($id) [listrefs $id]
7001 set oldmainhead $mainhead
7002 readrefs
7003 changedrefs
7004 set refids [lsort -unique [concat $refids [array names idtags] \
7005 [array names idheads] [array names idotherrefs]]]
7006 foreach id $refids {
7007 set v [listrefs $id]
7008 if {![info exists ref($id)] || $ref($id) != $v ||
7009 ($id eq $oldmainhead && $id ne $mainhead) ||
7010 ($id eq $mainhead && $id ne $oldmainhead)} {
7011 redrawtags $id
7016 proc listrefs {id} {
7017 global idtags idheads idotherrefs
7019 set x {}
7020 if {[info exists idtags($id)]} {
7021 set x $idtags($id)
7023 set y {}
7024 if {[info exists idheads($id)]} {
7025 set y $idheads($id)
7027 set z {}
7028 if {[info exists idotherrefs($id)]} {
7029 set z $idotherrefs($id)
7031 return [list $x $y $z]
7034 proc showtag {tag isnew} {
7035 global ctext tagcontents tagids linknum tagobjid
7037 if {$isnew} {
7038 addtohistory [list showtag $tag 0]
7040 $ctext conf -state normal
7041 clear_ctext
7042 set linknum 0
7043 if {![info exists tagcontents($tag)]} {
7044 catch {
7045 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7048 if {[info exists tagcontents($tag)]} {
7049 set text $tagcontents($tag)
7050 } else {
7051 set text "Tag: $tag\nId: $tagids($tag)"
7053 appendwithlinks $text {}
7054 $ctext conf -state disabled
7055 init_flist {}
7058 proc doquit {} {
7059 global stopped
7060 set stopped 100
7061 savestuff .
7062 destroy .
7065 proc doprefs {} {
7066 global maxwidth maxgraphpct diffopts
7067 global oldprefs prefstop showneartags showlocalchanges
7068 global bgcolor fgcolor ctext diffcolors selectbgcolor
7069 global uifont tabstop
7071 set top .gitkprefs
7072 set prefstop $top
7073 if {[winfo exists $top]} {
7074 raise $top
7075 return
7077 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7078 set oldprefs($v) [set $v]
7080 toplevel $top
7081 wm title $top "Gitk preferences"
7082 label $top.ldisp -text "Commit list display options"
7083 $top.ldisp configure -font $uifont
7084 grid $top.ldisp - -sticky w -pady 10
7085 label $top.spacer -text " "
7086 label $top.maxwidthl -text "Maximum graph width (lines)" \
7087 -font optionfont
7088 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7089 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7090 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7091 -font optionfont
7092 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7093 grid x $top.maxpctl $top.maxpct -sticky w
7094 frame $top.showlocal
7095 label $top.showlocal.l -text "Show local changes" -font optionfont
7096 checkbutton $top.showlocal.b -variable showlocalchanges
7097 pack $top.showlocal.b $top.showlocal.l -side left
7098 grid x $top.showlocal -sticky w
7100 label $top.ddisp -text "Diff display options"
7101 $top.ddisp configure -font $uifont
7102 grid $top.ddisp - -sticky w -pady 10
7103 label $top.diffoptl -text "Options for diff program" \
7104 -font optionfont
7105 entry $top.diffopt -width 20 -textvariable diffopts
7106 grid x $top.diffoptl $top.diffopt -sticky w
7107 frame $top.ntag
7108 label $top.ntag.l -text "Display nearby tags" -font optionfont
7109 checkbutton $top.ntag.b -variable showneartags
7110 pack $top.ntag.b $top.ntag.l -side left
7111 grid x $top.ntag -sticky w
7112 label $top.tabstopl -text "tabstop" -font optionfont
7113 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7114 grid x $top.tabstopl $top.tabstop -sticky w
7116 label $top.cdisp -text "Colors: press to choose"
7117 $top.cdisp configure -font $uifont
7118 grid $top.cdisp - -sticky w -pady 10
7119 label $top.bg -padx 40 -relief sunk -background $bgcolor
7120 button $top.bgbut -text "Background" -font optionfont \
7121 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7122 grid x $top.bgbut $top.bg -sticky w
7123 label $top.fg -padx 40 -relief sunk -background $fgcolor
7124 button $top.fgbut -text "Foreground" -font optionfont \
7125 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7126 grid x $top.fgbut $top.fg -sticky w
7127 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7128 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7129 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7130 [list $ctext tag conf d0 -foreground]]
7131 grid x $top.diffoldbut $top.diffold -sticky w
7132 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7133 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7134 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7135 [list $ctext tag conf d1 -foreground]]
7136 grid x $top.diffnewbut $top.diffnew -sticky w
7137 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7138 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7139 -command [list choosecolor diffcolors 2 $top.hunksep \
7140 "diff hunk header" \
7141 [list $ctext tag conf hunksep -foreground]]
7142 grid x $top.hunksepbut $top.hunksep -sticky w
7143 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7144 button $top.selbgbut -text "Select bg" -font optionfont \
7145 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7146 grid x $top.selbgbut $top.selbgsep -sticky w
7148 frame $top.buts
7149 button $top.buts.ok -text "OK" -command prefsok -default active
7150 $top.buts.ok configure -font $uifont
7151 button $top.buts.can -text "Cancel" -command prefscan -default normal
7152 $top.buts.can configure -font $uifont
7153 grid $top.buts.ok $top.buts.can
7154 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7155 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7156 grid $top.buts - - -pady 10 -sticky ew
7157 bind $top <Visibility> "focus $top.buts.ok"
7160 proc choosecolor {v vi w x cmd} {
7161 global $v
7163 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7164 -title "Gitk: choose color for $x"]
7165 if {$c eq {}} return
7166 $w conf -background $c
7167 lset $v $vi $c
7168 eval $cmd $c
7171 proc setselbg {c} {
7172 global bglist cflist
7173 foreach w $bglist {
7174 $w configure -selectbackground $c
7176 $cflist tag configure highlight \
7177 -background [$cflist cget -selectbackground]
7178 allcanvs itemconf secsel -fill $c
7181 proc setbg {c} {
7182 global bglist
7184 foreach w $bglist {
7185 $w conf -background $c
7189 proc setfg {c} {
7190 global fglist canv
7192 foreach w $fglist {
7193 $w conf -foreground $c
7195 allcanvs itemconf text -fill $c
7196 $canv itemconf circle -outline $c
7199 proc prefscan {} {
7200 global maxwidth maxgraphpct diffopts
7201 global oldprefs prefstop showneartags showlocalchanges
7203 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7204 set $v $oldprefs($v)
7206 catch {destroy $prefstop}
7207 unset prefstop
7210 proc prefsok {} {
7211 global maxwidth maxgraphpct
7212 global oldprefs prefstop showneartags showlocalchanges
7213 global charspc ctext tabstop
7215 catch {destroy $prefstop}
7216 unset prefstop
7217 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7218 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7219 if {$showlocalchanges} {
7220 doshowlocalchanges
7221 } else {
7222 dohidelocalchanges
7225 if {$maxwidth != $oldprefs(maxwidth)
7226 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7227 redisplay
7228 } elseif {$showneartags != $oldprefs(showneartags)} {
7229 reselectline
7233 proc formatdate {d} {
7234 if {$d ne {}} {
7235 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7237 return $d
7240 # This list of encoding names and aliases is distilled from
7241 # http://www.iana.org/assignments/character-sets.
7242 # Not all of them are supported by Tcl.
7243 set encoding_aliases {
7244 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7245 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7246 { ISO-10646-UTF-1 csISO10646UTF1 }
7247 { ISO_646.basic:1983 ref csISO646basic1983 }
7248 { INVARIANT csINVARIANT }
7249 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7250 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7251 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7252 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7253 { NATS-DANO iso-ir-9-1 csNATSDANO }
7254 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7255 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7256 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7257 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7258 { ISO-2022-KR csISO2022KR }
7259 { EUC-KR csEUCKR }
7260 { ISO-2022-JP csISO2022JP }
7261 { ISO-2022-JP-2 csISO2022JP2 }
7262 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7263 csISO13JISC6220jp }
7264 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7265 { IT iso-ir-15 ISO646-IT csISO15Italian }
7266 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7267 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7268 { greek7-old iso-ir-18 csISO18Greek7Old }
7269 { latin-greek iso-ir-19 csISO19LatinGreek }
7270 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7271 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7272 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7273 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7274 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7275 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7276 { INIS iso-ir-49 csISO49INIS }
7277 { INIS-8 iso-ir-50 csISO50INIS8 }
7278 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7279 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7280 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7281 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7282 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7283 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7284 csISO60Norwegian1 }
7285 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7286 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7287 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7288 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7289 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7290 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7291 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7292 { greek7 iso-ir-88 csISO88Greek7 }
7293 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7294 { iso-ir-90 csISO90 }
7295 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7296 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7297 csISO92JISC62991984b }
7298 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7299 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7300 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7301 csISO95JIS62291984handadd }
7302 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7303 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7304 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7305 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7306 CP819 csISOLatin1 }
7307 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7308 { T.61-7bit iso-ir-102 csISO102T617bit }
7309 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7310 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7311 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7312 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7313 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7314 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7315 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7316 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7317 arabic csISOLatinArabic }
7318 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7319 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7320 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7321 greek greek8 csISOLatinGreek }
7322 { T.101-G2 iso-ir-128 csISO128T101G2 }
7323 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7324 csISOLatinHebrew }
7325 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7326 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7327 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7328 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7329 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7330 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7331 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7332 csISOLatinCyrillic }
7333 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7334 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7335 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7336 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7337 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7338 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7339 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7340 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7341 { ISO_10367-box iso-ir-155 csISO10367Box }
7342 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7343 { latin-lap lap iso-ir-158 csISO158Lap }
7344 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7345 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7346 { us-dk csUSDK }
7347 { dk-us csDKUS }
7348 { JIS_X0201 X0201 csHalfWidthKatakana }
7349 { KSC5636 ISO646-KR csKSC5636 }
7350 { ISO-10646-UCS-2 csUnicode }
7351 { ISO-10646-UCS-4 csUCS4 }
7352 { DEC-MCS dec csDECMCS }
7353 { hp-roman8 roman8 r8 csHPRoman8 }
7354 { macintosh mac csMacintosh }
7355 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7356 csIBM037 }
7357 { IBM038 EBCDIC-INT cp038 csIBM038 }
7358 { IBM273 CP273 csIBM273 }
7359 { IBM274 EBCDIC-BE CP274 csIBM274 }
7360 { IBM275 EBCDIC-BR cp275 csIBM275 }
7361 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7362 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7363 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7364 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7365 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7366 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7367 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7368 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7369 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7370 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7371 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7372 { IBM437 cp437 437 csPC8CodePage437 }
7373 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7374 { IBM775 cp775 csPC775Baltic }
7375 { IBM850 cp850 850 csPC850Multilingual }
7376 { IBM851 cp851 851 csIBM851 }
7377 { IBM852 cp852 852 csPCp852 }
7378 { IBM855 cp855 855 csIBM855 }
7379 { IBM857 cp857 857 csIBM857 }
7380 { IBM860 cp860 860 csIBM860 }
7381 { IBM861 cp861 861 cp-is csIBM861 }
7382 { IBM862 cp862 862 csPC862LatinHebrew }
7383 { IBM863 cp863 863 csIBM863 }
7384 { IBM864 cp864 csIBM864 }
7385 { IBM865 cp865 865 csIBM865 }
7386 { IBM866 cp866 866 csIBM866 }
7387 { IBM868 CP868 cp-ar csIBM868 }
7388 { IBM869 cp869 869 cp-gr csIBM869 }
7389 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7390 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7391 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7392 { IBM891 cp891 csIBM891 }
7393 { IBM903 cp903 csIBM903 }
7394 { IBM904 cp904 904 csIBBM904 }
7395 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7396 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7397 { IBM1026 CP1026 csIBM1026 }
7398 { EBCDIC-AT-DE csIBMEBCDICATDE }
7399 { EBCDIC-AT-DE-A csEBCDICATDEA }
7400 { EBCDIC-CA-FR csEBCDICCAFR }
7401 { EBCDIC-DK-NO csEBCDICDKNO }
7402 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7403 { EBCDIC-FI-SE csEBCDICFISE }
7404 { EBCDIC-FI-SE-A csEBCDICFISEA }
7405 { EBCDIC-FR csEBCDICFR }
7406 { EBCDIC-IT csEBCDICIT }
7407 { EBCDIC-PT csEBCDICPT }
7408 { EBCDIC-ES csEBCDICES }
7409 { EBCDIC-ES-A csEBCDICESA }
7410 { EBCDIC-ES-S csEBCDICESS }
7411 { EBCDIC-UK csEBCDICUK }
7412 { EBCDIC-US csEBCDICUS }
7413 { UNKNOWN-8BIT csUnknown8BiT }
7414 { MNEMONIC csMnemonic }
7415 { MNEM csMnem }
7416 { VISCII csVISCII }
7417 { VIQR csVIQR }
7418 { KOI8-R csKOI8R }
7419 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7420 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7421 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7422 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7423 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7424 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7425 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7426 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7427 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7428 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7429 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7430 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7431 { IBM1047 IBM-1047 }
7432 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7433 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7434 { UNICODE-1-1 csUnicode11 }
7435 { CESU-8 csCESU-8 }
7436 { BOCU-1 csBOCU-1 }
7437 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7438 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7439 l8 }
7440 { ISO-8859-15 ISO_8859-15 Latin-9 }
7441 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7442 { GBK CP936 MS936 windows-936 }
7443 { JIS_Encoding csJISEncoding }
7444 { Shift_JIS MS_Kanji csShiftJIS }
7445 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7446 EUC-JP }
7447 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7448 { ISO-10646-UCS-Basic csUnicodeASCII }
7449 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7450 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7451 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7452 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7453 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7454 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7455 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7456 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7457 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7458 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7459 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7460 { Ventura-US csVenturaUS }
7461 { Ventura-International csVenturaInternational }
7462 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7463 { PC8-Turkish csPC8Turkish }
7464 { IBM-Symbols csIBMSymbols }
7465 { IBM-Thai csIBMThai }
7466 { HP-Legal csHPLegal }
7467 { HP-Pi-font csHPPiFont }
7468 { HP-Math8 csHPMath8 }
7469 { Adobe-Symbol-Encoding csHPPSMath }
7470 { HP-DeskTop csHPDesktop }
7471 { Ventura-Math csVenturaMath }
7472 { Microsoft-Publishing csMicrosoftPublishing }
7473 { Windows-31J csWindows31J }
7474 { GB2312 csGB2312 }
7475 { Big5 csBig5 }
7478 proc tcl_encoding {enc} {
7479 global encoding_aliases
7480 set names [encoding names]
7481 set lcnames [string tolower $names]
7482 set enc [string tolower $enc]
7483 set i [lsearch -exact $lcnames $enc]
7484 if {$i < 0} {
7485 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7486 if {[regsub {^iso[-_]} $enc iso encx]} {
7487 set i [lsearch -exact $lcnames $encx]
7490 if {$i < 0} {
7491 foreach l $encoding_aliases {
7492 set ll [string tolower $l]
7493 if {[lsearch -exact $ll $enc] < 0} continue
7494 # look through the aliases for one that tcl knows about
7495 foreach e $ll {
7496 set i [lsearch -exact $lcnames $e]
7497 if {$i < 0} {
7498 if {[regsub {^iso[-_]} $e iso ex]} {
7499 set i [lsearch -exact $lcnames $ex]
7502 if {$i >= 0} break
7504 break
7507 if {$i >= 0} {
7508 return [lindex $names $i]
7510 return {}
7513 # defaults...
7514 set datemode 0
7515 set diffopts "-U 5 -p"
7516 set wrcomcmd "git diff-tree --stdin -p --pretty"
7518 set gitencoding {}
7519 catch {
7520 set gitencoding [exec git config --get i18n.commitencoding]
7522 if {$gitencoding == ""} {
7523 set gitencoding "utf-8"
7525 set tclencoding [tcl_encoding $gitencoding]
7526 if {$tclencoding == {}} {
7527 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7530 set mainfont {Helvetica 9}
7531 set textfont {Courier 9}
7532 set uifont {Helvetica 9 bold}
7533 set tabstop 8
7534 set findmergefiles 0
7535 set maxgraphpct 50
7536 set maxwidth 16
7537 set revlistorder 0
7538 set fastdate 0
7539 set uparrowlen 7
7540 set downarrowlen 7
7541 set mingaplen 30
7542 set cmitmode "patch"
7543 set wrapcomment "none"
7544 set showneartags 1
7545 set maxrefs 20
7546 set maxlinelen 200
7547 set showlocalchanges 1
7549 set colors {green red blue magenta darkgrey brown orange}
7550 set bgcolor white
7551 set fgcolor black
7552 set diffcolors {red "#00a000" blue}
7553 set selectbgcolor gray85
7555 catch {source ~/.gitk}
7557 font create optionfont -family sans-serif -size -12
7559 # check that we can find a .git directory somewhere...
7560 set gitdir [gitdir]
7561 if {![file isdirectory $gitdir]} {
7562 show_error {} . "Cannot find the git directory \"$gitdir\"."
7563 exit 1
7566 set revtreeargs {}
7567 set cmdline_files {}
7568 set i 0
7569 foreach arg $argv {
7570 switch -- $arg {
7571 "" { }
7572 "-d" { set datemode 1 }
7573 "--" {
7574 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7575 break
7577 default {
7578 lappend revtreeargs $arg
7581 incr i
7584 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7585 # no -- on command line, but some arguments (other than -d)
7586 if {[catch {
7587 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7588 set cmdline_files [split $f "\n"]
7589 set n [llength $cmdline_files]
7590 set revtreeargs [lrange $revtreeargs 0 end-$n]
7591 # Unfortunately git rev-parse doesn't produce an error when
7592 # something is both a revision and a filename. To be consistent
7593 # with git log and git rev-list, check revtreeargs for filenames.
7594 foreach arg $revtreeargs {
7595 if {[file exists $arg]} {
7596 show_error {} . "Ambiguous argument '$arg': both revision\
7597 and filename"
7598 exit 1
7601 } err]} {
7602 # unfortunately we get both stdout and stderr in $err,
7603 # so look for "fatal:".
7604 set i [string first "fatal:" $err]
7605 if {$i > 0} {
7606 set err [string range $err [expr {$i + 6}] end]
7608 show_error {} . "Bad arguments to gitk:\n$err"
7609 exit 1
7613 set nullid "0000000000000000000000000000000000000000"
7614 set nullid2 "0000000000000000000000000000000000000001"
7617 set runq {}
7618 set history {}
7619 set historyindex 0
7620 set fh_serial 0
7621 set nhl_names {}
7622 set highlight_paths {}
7623 set searchdirn -forwards
7624 set boldrows {}
7625 set boldnamerows {}
7626 set diffelide {0 0}
7627 set markingmatches 0
7629 set optim_delay 16
7631 set nextviewnum 1
7632 set curview 0
7633 set selectedview 0
7634 set selectedhlview None
7635 set viewfiles(0) {}
7636 set viewperm(0) 0
7637 set viewargs(0) {}
7639 set cmdlineok 0
7640 set stopped 0
7641 set stuffsaved 0
7642 set patchnum 0
7643 set lookingforhead 0
7644 set localirow -1
7645 set localfrow -1
7646 set lserial 0
7647 setcoords
7648 makewindow
7649 wm title . "[file tail $argv0]: [file tail [pwd]]"
7650 readrefs
7652 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7653 # create a view for the files/dirs specified on the command line
7654 set curview 1
7655 set selectedview 1
7656 set nextviewnum 2
7657 set viewname(1) "Command line"
7658 set viewfiles(1) $cmdline_files
7659 set viewargs(1) $revtreeargs
7660 set viewperm(1) 0
7661 addviewmenu 1
7662 .bar.view entryconf Edit* -state normal
7663 .bar.view entryconf Delete* -state normal
7666 if {[info exists permviews]} {
7667 foreach v $permviews {
7668 set n $nextviewnum
7669 incr nextviewnum
7670 set viewname($n) [lindex $v 0]
7671 set viewfiles($n) [lindex $v 1]
7672 set viewargs($n) [lindex $v 2]
7673 set viewperm($n) 1
7674 addviewmenu $n
7677 getcommits