Work around failures due to bogus quoting of ^ and {}.
[git/platforms.git] / gitk
blob43d88caa7a87a1641494b50709712808c9b9d5ef
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
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 nullid commitidx phase
266 global numcommits startmsecs
268 if {[info exists pending_select]} {
269 set row [expr {[lindex $displayorder 0] eq $nullid}]
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 # update things for a head moved to a child of its previous location
441 proc movehead {id name} {
442 global headids idheads
444 removehead $headids($name) $name
445 set headids($name) $id
446 lappend idheads($id) $name
449 # update things when a head has been removed
450 proc removehead {id name} {
451 global headids idheads
453 if {$idheads($id) eq $name} {
454 unset idheads($id)
455 } else {
456 set i [lsearch -exact $idheads($id) $name]
457 if {$i >= 0} {
458 set idheads($id) [lreplace $idheads($id) $i $i]
461 unset headids($name)
464 proc show_error {w top msg} {
465 message $w.m -text $msg -justify center -aspect 400
466 pack $w.m -side top -fill x -padx 20 -pady 20
467 button $w.ok -text OK -command "destroy $top"
468 pack $w.ok -side bottom -fill x
469 bind $top <Visibility> "grab $top; focus $top"
470 bind $top <Key-Return> "destroy $top"
471 tkwait window $top
474 proc error_popup msg {
475 set w .error
476 toplevel $w
477 wm transient $w .
478 show_error $w $w $msg
481 proc confirm_popup msg {
482 global confirm_ok
483 set confirm_ok 0
484 set w .confirm
485 toplevel $w
486 wm transient $w .
487 message $w.m -text $msg -justify center -aspect 400
488 pack $w.m -side top -fill x -padx 20 -pady 20
489 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
490 pack $w.ok -side left -fill x
491 button $w.cancel -text Cancel -command "destroy $w"
492 pack $w.cancel -side right -fill x
493 bind $w <Visibility> "grab $w; focus $w"
494 tkwait window $w
495 return $confirm_ok
498 proc makewindow {} {
499 global canv canv2 canv3 linespc charspc ctext cflist
500 global textfont mainfont uifont tabstop
501 global findtype findtypemenu findloc findstring fstring geometry
502 global entries sha1entry sha1string sha1but
503 global maincursor textcursor curtextcursor
504 global rowctxmenu fakerowmenu mergemax wrapcomment
505 global highlight_files gdttype
506 global searchstring sstring
507 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
508 global headctxmenu
510 menu .bar
511 .bar add cascade -label "File" -menu .bar.file
512 .bar configure -font $uifont
513 menu .bar.file
514 .bar.file add command -label "Update" -command updatecommits
515 .bar.file add command -label "Reread references" -command rereadrefs
516 .bar.file add command -label "Quit" -command doquit
517 .bar.file configure -font $uifont
518 menu .bar.edit
519 .bar add cascade -label "Edit" -menu .bar.edit
520 .bar.edit add command -label "Preferences" -command doprefs
521 .bar.edit configure -font $uifont
523 menu .bar.view -font $uifont
524 .bar add cascade -label "View" -menu .bar.view
525 .bar.view add command -label "New view..." -command {newview 0}
526 .bar.view add command -label "Edit view..." -command editview \
527 -state disabled
528 .bar.view add command -label "Delete view" -command delview -state disabled
529 .bar.view add separator
530 .bar.view add radiobutton -label "All files" -command {showview 0} \
531 -variable selectedview -value 0
533 menu .bar.help
534 .bar add cascade -label "Help" -menu .bar.help
535 .bar.help add command -label "About gitk" -command about
536 .bar.help add command -label "Key bindings" -command keys
537 .bar.help configure -font $uifont
538 . configure -menu .bar
540 # the gui has upper and lower half, parts of a paned window.
541 panedwindow .ctop -orient vertical
543 # possibly use assumed geometry
544 if {![info exists geometry(pwsash0)]} {
545 set geometry(topheight) [expr {15 * $linespc}]
546 set geometry(topwidth) [expr {80 * $charspc}]
547 set geometry(botheight) [expr {15 * $linespc}]
548 set geometry(botwidth) [expr {50 * $charspc}]
549 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
550 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
553 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
554 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
555 frame .tf.histframe
556 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
558 # create three canvases
559 set cscroll .tf.histframe.csb
560 set canv .tf.histframe.pwclist.canv
561 canvas $canv \
562 -selectbackground $selectbgcolor \
563 -background $bgcolor -bd 0 \
564 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
565 .tf.histframe.pwclist add $canv
566 set canv2 .tf.histframe.pwclist.canv2
567 canvas $canv2 \
568 -selectbackground $selectbgcolor \
569 -background $bgcolor -bd 0 -yscrollincr $linespc
570 .tf.histframe.pwclist add $canv2
571 set canv3 .tf.histframe.pwclist.canv3
572 canvas $canv3 \
573 -selectbackground $selectbgcolor \
574 -background $bgcolor -bd 0 -yscrollincr $linespc
575 .tf.histframe.pwclist add $canv3
576 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
577 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
579 # a scroll bar to rule them
580 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
581 pack $cscroll -side right -fill y
582 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
583 lappend bglist $canv $canv2 $canv3
584 pack .tf.histframe.pwclist -fill both -expand 1 -side left
586 # we have two button bars at bottom of top frame. Bar 1
587 frame .tf.bar
588 frame .tf.lbar -height 15
590 set sha1entry .tf.bar.sha1
591 set entries $sha1entry
592 set sha1but .tf.bar.sha1label
593 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
594 -command gotocommit -width 8 -font $uifont
595 $sha1but conf -disabledforeground [$sha1but cget -foreground]
596 pack .tf.bar.sha1label -side left
597 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
598 trace add variable sha1string write sha1change
599 pack $sha1entry -side left -pady 2
601 image create bitmap bm-left -data {
602 #define left_width 16
603 #define left_height 16
604 static unsigned char left_bits[] = {
605 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
606 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
607 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
609 image create bitmap bm-right -data {
610 #define right_width 16
611 #define right_height 16
612 static unsigned char right_bits[] = {
613 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
614 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
615 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
617 button .tf.bar.leftbut -image bm-left -command goback \
618 -state disabled -width 26
619 pack .tf.bar.leftbut -side left -fill y
620 button .tf.bar.rightbut -image bm-right -command goforw \
621 -state disabled -width 26
622 pack .tf.bar.rightbut -side left -fill y
624 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
625 pack .tf.bar.findbut -side left
626 set findstring {}
627 set fstring .tf.bar.findstring
628 lappend entries $fstring
629 entry $fstring -width 30 -font $textfont -textvariable findstring
630 trace add variable findstring write find_change
631 pack $fstring -side left -expand 1 -fill x -in .tf.bar
632 set findtype Exact
633 set findtypemenu [tk_optionMenu .tf.bar.findtype \
634 findtype Exact IgnCase Regexp]
635 trace add variable findtype write find_change
636 .tf.bar.findtype configure -font $uifont
637 .tf.bar.findtype.menu configure -font $uifont
638 set findloc "All fields"
639 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
640 Comments Author Committer
641 trace add variable findloc write find_change
642 .tf.bar.findloc configure -font $uifont
643 .tf.bar.findloc.menu configure -font $uifont
644 pack .tf.bar.findloc -side right
645 pack .tf.bar.findtype -side right
647 # build up the bottom bar of upper window
648 label .tf.lbar.flabel -text "Highlight: Commits " \
649 -font $uifont
650 pack .tf.lbar.flabel -side left -fill y
651 set gdttype "touching paths:"
652 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
653 "adding/removing string:"]
654 trace add variable gdttype write hfiles_change
655 $gm conf -font $uifont
656 .tf.lbar.gdttype conf -font $uifont
657 pack .tf.lbar.gdttype -side left -fill y
658 entry .tf.lbar.fent -width 25 -font $textfont \
659 -textvariable highlight_files
660 trace add variable highlight_files write hfiles_change
661 lappend entries .tf.lbar.fent
662 pack .tf.lbar.fent -side left -fill x -expand 1
663 label .tf.lbar.vlabel -text " OR in view" -font $uifont
664 pack .tf.lbar.vlabel -side left -fill y
665 global viewhlmenu selectedhlview
666 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
667 $viewhlmenu entryconf None -command delvhighlight
668 $viewhlmenu conf -font $uifont
669 .tf.lbar.vhl conf -font $uifont
670 pack .tf.lbar.vhl -side left -fill y
671 label .tf.lbar.rlabel -text " OR " -font $uifont
672 pack .tf.lbar.rlabel -side left -fill y
673 global highlight_related
674 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
675 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
676 $m conf -font $uifont
677 .tf.lbar.relm conf -font $uifont
678 trace add variable highlight_related write vrel_change
679 pack .tf.lbar.relm -side left -fill y
681 # Finish putting the upper half of the viewer together
682 pack .tf.lbar -in .tf -side bottom -fill x
683 pack .tf.bar -in .tf -side bottom -fill x
684 pack .tf.histframe -fill both -side top -expand 1
685 .ctop add .tf
686 .ctop paneconfigure .tf -height $geometry(topheight)
687 .ctop paneconfigure .tf -width $geometry(topwidth)
689 # now build up the bottom
690 panedwindow .pwbottom -orient horizontal
692 # lower left, a text box over search bar, scroll bar to the right
693 # if we know window height, then that will set the lower text height, otherwise
694 # we set lower text height which will drive window height
695 if {[info exists geometry(main)]} {
696 frame .bleft -width $geometry(botwidth)
697 } else {
698 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
700 frame .bleft.top
701 frame .bleft.mid
703 button .bleft.top.search -text "Search" -command dosearch \
704 -font $uifont
705 pack .bleft.top.search -side left -padx 5
706 set sstring .bleft.top.sstring
707 entry $sstring -width 20 -font $textfont -textvariable searchstring
708 lappend entries $sstring
709 trace add variable searchstring write incrsearch
710 pack $sstring -side left -expand 1 -fill x
711 radiobutton .bleft.mid.diff -text "Diff" \
712 -command changediffdisp -variable diffelide -value {0 0}
713 radiobutton .bleft.mid.old -text "Old version" \
714 -command changediffdisp -variable diffelide -value {0 1}
715 radiobutton .bleft.mid.new -text "New version" \
716 -command changediffdisp -variable diffelide -value {1 0}
717 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
718 set ctext .bleft.ctext
719 text $ctext -background $bgcolor -foreground $fgcolor \
720 -tabs "[expr {$tabstop * $charspc}]" \
721 -state disabled -font $textfont \
722 -yscrollcommand scrolltext -wrap none
723 scrollbar .bleft.sb -command "$ctext yview"
724 pack .bleft.top -side top -fill x
725 pack .bleft.mid -side top -fill x
726 pack .bleft.sb -side right -fill y
727 pack $ctext -side left -fill both -expand 1
728 lappend bglist $ctext
729 lappend fglist $ctext
731 $ctext tag conf comment -wrap $wrapcomment
732 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
733 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
734 $ctext tag conf d0 -fore [lindex $diffcolors 0]
735 $ctext tag conf d1 -fore [lindex $diffcolors 1]
736 $ctext tag conf m0 -fore red
737 $ctext tag conf m1 -fore blue
738 $ctext tag conf m2 -fore green
739 $ctext tag conf m3 -fore purple
740 $ctext tag conf m4 -fore brown
741 $ctext tag conf m5 -fore "#009090"
742 $ctext tag conf m6 -fore magenta
743 $ctext tag conf m7 -fore "#808000"
744 $ctext tag conf m8 -fore "#009000"
745 $ctext tag conf m9 -fore "#ff0080"
746 $ctext tag conf m10 -fore cyan
747 $ctext tag conf m11 -fore "#b07070"
748 $ctext tag conf m12 -fore "#70b0f0"
749 $ctext tag conf m13 -fore "#70f0b0"
750 $ctext tag conf m14 -fore "#f0b070"
751 $ctext tag conf m15 -fore "#ff70b0"
752 $ctext tag conf mmax -fore darkgrey
753 set mergemax 16
754 $ctext tag conf mresult -font [concat $textfont bold]
755 $ctext tag conf msep -font [concat $textfont bold]
756 $ctext tag conf found -back yellow
758 .pwbottom add .bleft
759 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
761 # lower right
762 frame .bright
763 frame .bright.mode
764 radiobutton .bright.mode.patch -text "Patch" \
765 -command reselectline -variable cmitmode -value "patch"
766 .bright.mode.patch configure -font $uifont
767 radiobutton .bright.mode.tree -text "Tree" \
768 -command reselectline -variable cmitmode -value "tree"
769 .bright.mode.tree configure -font $uifont
770 grid .bright.mode.patch .bright.mode.tree -sticky ew
771 pack .bright.mode -side top -fill x
772 set cflist .bright.cfiles
773 set indent [font measure $mainfont "nn"]
774 text $cflist \
775 -selectbackground $selectbgcolor \
776 -background $bgcolor -foreground $fgcolor \
777 -font $mainfont \
778 -tabs [list $indent [expr {2 * $indent}]] \
779 -yscrollcommand ".bright.sb set" \
780 -cursor [. cget -cursor] \
781 -spacing1 1 -spacing3 1
782 lappend bglist $cflist
783 lappend fglist $cflist
784 scrollbar .bright.sb -command "$cflist yview"
785 pack .bright.sb -side right -fill y
786 pack $cflist -side left -fill both -expand 1
787 $cflist tag configure highlight \
788 -background [$cflist cget -selectbackground]
789 $cflist tag configure bold -font [concat $mainfont bold]
791 .pwbottom add .bright
792 .ctop add .pwbottom
794 # restore window position if known
795 if {[info exists geometry(main)]} {
796 wm geometry . "$geometry(main)"
799 bind .pwbottom <Configure> {resizecdetpanes %W %w}
800 pack .ctop -fill both -expand 1
801 bindall <1> {selcanvline %W %x %y}
802 #bindall <B1-Motion> {selcanvline %W %x %y}
803 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
804 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
805 bindall <2> "canvscan mark %W %x %y"
806 bindall <B2-Motion> "canvscan dragto %W %x %y"
807 bindkey <Home> selfirstline
808 bindkey <End> sellastline
809 bind . <Key-Up> "selnextline -1"
810 bind . <Key-Down> "selnextline 1"
811 bind . <Shift-Key-Up> "next_highlight -1"
812 bind . <Shift-Key-Down> "next_highlight 1"
813 bindkey <Key-Right> "goforw"
814 bindkey <Key-Left> "goback"
815 bind . <Key-Prior> "selnextpage -1"
816 bind . <Key-Next> "selnextpage 1"
817 bind . <Control-Home> "allcanvs yview moveto 0.0"
818 bind . <Control-End> "allcanvs yview moveto 1.0"
819 bind . <Control-Key-Up> "allcanvs yview scroll -1 units"
820 bind . <Control-Key-Down> "allcanvs yview scroll 1 units"
821 bind . <Control-Key-Prior> "allcanvs yview scroll -1 pages"
822 bind . <Control-Key-Next> "allcanvs yview scroll 1 pages"
823 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
824 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
825 bindkey <Key-space> "$ctext yview scroll 1 pages"
826 bindkey p "selnextline -1"
827 bindkey n "selnextline 1"
828 bindkey z "goback"
829 bindkey x "goforw"
830 bindkey i "selnextline -1"
831 bindkey k "selnextline 1"
832 bindkey j "goback"
833 bindkey l "goforw"
834 bindkey b "$ctext yview scroll -1 pages"
835 bindkey d "$ctext yview scroll 18 units"
836 bindkey u "$ctext yview scroll -18 units"
837 bindkey / {findnext 1}
838 bindkey <Key-Return> {findnext 0}
839 bindkey ? findprev
840 bindkey f nextfile
841 bindkey <F5> updatecommits
842 bind . <Control-q> doquit
843 bind . <Control-f> dofind
844 bind . <Control-g> {findnext 0}
845 bind . <Control-r> dosearchback
846 bind . <Control-s> dosearch
847 bind . <Control-equal> {incrfont 1}
848 bind . <Control-KP_Add> {incrfont 1}
849 bind . <Control-minus> {incrfont -1}
850 bind . <Control-KP_Subtract> {incrfont -1}
851 wm protocol . WM_DELETE_WINDOW doquit
852 bind . <Button-1> "click %W"
853 bind $fstring <Key-Return> dofind
854 bind $sha1entry <Key-Return> gotocommit
855 bind $sha1entry <<PasteSelection>> clearsha1
856 bind $cflist <1> {sel_flist %W %x %y; break}
857 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
858 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
860 set maincursor [. cget -cursor]
861 set textcursor [$ctext cget -cursor]
862 set curtextcursor $textcursor
864 set rowctxmenu .rowctxmenu
865 menu $rowctxmenu -tearoff 0
866 $rowctxmenu add command -label "Diff this -> selected" \
867 -command {diffvssel 0}
868 $rowctxmenu add command -label "Diff selected -> this" \
869 -command {diffvssel 1}
870 $rowctxmenu add command -label "Make patch" -command mkpatch
871 $rowctxmenu add command -label "Create tag" -command mktag
872 $rowctxmenu add command -label "Write commit to file" -command writecommit
873 $rowctxmenu add command -label "Create new branch" -command mkbranch
874 $rowctxmenu add command -label "Cherry-pick this commit" \
875 -command cherrypick
876 $rowctxmenu add command -label "Reset HEAD branch to here" \
877 -command resethead
879 set fakerowmenu .fakerowmenu
880 menu $fakerowmenu -tearoff 0
881 $fakerowmenu add command -label "Diff this -> selected" \
882 -command {diffvssel 0}
883 $fakerowmenu add command -label "Diff selected -> this" \
884 -command {diffvssel 1}
885 $fakerowmenu add command -label "Make patch" -command mkpatch
886 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
887 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
888 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
890 set headctxmenu .headctxmenu
891 menu $headctxmenu -tearoff 0
892 $headctxmenu add command -label "Check out this branch" \
893 -command cobranch
894 $headctxmenu add command -label "Remove this branch" \
895 -command rmbranch
898 # mouse-2 makes all windows scan vertically, but only the one
899 # the cursor is in scans horizontally
900 proc canvscan {op w x y} {
901 global canv canv2 canv3
902 foreach c [list $canv $canv2 $canv3] {
903 if {$c == $w} {
904 $c scan $op $x $y
905 } else {
906 $c scan $op 0 $y
911 proc scrollcanv {cscroll f0 f1} {
912 $cscroll set $f0 $f1
913 drawfrac $f0 $f1
914 flushhighlights
917 # when we make a key binding for the toplevel, make sure
918 # it doesn't get triggered when that key is pressed in the
919 # find string entry widget.
920 proc bindkey {ev script} {
921 global entries
922 bind . $ev $script
923 set escript [bind Entry $ev]
924 if {$escript == {}} {
925 set escript [bind Entry <Key>]
927 foreach e $entries {
928 bind $e $ev "$escript; break"
932 # set the focus back to the toplevel for any click outside
933 # the entry widgets
934 proc click {w} {
935 global entries
936 foreach e $entries {
937 if {$w == $e} return
939 focus .
942 proc savestuff {w} {
943 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
944 global stuffsaved findmergefiles maxgraphpct
945 global maxwidth showneartags showlocalchanges
946 global viewname viewfiles viewargs viewperm nextviewnum
947 global cmitmode wrapcomment
948 global colors bgcolor fgcolor diffcolors selectbgcolor
950 if {$stuffsaved} return
951 if {![winfo viewable .]} return
952 catch {
953 set f [open "~/.gitk-new" w]
954 puts $f [list set mainfont $mainfont]
955 puts $f [list set textfont $textfont]
956 puts $f [list set uifont $uifont]
957 puts $f [list set tabstop $tabstop]
958 puts $f [list set findmergefiles $findmergefiles]
959 puts $f [list set maxgraphpct $maxgraphpct]
960 puts $f [list set maxwidth $maxwidth]
961 puts $f [list set cmitmode $cmitmode]
962 puts $f [list set wrapcomment $wrapcomment]
963 puts $f [list set showneartags $showneartags]
964 puts $f [list set showlocalchanges $showlocalchanges]
965 puts $f [list set bgcolor $bgcolor]
966 puts $f [list set fgcolor $fgcolor]
967 puts $f [list set colors $colors]
968 puts $f [list set diffcolors $diffcolors]
969 puts $f [list set selectbgcolor $selectbgcolor]
971 puts $f "set geometry(main) [wm geometry .]"
972 puts $f "set geometry(topwidth) [winfo width .tf]"
973 puts $f "set geometry(topheight) [winfo height .tf]"
974 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
975 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
976 puts $f "set geometry(botwidth) [winfo width .bleft]"
977 puts $f "set geometry(botheight) [winfo height .bleft]"
979 puts -nonewline $f "set permviews {"
980 for {set v 0} {$v < $nextviewnum} {incr v} {
981 if {$viewperm($v)} {
982 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
985 puts $f "}"
986 close $f
987 catch {file delete "~/.gitk"}
988 file rename -force "~/.gitk-new" "~/.gitk"
990 set stuffsaved 1
993 proc resizeclistpanes {win w} {
994 global oldwidth
995 if {[info exists oldwidth($win)]} {
996 set s0 [$win sash coord 0]
997 set s1 [$win sash coord 1]
998 if {$w < 60} {
999 set sash0 [expr {int($w/2 - 2)}]
1000 set sash1 [expr {int($w*5/6 - 2)}]
1001 } else {
1002 set factor [expr {1.0 * $w / $oldwidth($win)}]
1003 set sash0 [expr {int($factor * [lindex $s0 0])}]
1004 set sash1 [expr {int($factor * [lindex $s1 0])}]
1005 if {$sash0 < 30} {
1006 set sash0 30
1008 if {$sash1 < $sash0 + 20} {
1009 set sash1 [expr {$sash0 + 20}]
1011 if {$sash1 > $w - 10} {
1012 set sash1 [expr {$w - 10}]
1013 if {$sash0 > $sash1 - 20} {
1014 set sash0 [expr {$sash1 - 20}]
1018 $win sash place 0 $sash0 [lindex $s0 1]
1019 $win sash place 1 $sash1 [lindex $s1 1]
1021 set oldwidth($win) $w
1024 proc resizecdetpanes {win w} {
1025 global oldwidth
1026 if {[info exists oldwidth($win)]} {
1027 set s0 [$win sash coord 0]
1028 if {$w < 60} {
1029 set sash0 [expr {int($w*3/4 - 2)}]
1030 } else {
1031 set factor [expr {1.0 * $w / $oldwidth($win)}]
1032 set sash0 [expr {int($factor * [lindex $s0 0])}]
1033 if {$sash0 < 45} {
1034 set sash0 45
1036 if {$sash0 > $w - 15} {
1037 set sash0 [expr {$w - 15}]
1040 $win sash place 0 $sash0 [lindex $s0 1]
1042 set oldwidth($win) $w
1045 proc allcanvs args {
1046 global canv canv2 canv3
1047 eval $canv $args
1048 eval $canv2 $args
1049 eval $canv3 $args
1052 proc bindall {event action} {
1053 global canv canv2 canv3
1054 bind $canv $event $action
1055 bind $canv2 $event $action
1056 bind $canv3 $event $action
1059 proc about {} {
1060 global uifont
1061 set w .about
1062 if {[winfo exists $w]} {
1063 raise $w
1064 return
1066 toplevel $w
1067 wm title $w "About gitk"
1068 message $w.m -text {
1069 Gitk - a commit viewer for git
1071 Copyright © 2005-2006 Paul Mackerras
1073 Use and redistribute under the terms of the GNU General Public License} \
1074 -justify center -aspect 400 -border 2 -bg white -relief groove
1075 pack $w.m -side top -fill x -padx 2 -pady 2
1076 $w.m configure -font $uifont
1077 button $w.ok -text Close -command "destroy $w" -default active
1078 pack $w.ok -side bottom
1079 $w.ok configure -font $uifont
1080 bind $w <Visibility> "focus $w.ok"
1081 bind $w <Key-Escape> "destroy $w"
1082 bind $w <Key-Return> "destroy $w"
1085 proc keys {} {
1086 global uifont
1087 set w .keys
1088 if {[winfo exists $w]} {
1089 raise $w
1090 return
1092 toplevel $w
1093 wm title $w "Gitk key bindings"
1094 message $w.m -text {
1095 Gitk key bindings:
1097 <Ctrl-Q> Quit
1098 <Home> Move to first commit
1099 <End> Move to last commit
1100 <Up>, p, i Move up one commit
1101 <Down>, n, k Move down one commit
1102 <Left>, z, j Go back in history list
1103 <Right>, x, l Go forward in history list
1104 <PageUp> Move up one page in commit list
1105 <PageDown> Move down one page in commit list
1106 <Ctrl-Home> Scroll to top of commit list
1107 <Ctrl-End> Scroll to bottom of commit list
1108 <Ctrl-Up> Scroll commit list up one line
1109 <Ctrl-Down> Scroll commit list down one line
1110 <Ctrl-PageUp> Scroll commit list up one page
1111 <Ctrl-PageDown> Scroll commit list down one page
1112 <Shift-Up> Move to previous highlighted line
1113 <Shift-Down> Move to next highlighted line
1114 <Delete>, b Scroll diff view up one page
1115 <Backspace> Scroll diff view up one page
1116 <Space> Scroll diff view down one page
1117 u Scroll diff view up 18 lines
1118 d Scroll diff view down 18 lines
1119 <Ctrl-F> Find
1120 <Ctrl-G> Move to next find hit
1121 <Return> Move to next find hit
1122 / Move to next find hit, or redo find
1123 ? Move to previous find hit
1124 f Scroll diff view to next file
1125 <Ctrl-S> Search for next hit in diff view
1126 <Ctrl-R> Search for previous hit in diff view
1127 <Ctrl-KP+> Increase font size
1128 <Ctrl-plus> Increase font size
1129 <Ctrl-KP-> Decrease font size
1130 <Ctrl-minus> Decrease font size
1131 <F5> Update
1133 -justify left -bg white -border 2 -relief groove
1134 pack $w.m -side top -fill both -padx 2 -pady 2
1135 $w.m configure -font $uifont
1136 button $w.ok -text Close -command "destroy $w" -default active
1137 pack $w.ok -side bottom
1138 $w.ok configure -font $uifont
1139 bind $w <Visibility> "focus $w.ok"
1140 bind $w <Key-Escape> "destroy $w"
1141 bind $w <Key-Return> "destroy $w"
1144 # Procedures for manipulating the file list window at the
1145 # bottom right of the overall window.
1147 proc treeview {w l openlevs} {
1148 global treecontents treediropen treeheight treeparent treeindex
1150 set ix 0
1151 set treeindex() 0
1152 set lev 0
1153 set prefix {}
1154 set prefixend -1
1155 set prefendstack {}
1156 set htstack {}
1157 set ht 0
1158 set treecontents() {}
1159 $w conf -state normal
1160 foreach f $l {
1161 while {[string range $f 0 $prefixend] ne $prefix} {
1162 if {$lev <= $openlevs} {
1163 $w mark set e:$treeindex($prefix) "end -1c"
1164 $w mark gravity e:$treeindex($prefix) left
1166 set treeheight($prefix) $ht
1167 incr ht [lindex $htstack end]
1168 set htstack [lreplace $htstack end end]
1169 set prefixend [lindex $prefendstack end]
1170 set prefendstack [lreplace $prefendstack end end]
1171 set prefix [string range $prefix 0 $prefixend]
1172 incr lev -1
1174 set tail [string range $f [expr {$prefixend+1}] end]
1175 while {[set slash [string first "/" $tail]] >= 0} {
1176 lappend htstack $ht
1177 set ht 0
1178 lappend prefendstack $prefixend
1179 incr prefixend [expr {$slash + 1}]
1180 set d [string range $tail 0 $slash]
1181 lappend treecontents($prefix) $d
1182 set oldprefix $prefix
1183 append prefix $d
1184 set treecontents($prefix) {}
1185 set treeindex($prefix) [incr ix]
1186 set treeparent($prefix) $oldprefix
1187 set tail [string range $tail [expr {$slash+1}] end]
1188 if {$lev <= $openlevs} {
1189 set ht 1
1190 set treediropen($prefix) [expr {$lev < $openlevs}]
1191 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1192 $w mark set d:$ix "end -1c"
1193 $w mark gravity d:$ix left
1194 set str "\n"
1195 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1196 $w insert end $str
1197 $w image create end -align center -image $bm -padx 1 \
1198 -name a:$ix
1199 $w insert end $d [highlight_tag $prefix]
1200 $w mark set s:$ix "end -1c"
1201 $w mark gravity s:$ix left
1203 incr lev
1205 if {$tail ne {}} {
1206 if {$lev <= $openlevs} {
1207 incr ht
1208 set str "\n"
1209 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1210 $w insert end $str
1211 $w insert end $tail [highlight_tag $f]
1213 lappend treecontents($prefix) $tail
1216 while {$htstack ne {}} {
1217 set treeheight($prefix) $ht
1218 incr ht [lindex $htstack end]
1219 set htstack [lreplace $htstack end end]
1220 set prefixend [lindex $prefendstack end]
1221 set prefendstack [lreplace $prefendstack end end]
1222 set prefix [string range $prefix 0 $prefixend]
1224 $w conf -state disabled
1227 proc linetoelt {l} {
1228 global treeheight treecontents
1230 set y 2
1231 set prefix {}
1232 while {1} {
1233 foreach e $treecontents($prefix) {
1234 if {$y == $l} {
1235 return "$prefix$e"
1237 set n 1
1238 if {[string index $e end] eq "/"} {
1239 set n $treeheight($prefix$e)
1240 if {$y + $n > $l} {
1241 append prefix $e
1242 incr y
1243 break
1246 incr y $n
1251 proc highlight_tree {y prefix} {
1252 global treeheight treecontents cflist
1254 foreach e $treecontents($prefix) {
1255 set path $prefix$e
1256 if {[highlight_tag $path] ne {}} {
1257 $cflist tag add bold $y.0 "$y.0 lineend"
1259 incr y
1260 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1261 set y [highlight_tree $y $path]
1264 return $y
1267 proc treeclosedir {w dir} {
1268 global treediropen treeheight treeparent treeindex
1270 set ix $treeindex($dir)
1271 $w conf -state normal
1272 $w delete s:$ix e:$ix
1273 set treediropen($dir) 0
1274 $w image configure a:$ix -image tri-rt
1275 $w conf -state disabled
1276 set n [expr {1 - $treeheight($dir)}]
1277 while {$dir ne {}} {
1278 incr treeheight($dir) $n
1279 set dir $treeparent($dir)
1283 proc treeopendir {w dir} {
1284 global treediropen treeheight treeparent treecontents treeindex
1286 set ix $treeindex($dir)
1287 $w conf -state normal
1288 $w image configure a:$ix -image tri-dn
1289 $w mark set e:$ix s:$ix
1290 $w mark gravity e:$ix right
1291 set lev 0
1292 set str "\n"
1293 set n [llength $treecontents($dir)]
1294 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1295 incr lev
1296 append str "\t"
1297 incr treeheight($x) $n
1299 foreach e $treecontents($dir) {
1300 set de $dir$e
1301 if {[string index $e end] eq "/"} {
1302 set iy $treeindex($de)
1303 $w mark set d:$iy e:$ix
1304 $w mark gravity d:$iy left
1305 $w insert e:$ix $str
1306 set treediropen($de) 0
1307 $w image create e:$ix -align center -image tri-rt -padx 1 \
1308 -name a:$iy
1309 $w insert e:$ix $e [highlight_tag $de]
1310 $w mark set s:$iy e:$ix
1311 $w mark gravity s:$iy left
1312 set treeheight($de) 1
1313 } else {
1314 $w insert e:$ix $str
1315 $w insert e:$ix $e [highlight_tag $de]
1318 $w mark gravity e:$ix left
1319 $w conf -state disabled
1320 set treediropen($dir) 1
1321 set top [lindex [split [$w index @0,0] .] 0]
1322 set ht [$w cget -height]
1323 set l [lindex [split [$w index s:$ix] .] 0]
1324 if {$l < $top} {
1325 $w yview $l.0
1326 } elseif {$l + $n + 1 > $top + $ht} {
1327 set top [expr {$l + $n + 2 - $ht}]
1328 if {$l < $top} {
1329 set top $l
1331 $w yview $top.0
1335 proc treeclick {w x y} {
1336 global treediropen cmitmode ctext cflist cflist_top
1338 if {$cmitmode ne "tree"} return
1339 if {![info exists cflist_top]} return
1340 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1341 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1342 $cflist tag add highlight $l.0 "$l.0 lineend"
1343 set cflist_top $l
1344 if {$l == 1} {
1345 $ctext yview 1.0
1346 return
1348 set e [linetoelt $l]
1349 if {[string index $e end] ne "/"} {
1350 showfile $e
1351 } elseif {$treediropen($e)} {
1352 treeclosedir $w $e
1353 } else {
1354 treeopendir $w $e
1358 proc setfilelist {id} {
1359 global treefilelist cflist
1361 treeview $cflist $treefilelist($id) 0
1364 image create bitmap tri-rt -background black -foreground blue -data {
1365 #define tri-rt_width 13
1366 #define tri-rt_height 13
1367 static unsigned char tri-rt_bits[] = {
1368 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1369 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1370 0x00, 0x00};
1371 } -maskdata {
1372 #define tri-rt-mask_width 13
1373 #define tri-rt-mask_height 13
1374 static unsigned char tri-rt-mask_bits[] = {
1375 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1376 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1377 0x08, 0x00};
1379 image create bitmap tri-dn -background black -foreground blue -data {
1380 #define tri-dn_width 13
1381 #define tri-dn_height 13
1382 static unsigned char tri-dn_bits[] = {
1383 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1384 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1385 0x00, 0x00};
1386 } -maskdata {
1387 #define tri-dn-mask_width 13
1388 #define tri-dn-mask_height 13
1389 static unsigned char tri-dn-mask_bits[] = {
1390 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1391 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1392 0x00, 0x00};
1395 proc init_flist {first} {
1396 global cflist cflist_top selectedline difffilestart
1398 $cflist conf -state normal
1399 $cflist delete 0.0 end
1400 if {$first ne {}} {
1401 $cflist insert end $first
1402 set cflist_top 1
1403 $cflist tag add highlight 1.0 "1.0 lineend"
1404 } else {
1405 catch {unset cflist_top}
1407 $cflist conf -state disabled
1408 set difffilestart {}
1411 proc highlight_tag {f} {
1412 global highlight_paths
1414 foreach p $highlight_paths {
1415 if {[string match $p $f]} {
1416 return "bold"
1419 return {}
1422 proc highlight_filelist {} {
1423 global cmitmode cflist
1425 $cflist conf -state normal
1426 if {$cmitmode ne "tree"} {
1427 set end [lindex [split [$cflist index end] .] 0]
1428 for {set l 2} {$l < $end} {incr l} {
1429 set line [$cflist get $l.0 "$l.0 lineend"]
1430 if {[highlight_tag $line] ne {}} {
1431 $cflist tag add bold $l.0 "$l.0 lineend"
1434 } else {
1435 highlight_tree 2 {}
1437 $cflist conf -state disabled
1440 proc unhighlight_filelist {} {
1441 global cflist
1443 $cflist conf -state normal
1444 $cflist tag remove bold 1.0 end
1445 $cflist conf -state disabled
1448 proc add_flist {fl} {
1449 global cflist
1451 $cflist conf -state normal
1452 foreach f $fl {
1453 $cflist insert end "\n"
1454 $cflist insert end $f [highlight_tag $f]
1456 $cflist conf -state disabled
1459 proc sel_flist {w x y} {
1460 global ctext difffilestart cflist cflist_top cmitmode
1462 if {$cmitmode eq "tree"} return
1463 if {![info exists cflist_top]} return
1464 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1465 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1466 $cflist tag add highlight $l.0 "$l.0 lineend"
1467 set cflist_top $l
1468 if {$l == 1} {
1469 $ctext yview 1.0
1470 } else {
1471 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1475 # Functions for adding and removing shell-type quoting
1477 proc shellquote {str} {
1478 if {![string match "*\['\"\\ \t]*" $str]} {
1479 return $str
1481 if {![string match "*\['\"\\]*" $str]} {
1482 return "\"$str\""
1484 if {![string match "*'*" $str]} {
1485 return "'$str'"
1487 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1490 proc shellarglist {l} {
1491 set str {}
1492 foreach a $l {
1493 if {$str ne {}} {
1494 append str " "
1496 append str [shellquote $a]
1498 return $str
1501 proc shelldequote {str} {
1502 set ret {}
1503 set used -1
1504 while {1} {
1505 incr used
1506 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1507 append ret [string range $str $used end]
1508 set used [string length $str]
1509 break
1511 set first [lindex $first 0]
1512 set ch [string index $str $first]
1513 if {$first > $used} {
1514 append ret [string range $str $used [expr {$first - 1}]]
1515 set used $first
1517 if {$ch eq " " || $ch eq "\t"} break
1518 incr used
1519 if {$ch eq "'"} {
1520 set first [string first "'" $str $used]
1521 if {$first < 0} {
1522 error "unmatched single-quote"
1524 append ret [string range $str $used [expr {$first - 1}]]
1525 set used $first
1526 continue
1528 if {$ch eq "\\"} {
1529 if {$used >= [string length $str]} {
1530 error "trailing backslash"
1532 append ret [string index $str $used]
1533 continue
1535 # here ch == "\""
1536 while {1} {
1537 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1538 error "unmatched double-quote"
1540 set first [lindex $first 0]
1541 set ch [string index $str $first]
1542 if {$first > $used} {
1543 append ret [string range $str $used [expr {$first - 1}]]
1544 set used $first
1546 if {$ch eq "\""} break
1547 incr used
1548 append ret [string index $str $used]
1549 incr used
1552 return [list $used $ret]
1555 proc shellsplit {str} {
1556 set l {}
1557 while {1} {
1558 set str [string trimleft $str]
1559 if {$str eq {}} break
1560 set dq [shelldequote $str]
1561 set n [lindex $dq 0]
1562 set word [lindex $dq 1]
1563 set str [string range $str $n end]
1564 lappend l $word
1566 return $l
1569 # Code to implement multiple views
1571 proc newview {ishighlight} {
1572 global nextviewnum newviewname newviewperm uifont newishighlight
1573 global newviewargs revtreeargs
1575 set newishighlight $ishighlight
1576 set top .gitkview
1577 if {[winfo exists $top]} {
1578 raise $top
1579 return
1581 set newviewname($nextviewnum) "View $nextviewnum"
1582 set newviewperm($nextviewnum) 0
1583 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1584 vieweditor $top $nextviewnum "Gitk view definition"
1587 proc editview {} {
1588 global curview
1589 global viewname viewperm newviewname newviewperm
1590 global viewargs newviewargs
1592 set top .gitkvedit-$curview
1593 if {[winfo exists $top]} {
1594 raise $top
1595 return
1597 set newviewname($curview) $viewname($curview)
1598 set newviewperm($curview) $viewperm($curview)
1599 set newviewargs($curview) [shellarglist $viewargs($curview)]
1600 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1603 proc vieweditor {top n title} {
1604 global newviewname newviewperm viewfiles
1605 global uifont
1607 toplevel $top
1608 wm title $top $title
1609 label $top.nl -text "Name" -font $uifont
1610 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1611 grid $top.nl $top.name -sticky w -pady 5
1612 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1613 -font $uifont
1614 grid $top.perm - -pady 5 -sticky w
1615 message $top.al -aspect 1000 -font $uifont \
1616 -text "Commits to include (arguments to git rev-list):"
1617 grid $top.al - -sticky w -pady 5
1618 entry $top.args -width 50 -textvariable newviewargs($n) \
1619 -background white -font $uifont
1620 grid $top.args - -sticky ew -padx 5
1621 message $top.l -aspect 1000 -font $uifont \
1622 -text "Enter files and directories to include, one per line:"
1623 grid $top.l - -sticky w
1624 text $top.t -width 40 -height 10 -background white -font $uifont
1625 if {[info exists viewfiles($n)]} {
1626 foreach f $viewfiles($n) {
1627 $top.t insert end $f
1628 $top.t insert end "\n"
1630 $top.t delete {end - 1c} end
1631 $top.t mark set insert 0.0
1633 grid $top.t - -sticky ew -padx 5
1634 frame $top.buts
1635 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1636 -font $uifont
1637 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1638 -font $uifont
1639 grid $top.buts.ok $top.buts.can
1640 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1641 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1642 grid $top.buts - -pady 10 -sticky ew
1643 focus $top.t
1646 proc doviewmenu {m first cmd op argv} {
1647 set nmenu [$m index end]
1648 for {set i $first} {$i <= $nmenu} {incr i} {
1649 if {[$m entrycget $i -command] eq $cmd} {
1650 eval $m $op $i $argv
1651 break
1656 proc allviewmenus {n op args} {
1657 global viewhlmenu
1659 doviewmenu .bar.view 5 [list showview $n] $op $args
1660 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1663 proc newviewok {top n} {
1664 global nextviewnum newviewperm newviewname newishighlight
1665 global viewname viewfiles viewperm selectedview curview
1666 global viewargs newviewargs viewhlmenu
1668 if {[catch {
1669 set newargs [shellsplit $newviewargs($n)]
1670 } err]} {
1671 error_popup "Error in commit selection arguments: $err"
1672 wm raise $top
1673 focus $top
1674 return
1676 set files {}
1677 foreach f [split [$top.t get 0.0 end] "\n"] {
1678 set ft [string trim $f]
1679 if {$ft ne {}} {
1680 lappend files $ft
1683 if {![info exists viewfiles($n)]} {
1684 # creating a new view
1685 incr nextviewnum
1686 set viewname($n) $newviewname($n)
1687 set viewperm($n) $newviewperm($n)
1688 set viewfiles($n) $files
1689 set viewargs($n) $newargs
1690 addviewmenu $n
1691 if {!$newishighlight} {
1692 run showview $n
1693 } else {
1694 run addvhighlight $n
1696 } else {
1697 # editing an existing view
1698 set viewperm($n) $newviewperm($n)
1699 if {$newviewname($n) ne $viewname($n)} {
1700 set viewname($n) $newviewname($n)
1701 doviewmenu .bar.view 5 [list showview $n] \
1702 entryconf [list -label $viewname($n)]
1703 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1704 entryconf [list -label $viewname($n) -value $viewname($n)]
1706 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1707 set viewfiles($n) $files
1708 set viewargs($n) $newargs
1709 if {$curview == $n} {
1710 run updatecommits
1714 catch {destroy $top}
1717 proc delview {} {
1718 global curview viewdata viewperm hlview selectedhlview
1720 if {$curview == 0} return
1721 if {[info exists hlview] && $hlview == $curview} {
1722 set selectedhlview None
1723 unset hlview
1725 allviewmenus $curview delete
1726 set viewdata($curview) {}
1727 set viewperm($curview) 0
1728 showview 0
1731 proc addviewmenu {n} {
1732 global viewname viewhlmenu
1734 .bar.view add radiobutton -label $viewname($n) \
1735 -command [list showview $n] -variable selectedview -value $n
1736 $viewhlmenu add radiobutton -label $viewname($n) \
1737 -command [list addvhighlight $n] -variable selectedhlview
1740 proc flatten {var} {
1741 global $var
1743 set ret {}
1744 foreach i [array names $var] {
1745 lappend ret $i [set $var\($i\)]
1747 return $ret
1750 proc unflatten {var l} {
1751 global $var
1753 catch {unset $var}
1754 foreach {i v} $l {
1755 set $var\($i\) $v
1759 proc showview {n} {
1760 global curview viewdata viewfiles
1761 global displayorder parentlist rowidlist rowoffsets
1762 global colormap rowtextx commitrow nextcolor canvxmax
1763 global numcommits rowrangelist commitlisted idrowranges rowchk
1764 global selectedline currentid canv canvy0
1765 global treediffs
1766 global pending_select phase
1767 global commitidx rowlaidout rowoptim
1768 global commfd
1769 global selectedview selectfirst
1770 global vparentlist vdisporder vcmitlisted
1771 global hlview selectedhlview
1773 if {$n == $curview} return
1774 set selid {}
1775 if {[info exists selectedline]} {
1776 set selid $currentid
1777 set y [yc $selectedline]
1778 set ymax [lindex [$canv cget -scrollregion] 3]
1779 set span [$canv yview]
1780 set ytop [expr {[lindex $span 0] * $ymax}]
1781 set ybot [expr {[lindex $span 1] * $ymax}]
1782 if {$ytop < $y && $y < $ybot} {
1783 set yscreen [expr {$y - $ytop}]
1784 } else {
1785 set yscreen [expr {($ybot - $ytop) / 2}]
1787 } elseif {[info exists pending_select]} {
1788 set selid $pending_select
1789 unset pending_select
1791 unselectline
1792 normalline
1793 if {$curview >= 0} {
1794 set vparentlist($curview) $parentlist
1795 set vdisporder($curview) $displayorder
1796 set vcmitlisted($curview) $commitlisted
1797 if {$phase ne {}} {
1798 set viewdata($curview) \
1799 [list $phase $rowidlist $rowoffsets $rowrangelist \
1800 [flatten idrowranges] [flatten idinlist] \
1801 $rowlaidout $rowoptim $numcommits]
1802 } elseif {![info exists viewdata($curview)]
1803 || [lindex $viewdata($curview) 0] ne {}} {
1804 set viewdata($curview) \
1805 [list {} $rowidlist $rowoffsets $rowrangelist]
1808 catch {unset treediffs}
1809 clear_display
1810 if {[info exists hlview] && $hlview == $n} {
1811 unset hlview
1812 set selectedhlview None
1815 set curview $n
1816 set selectedview $n
1817 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1818 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1820 if {![info exists viewdata($n)]} {
1821 if {$selid ne {}} {
1822 set pending_select $selid
1824 getcommits
1825 return
1828 set v $viewdata($n)
1829 set phase [lindex $v 0]
1830 set displayorder $vdisporder($n)
1831 set parentlist $vparentlist($n)
1832 set commitlisted $vcmitlisted($n)
1833 set rowidlist [lindex $v 1]
1834 set rowoffsets [lindex $v 2]
1835 set rowrangelist [lindex $v 3]
1836 if {$phase eq {}} {
1837 set numcommits [llength $displayorder]
1838 catch {unset idrowranges}
1839 } else {
1840 unflatten idrowranges [lindex $v 4]
1841 unflatten idinlist [lindex $v 5]
1842 set rowlaidout [lindex $v 6]
1843 set rowoptim [lindex $v 7]
1844 set numcommits [lindex $v 8]
1845 catch {unset rowchk}
1848 catch {unset colormap}
1849 catch {unset rowtextx}
1850 set nextcolor 0
1851 set canvxmax [$canv cget -width]
1852 set curview $n
1853 set row 0
1854 setcanvscroll
1855 set yf 0
1856 set row {}
1857 set selectfirst 0
1858 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1859 set row $commitrow($n,$selid)
1860 # try to get the selected row in the same position on the screen
1861 set ymax [lindex [$canv cget -scrollregion] 3]
1862 set ytop [expr {[yc $row] - $yscreen}]
1863 if {$ytop < 0} {
1864 set ytop 0
1866 set yf [expr {$ytop * 1.0 / $ymax}]
1868 allcanvs yview moveto $yf
1869 drawvisible
1870 if {$row ne {}} {
1871 selectline $row 0
1872 } elseif {$selid ne {}} {
1873 set pending_select $selid
1874 } else {
1875 set row [expr {[lindex $displayorder 0] eq $nullid}]
1876 if {$row < $numcommits} {
1877 selectline $row 0
1878 } else {
1879 set selectfirst 1
1882 if {$phase ne {}} {
1883 if {$phase eq "getcommits"} {
1884 show_status "Reading commits..."
1886 run chewcommits $n
1887 } elseif {$numcommits == 0} {
1888 show_status "No commits selected"
1892 # Stuff relating to the highlighting facility
1894 proc ishighlighted {row} {
1895 global vhighlights fhighlights nhighlights rhighlights
1897 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1898 return $nhighlights($row)
1900 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1901 return $vhighlights($row)
1903 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1904 return $fhighlights($row)
1906 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1907 return $rhighlights($row)
1909 return 0
1912 proc bolden {row font} {
1913 global canv linehtag selectedline boldrows
1915 lappend boldrows $row
1916 $canv itemconf $linehtag($row) -font $font
1917 if {[info exists selectedline] && $row == $selectedline} {
1918 $canv delete secsel
1919 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1920 -outline {{}} -tags secsel \
1921 -fill [$canv cget -selectbackground]]
1922 $canv lower $t
1926 proc bolden_name {row font} {
1927 global canv2 linentag selectedline boldnamerows
1929 lappend boldnamerows $row
1930 $canv2 itemconf $linentag($row) -font $font
1931 if {[info exists selectedline] && $row == $selectedline} {
1932 $canv2 delete secsel
1933 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1934 -outline {{}} -tags secsel \
1935 -fill [$canv2 cget -selectbackground]]
1936 $canv2 lower $t
1940 proc unbolden {} {
1941 global mainfont boldrows
1943 set stillbold {}
1944 foreach row $boldrows {
1945 if {![ishighlighted $row]} {
1946 bolden $row $mainfont
1947 } else {
1948 lappend stillbold $row
1951 set boldrows $stillbold
1954 proc addvhighlight {n} {
1955 global hlview curview viewdata vhl_done vhighlights commitidx
1957 if {[info exists hlview]} {
1958 delvhighlight
1960 set hlview $n
1961 if {$n != $curview && ![info exists viewdata($n)]} {
1962 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1963 set vparentlist($n) {}
1964 set vdisporder($n) {}
1965 set vcmitlisted($n) {}
1966 start_rev_list $n
1968 set vhl_done $commitidx($hlview)
1969 if {$vhl_done > 0} {
1970 drawvisible
1974 proc delvhighlight {} {
1975 global hlview vhighlights
1977 if {![info exists hlview]} return
1978 unset hlview
1979 catch {unset vhighlights}
1980 unbolden
1983 proc vhighlightmore {} {
1984 global hlview vhl_done commitidx vhighlights
1985 global displayorder vdisporder curview mainfont
1987 set font [concat $mainfont bold]
1988 set max $commitidx($hlview)
1989 if {$hlview == $curview} {
1990 set disp $displayorder
1991 } else {
1992 set disp $vdisporder($hlview)
1994 set vr [visiblerows]
1995 set r0 [lindex $vr 0]
1996 set r1 [lindex $vr 1]
1997 for {set i $vhl_done} {$i < $max} {incr i} {
1998 set id [lindex $disp $i]
1999 if {[info exists commitrow($curview,$id)]} {
2000 set row $commitrow($curview,$id)
2001 if {$r0 <= $row && $row <= $r1} {
2002 if {![highlighted $row]} {
2003 bolden $row $font
2005 set vhighlights($row) 1
2009 set vhl_done $max
2012 proc askvhighlight {row id} {
2013 global hlview vhighlights commitrow iddrawn mainfont
2015 if {[info exists commitrow($hlview,$id)]} {
2016 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2017 bolden $row [concat $mainfont bold]
2019 set vhighlights($row) 1
2020 } else {
2021 set vhighlights($row) 0
2025 proc hfiles_change {name ix op} {
2026 global highlight_files filehighlight fhighlights fh_serial
2027 global mainfont highlight_paths
2029 if {[info exists filehighlight]} {
2030 # delete previous highlights
2031 catch {close $filehighlight}
2032 unset filehighlight
2033 catch {unset fhighlights}
2034 unbolden
2035 unhighlight_filelist
2037 set highlight_paths {}
2038 after cancel do_file_hl $fh_serial
2039 incr fh_serial
2040 if {$highlight_files ne {}} {
2041 after 300 do_file_hl $fh_serial
2045 proc makepatterns {l} {
2046 set ret {}
2047 foreach e $l {
2048 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2049 if {[string index $ee end] eq "/"} {
2050 lappend ret "$ee*"
2051 } else {
2052 lappend ret $ee
2053 lappend ret "$ee/*"
2056 return $ret
2059 proc do_file_hl {serial} {
2060 global highlight_files filehighlight highlight_paths gdttype fhl_list
2062 if {$gdttype eq "touching paths:"} {
2063 if {[catch {set paths [shellsplit $highlight_files]}]} return
2064 set highlight_paths [makepatterns $paths]
2065 highlight_filelist
2066 set gdtargs [concat -- $paths]
2067 } else {
2068 set gdtargs [list "-S$highlight_files"]
2070 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2071 set filehighlight [open $cmd r+]
2072 fconfigure $filehighlight -blocking 0
2073 filerun $filehighlight readfhighlight
2074 set fhl_list {}
2075 drawvisible
2076 flushhighlights
2079 proc flushhighlights {} {
2080 global filehighlight fhl_list
2082 if {[info exists filehighlight]} {
2083 lappend fhl_list {}
2084 puts $filehighlight ""
2085 flush $filehighlight
2089 proc askfilehighlight {row id} {
2090 global filehighlight fhighlights fhl_list
2092 lappend fhl_list $id
2093 set fhighlights($row) -1
2094 puts $filehighlight $id
2097 proc readfhighlight {} {
2098 global filehighlight fhighlights commitrow curview mainfont iddrawn
2099 global fhl_list
2101 if {![info exists filehighlight]} {
2102 return 0
2104 set nr 0
2105 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2106 set line [string trim $line]
2107 set i [lsearch -exact $fhl_list $line]
2108 if {$i < 0} continue
2109 for {set j 0} {$j < $i} {incr j} {
2110 set id [lindex $fhl_list $j]
2111 if {[info exists commitrow($curview,$id)]} {
2112 set fhighlights($commitrow($curview,$id)) 0
2115 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2116 if {$line eq {}} continue
2117 if {![info exists commitrow($curview,$line)]} continue
2118 set row $commitrow($curview,$line)
2119 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2120 bolden $row [concat $mainfont bold]
2122 set fhighlights($row) 1
2124 if {[eof $filehighlight]} {
2125 # strange...
2126 puts "oops, git diff-tree died"
2127 catch {close $filehighlight}
2128 unset filehighlight
2129 return 0
2131 next_hlcont
2132 return 1
2135 proc find_change {name ix op} {
2136 global nhighlights mainfont boldnamerows
2137 global findstring findpattern findtype markingmatches
2139 # delete previous highlights, if any
2140 foreach row $boldnamerows {
2141 bolden_name $row $mainfont
2143 set boldnamerows {}
2144 catch {unset nhighlights}
2145 unbolden
2146 unmarkmatches
2147 if {$findtype ne "Regexp"} {
2148 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2149 $findstring]
2150 set findpattern "*$e*"
2152 set markingmatches [expr {$findstring ne {}}]
2153 drawvisible
2156 proc doesmatch {f} {
2157 global findtype findstring findpattern
2159 if {$findtype eq "Regexp"} {
2160 return [regexp $findstring $f]
2161 } elseif {$findtype eq "IgnCase"} {
2162 return [string match -nocase $findpattern $f]
2163 } else {
2164 return [string match $findpattern $f]
2168 proc askfindhighlight {row id} {
2169 global nhighlights commitinfo iddrawn mainfont
2170 global findloc
2171 global markingmatches
2173 if {![info exists commitinfo($id)]} {
2174 getcommit $id
2176 set info $commitinfo($id)
2177 set isbold 0
2178 set fldtypes {Headline Author Date Committer CDate Comments}
2179 foreach f $info ty $fldtypes {
2180 if {($findloc eq "All fields" || $findloc eq $ty) &&
2181 [doesmatch $f]} {
2182 if {$ty eq "Author"} {
2183 set isbold 2
2184 break
2186 set isbold 1
2189 if {$isbold && [info exists iddrawn($id)]} {
2190 set f [concat $mainfont bold]
2191 if {![ishighlighted $row]} {
2192 bolden $row $f
2193 if {$isbold > 1} {
2194 bolden_name $row $f
2197 if {$markingmatches} {
2198 markrowmatches $row [lindex $info 0] [lindex $info 1]
2201 set nhighlights($row) $isbold
2204 proc markrowmatches {row headline author} {
2205 global canv canv2 linehtag linentag
2207 $canv delete match$row
2208 $canv2 delete match$row
2209 set m [findmatches $headline]
2210 if {$m ne {}} {
2211 markmatches $canv $row $headline $linehtag($row) $m \
2212 [$canv itemcget $linehtag($row) -font]
2214 set m [findmatches $author]
2215 if {$m ne {}} {
2216 markmatches $canv2 $row $author $linentag($row) $m \
2217 [$canv2 itemcget $linentag($row) -font]
2221 proc vrel_change {name ix op} {
2222 global highlight_related
2224 rhighlight_none
2225 if {$highlight_related ne "None"} {
2226 run drawvisible
2230 # prepare for testing whether commits are descendents or ancestors of a
2231 proc rhighlight_sel {a} {
2232 global descendent desc_todo ancestor anc_todo
2233 global highlight_related rhighlights
2235 catch {unset descendent}
2236 set desc_todo [list $a]
2237 catch {unset ancestor}
2238 set anc_todo [list $a]
2239 if {$highlight_related ne "None"} {
2240 rhighlight_none
2241 run drawvisible
2245 proc rhighlight_none {} {
2246 global rhighlights
2248 catch {unset rhighlights}
2249 unbolden
2252 proc is_descendent {a} {
2253 global curview children commitrow descendent desc_todo
2255 set v $curview
2256 set la $commitrow($v,$a)
2257 set todo $desc_todo
2258 set leftover {}
2259 set done 0
2260 for {set i 0} {$i < [llength $todo]} {incr i} {
2261 set do [lindex $todo $i]
2262 if {$commitrow($v,$do) < $la} {
2263 lappend leftover $do
2264 continue
2266 foreach nk $children($v,$do) {
2267 if {![info exists descendent($nk)]} {
2268 set descendent($nk) 1
2269 lappend todo $nk
2270 if {$nk eq $a} {
2271 set done 1
2275 if {$done} {
2276 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2277 return
2280 set descendent($a) 0
2281 set desc_todo $leftover
2284 proc is_ancestor {a} {
2285 global curview parentlist commitrow ancestor anc_todo
2287 set v $curview
2288 set la $commitrow($v,$a)
2289 set todo $anc_todo
2290 set leftover {}
2291 set done 0
2292 for {set i 0} {$i < [llength $todo]} {incr i} {
2293 set do [lindex $todo $i]
2294 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2295 lappend leftover $do
2296 continue
2298 foreach np [lindex $parentlist $commitrow($v,$do)] {
2299 if {![info exists ancestor($np)]} {
2300 set ancestor($np) 1
2301 lappend todo $np
2302 if {$np eq $a} {
2303 set done 1
2307 if {$done} {
2308 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2309 return
2312 set ancestor($a) 0
2313 set anc_todo $leftover
2316 proc askrelhighlight {row id} {
2317 global descendent highlight_related iddrawn mainfont rhighlights
2318 global selectedline ancestor
2320 if {![info exists selectedline]} return
2321 set isbold 0
2322 if {$highlight_related eq "Descendent" ||
2323 $highlight_related eq "Not descendent"} {
2324 if {![info exists descendent($id)]} {
2325 is_descendent $id
2327 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2328 set isbold 1
2330 } elseif {$highlight_related eq "Ancestor" ||
2331 $highlight_related eq "Not ancestor"} {
2332 if {![info exists ancestor($id)]} {
2333 is_ancestor $id
2335 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2336 set isbold 1
2339 if {[info exists iddrawn($id)]} {
2340 if {$isbold && ![ishighlighted $row]} {
2341 bolden $row [concat $mainfont bold]
2344 set rhighlights($row) $isbold
2347 proc next_hlcont {} {
2348 global fhl_row fhl_dirn displayorder numcommits
2349 global vhighlights fhighlights nhighlights rhighlights
2350 global hlview filehighlight findstring highlight_related
2352 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2353 set row $fhl_row
2354 while {1} {
2355 if {$row < 0 || $row >= $numcommits} {
2356 bell
2357 set fhl_dirn 0
2358 return
2360 set id [lindex $displayorder $row]
2361 if {[info exists hlview]} {
2362 if {![info exists vhighlights($row)]} {
2363 askvhighlight $row $id
2365 if {$vhighlights($row) > 0} break
2367 if {$findstring ne {}} {
2368 if {![info exists nhighlights($row)]} {
2369 askfindhighlight $row $id
2371 if {$nhighlights($row) > 0} break
2373 if {$highlight_related ne "None"} {
2374 if {![info exists rhighlights($row)]} {
2375 askrelhighlight $row $id
2377 if {$rhighlights($row) > 0} break
2379 if {[info exists filehighlight]} {
2380 if {![info exists fhighlights($row)]} {
2381 # ask for a few more while we're at it...
2382 set r $row
2383 for {set n 0} {$n < 100} {incr n} {
2384 if {![info exists fhighlights($r)]} {
2385 askfilehighlight $r [lindex $displayorder $r]
2387 incr r $fhl_dirn
2388 if {$r < 0 || $r >= $numcommits} break
2390 flushhighlights
2392 if {$fhighlights($row) < 0} {
2393 set fhl_row $row
2394 return
2396 if {$fhighlights($row) > 0} break
2398 incr row $fhl_dirn
2400 set fhl_dirn 0
2401 selectline $row 1
2404 proc next_highlight {dirn} {
2405 global selectedline fhl_row fhl_dirn
2406 global hlview filehighlight findstring highlight_related
2408 if {![info exists selectedline]} return
2409 if {!([info exists hlview] || $findstring ne {} ||
2410 $highlight_related ne "None" || [info exists filehighlight])} return
2411 set fhl_row [expr {$selectedline + $dirn}]
2412 set fhl_dirn $dirn
2413 next_hlcont
2416 proc cancel_next_highlight {} {
2417 global fhl_dirn
2419 set fhl_dirn 0
2422 # Graph layout functions
2424 proc shortids {ids} {
2425 set res {}
2426 foreach id $ids {
2427 if {[llength $id] > 1} {
2428 lappend res [shortids $id]
2429 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2430 lappend res [string range $id 0 7]
2431 } else {
2432 lappend res $id
2435 return $res
2438 proc incrange {l x o} {
2439 set n [llength $l]
2440 while {$x < $n} {
2441 set e [lindex $l $x]
2442 if {$e ne {}} {
2443 lset l $x [expr {$e + $o}]
2445 incr x
2447 return $l
2450 proc ntimes {n o} {
2451 set ret {}
2452 for {} {$n > 0} {incr n -1} {
2453 lappend ret $o
2455 return $ret
2458 proc usedinrange {id l1 l2} {
2459 global children commitrow curview
2461 if {[info exists commitrow($curview,$id)]} {
2462 set r $commitrow($curview,$id)
2463 if {$l1 <= $r && $r <= $l2} {
2464 return [expr {$r - $l1 + 1}]
2467 set kids $children($curview,$id)
2468 foreach c $kids {
2469 set r $commitrow($curview,$c)
2470 if {$l1 <= $r && $r <= $l2} {
2471 return [expr {$r - $l1 + 1}]
2474 return 0
2477 proc sanity {row {full 0}} {
2478 global rowidlist rowoffsets
2480 set col -1
2481 set ids [lindex $rowidlist $row]
2482 foreach id $ids {
2483 incr col
2484 if {$id eq {}} continue
2485 if {$col < [llength $ids] - 1 &&
2486 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2487 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2489 set o [lindex $rowoffsets $row $col]
2490 set y $row
2491 set x $col
2492 while {$o ne {}} {
2493 incr y -1
2494 incr x $o
2495 if {[lindex $rowidlist $y $x] != $id} {
2496 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2497 puts " id=[shortids $id] check started at row $row"
2498 for {set i $row} {$i >= $y} {incr i -1} {
2499 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2501 break
2503 if {!$full} break
2504 set o [lindex $rowoffsets $y $x]
2509 proc makeuparrow {oid x y z} {
2510 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2512 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2513 incr y -1
2514 incr x $z
2515 set off0 [lindex $rowoffsets $y]
2516 for {set x0 $x} {1} {incr x0} {
2517 if {$x0 >= [llength $off0]} {
2518 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2519 break
2521 set z [lindex $off0 $x0]
2522 if {$z ne {}} {
2523 incr x0 $z
2524 break
2527 set z [expr {$x0 - $x}]
2528 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2529 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2531 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2532 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2533 lappend idrowranges($oid) [lindex $displayorder $y]
2536 proc initlayout {} {
2537 global rowidlist rowoffsets displayorder commitlisted
2538 global rowlaidout rowoptim
2539 global idinlist rowchk rowrangelist idrowranges
2540 global numcommits canvxmax canv
2541 global nextcolor
2542 global parentlist
2543 global colormap rowtextx
2544 global selectfirst
2546 set numcommits 0
2547 set displayorder {}
2548 set commitlisted {}
2549 set parentlist {}
2550 set rowrangelist {}
2551 set nextcolor 0
2552 set rowidlist {{}}
2553 set rowoffsets {{}}
2554 catch {unset idinlist}
2555 catch {unset rowchk}
2556 set rowlaidout 0
2557 set rowoptim 0
2558 set canvxmax [$canv cget -width]
2559 catch {unset colormap}
2560 catch {unset rowtextx}
2561 catch {unset idrowranges}
2562 set selectfirst 1
2565 proc setcanvscroll {} {
2566 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2568 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2569 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2570 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2571 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2574 proc visiblerows {} {
2575 global canv numcommits linespc
2577 set ymax [lindex [$canv cget -scrollregion] 3]
2578 if {$ymax eq {} || $ymax == 0} return
2579 set f [$canv yview]
2580 set y0 [expr {int([lindex $f 0] * $ymax)}]
2581 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2582 if {$r0 < 0} {
2583 set r0 0
2585 set y1 [expr {int([lindex $f 1] * $ymax)}]
2586 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2587 if {$r1 >= $numcommits} {
2588 set r1 [expr {$numcommits - 1}]
2590 return [list $r0 $r1]
2593 proc layoutmore {tmax allread} {
2594 global rowlaidout rowoptim commitidx numcommits optim_delay
2595 global uparrowlen curview rowidlist idinlist
2597 set showlast 0
2598 set showdelay $optim_delay
2599 set optdelay [expr {$uparrowlen + 1}]
2600 while {1} {
2601 if {$rowoptim - $showdelay > $numcommits} {
2602 showstuff [expr {$rowoptim - $showdelay}] $showlast
2603 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2604 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2605 if {$nr > 100} {
2606 set nr 100
2608 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2609 incr rowoptim $nr
2610 } elseif {$commitidx($curview) > $rowlaidout} {
2611 set nr [expr {$commitidx($curview) - $rowlaidout}]
2612 # may need to increase this threshold if uparrowlen or
2613 # mingaplen are increased...
2614 if {$nr > 150} {
2615 set nr 150
2617 set row $rowlaidout
2618 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2619 if {$rowlaidout == $row} {
2620 return 0
2622 } elseif {$allread} {
2623 set optdelay 0
2624 set nrows $commitidx($curview)
2625 if {[lindex $rowidlist $nrows] ne {} ||
2626 [array names idinlist] ne {}} {
2627 layouttail
2628 set rowlaidout $commitidx($curview)
2629 } elseif {$rowoptim == $nrows} {
2630 set showdelay 0
2631 set showlast 1
2632 if {$numcommits == $nrows} {
2633 return 0
2636 } else {
2637 return 0
2639 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2640 return 1
2645 proc showstuff {canshow last} {
2646 global numcommits commitrow pending_select selectedline curview
2647 global lookingforhead mainheadid displayorder nullid selectfirst
2648 global lastscrollset
2650 if {$numcommits == 0} {
2651 global phase
2652 set phase "incrdraw"
2653 allcanvs delete all
2655 set r0 $numcommits
2656 set prev $numcommits
2657 set numcommits $canshow
2658 set t [clock clicks -milliseconds]
2659 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2660 set lastscrollset $t
2661 setcanvscroll
2663 set rows [visiblerows]
2664 set r1 [lindex $rows 1]
2665 if {$r1 >= $canshow} {
2666 set r1 [expr {$canshow - 1}]
2668 if {$r0 <= $r1} {
2669 drawcommits $r0 $r1
2671 if {[info exists pending_select] &&
2672 [info exists commitrow($curview,$pending_select)] &&
2673 $commitrow($curview,$pending_select) < $numcommits} {
2674 selectline $commitrow($curview,$pending_select) 1
2676 if {$selectfirst} {
2677 if {[info exists selectedline] || [info exists pending_select]} {
2678 set selectfirst 0
2679 } else {
2680 set l [expr {[lindex $displayorder 0] eq $nullid}]
2681 selectline $l 1
2682 set selectfirst 0
2685 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2686 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2687 set lookingforhead 0
2688 dodiffindex
2692 proc doshowlocalchanges {} {
2693 global lookingforhead curview mainheadid phase commitrow
2695 if {[info exists commitrow($curview,$mainheadid)] &&
2696 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2697 dodiffindex
2698 } elseif {$phase ne {}} {
2699 set lookingforhead 1
2703 proc dohidelocalchanges {} {
2704 global lookingforhead localrow lserial
2706 set lookingforhead 0
2707 if {$localrow >= 0} {
2708 removerow $localrow
2709 set localrow -1
2711 incr lserial
2714 # spawn off a process to do git diff-index HEAD
2715 proc dodiffindex {} {
2716 global localrow lserial
2718 incr lserial
2719 set localrow -1
2720 set fd [open "|git diff-index HEAD" r]
2721 fconfigure $fd -blocking 0
2722 filerun $fd [list readdiffindex $fd $lserial]
2725 proc readdiffindex {fd serial} {
2726 global localrow commitrow mainheadid nullid curview
2727 global commitinfo commitdata lserial
2729 if {[gets $fd line] < 0} {
2730 if {[eof $fd]} {
2731 close $fd
2732 return 0
2734 return 1
2736 # we only need to see one line and we don't really care what it says...
2737 close $fd
2739 if {$serial == $lserial && $localrow == -1} {
2740 # add the line for the local diff to the graph
2741 set localrow $commitrow($curview,$mainheadid)
2742 set hl "Local uncommitted changes"
2743 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2744 set commitdata($nullid) "\n $hl\n"
2745 insertrow $localrow $nullid
2747 return 0
2750 proc layoutrows {row endrow last} {
2751 global rowidlist rowoffsets displayorder
2752 global uparrowlen downarrowlen maxwidth mingaplen
2753 global children parentlist
2754 global idrowranges
2755 global commitidx curview
2756 global idinlist rowchk rowrangelist
2758 set idlist [lindex $rowidlist $row]
2759 set offs [lindex $rowoffsets $row]
2760 while {$row < $endrow} {
2761 set id [lindex $displayorder $row]
2762 set oldolds {}
2763 set newolds {}
2764 foreach p [lindex $parentlist $row] {
2765 if {![info exists idinlist($p)]} {
2766 lappend newolds $p
2767 } elseif {!$idinlist($p)} {
2768 lappend oldolds $p
2771 set nev [expr {[llength $idlist] + [llength $newolds]
2772 + [llength $oldolds] - $maxwidth + 1}]
2773 if {$nev > 0} {
2774 if {!$last &&
2775 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2776 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2777 set i [lindex $idlist $x]
2778 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2779 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2780 [expr {$row + $uparrowlen + $mingaplen}]]
2781 if {$r == 0} {
2782 set idlist [lreplace $idlist $x $x]
2783 set offs [lreplace $offs $x $x]
2784 set offs [incrange $offs $x 1]
2785 set idinlist($i) 0
2786 set rm1 [expr {$row - 1}]
2787 lappend idrowranges($i) [lindex $displayorder $rm1]
2788 if {[incr nev -1] <= 0} break
2789 continue
2791 set rowchk($id) [expr {$row + $r}]
2794 lset rowidlist $row $idlist
2795 lset rowoffsets $row $offs
2797 set col [lsearch -exact $idlist $id]
2798 if {$col < 0} {
2799 set col [llength $idlist]
2800 lappend idlist $id
2801 lset rowidlist $row $idlist
2802 set z {}
2803 if {$children($curview,$id) ne {}} {
2804 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2805 unset idinlist($id)
2807 lappend offs $z
2808 lset rowoffsets $row $offs
2809 if {$z ne {}} {
2810 makeuparrow $id $col $row $z
2812 } else {
2813 unset idinlist($id)
2815 set ranges {}
2816 if {[info exists idrowranges($id)]} {
2817 set ranges $idrowranges($id)
2818 lappend ranges $id
2819 unset idrowranges($id)
2821 lappend rowrangelist $ranges
2822 incr row
2823 set offs [ntimes [llength $idlist] 0]
2824 set l [llength $newolds]
2825 set idlist [eval lreplace \$idlist $col $col $newolds]
2826 set o 0
2827 if {$l != 1} {
2828 set offs [lrange $offs 0 [expr {$col - 1}]]
2829 foreach x $newolds {
2830 lappend offs {}
2831 incr o -1
2833 incr o
2834 set tmp [expr {[llength $idlist] - [llength $offs]}]
2835 if {$tmp > 0} {
2836 set offs [concat $offs [ntimes $tmp $o]]
2838 } else {
2839 lset offs $col {}
2841 foreach i $newolds {
2842 set idinlist($i) 1
2843 set idrowranges($i) $id
2845 incr col $l
2846 foreach oid $oldolds {
2847 set idinlist($oid) 1
2848 set idlist [linsert $idlist $col $oid]
2849 set offs [linsert $offs $col $o]
2850 makeuparrow $oid $col $row $o
2851 incr col
2853 lappend rowidlist $idlist
2854 lappend rowoffsets $offs
2856 return $row
2859 proc addextraid {id row} {
2860 global displayorder commitrow commitinfo
2861 global commitidx commitlisted
2862 global parentlist children curview
2864 incr commitidx($curview)
2865 lappend displayorder $id
2866 lappend commitlisted 0
2867 lappend parentlist {}
2868 set commitrow($curview,$id) $row
2869 readcommit $id
2870 if {![info exists commitinfo($id)]} {
2871 set commitinfo($id) {"No commit information available"}
2873 if {![info exists children($curview,$id)]} {
2874 set children($curview,$id) {}
2878 proc layouttail {} {
2879 global rowidlist rowoffsets idinlist commitidx curview
2880 global idrowranges rowrangelist
2882 set row $commitidx($curview)
2883 set idlist [lindex $rowidlist $row]
2884 while {$idlist ne {}} {
2885 set col [expr {[llength $idlist] - 1}]
2886 set id [lindex $idlist $col]
2887 addextraid $id $row
2888 unset idinlist($id)
2889 lappend idrowranges($id) $id
2890 lappend rowrangelist $idrowranges($id)
2891 unset idrowranges($id)
2892 incr row
2893 set offs [ntimes $col 0]
2894 set idlist [lreplace $idlist $col $col]
2895 lappend rowidlist $idlist
2896 lappend rowoffsets $offs
2899 foreach id [array names idinlist] {
2900 unset idinlist($id)
2901 addextraid $id $row
2902 lset rowidlist $row [list $id]
2903 lset rowoffsets $row 0
2904 makeuparrow $id 0 $row 0
2905 lappend idrowranges($id) $id
2906 lappend rowrangelist $idrowranges($id)
2907 unset idrowranges($id)
2908 incr row
2909 lappend rowidlist {}
2910 lappend rowoffsets {}
2914 proc insert_pad {row col npad} {
2915 global rowidlist rowoffsets
2917 set pad [ntimes $npad {}]
2918 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2919 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2920 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2923 proc optimize_rows {row col endrow} {
2924 global rowidlist rowoffsets displayorder
2926 for {} {$row < $endrow} {incr row} {
2927 set idlist [lindex $rowidlist $row]
2928 set offs [lindex $rowoffsets $row]
2929 set haspad 0
2930 for {} {$col < [llength $offs]} {incr col} {
2931 if {[lindex $idlist $col] eq {}} {
2932 set haspad 1
2933 continue
2935 set z [lindex $offs $col]
2936 if {$z eq {}} continue
2937 set isarrow 0
2938 set x0 [expr {$col + $z}]
2939 set y0 [expr {$row - 1}]
2940 set z0 [lindex $rowoffsets $y0 $x0]
2941 if {$z0 eq {}} {
2942 set id [lindex $idlist $col]
2943 set ranges [rowranges $id]
2944 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2945 set isarrow 1
2948 # Looking at lines from this row to the previous row,
2949 # make them go straight up if they end in an arrow on
2950 # the previous row; otherwise make them go straight up
2951 # or at 45 degrees.
2952 if {$z < -1 || ($z < 0 && $isarrow)} {
2953 # Line currently goes left too much;
2954 # insert pads in the previous row, then optimize it
2955 set npad [expr {-1 - $z + $isarrow}]
2956 set offs [incrange $offs $col $npad]
2957 insert_pad $y0 $x0 $npad
2958 if {$y0 > 0} {
2959 optimize_rows $y0 $x0 $row
2961 set z [lindex $offs $col]
2962 set x0 [expr {$col + $z}]
2963 set z0 [lindex $rowoffsets $y0 $x0]
2964 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2965 # Line currently goes right too much;
2966 # insert pads in this line and adjust the next's rowoffsets
2967 set npad [expr {$z - 1 + $isarrow}]
2968 set y1 [expr {$row + 1}]
2969 set offs2 [lindex $rowoffsets $y1]
2970 set x1 -1
2971 foreach z $offs2 {
2972 incr x1
2973 if {$z eq {} || $x1 + $z < $col} continue
2974 if {$x1 + $z > $col} {
2975 incr npad
2977 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2978 break
2980 set pad [ntimes $npad {}]
2981 set idlist [eval linsert \$idlist $col $pad]
2982 set tmp [eval linsert \$offs $col $pad]
2983 incr col $npad
2984 set offs [incrange $tmp $col [expr {-$npad}]]
2985 set z [lindex $offs $col]
2986 set haspad 1
2988 if {$z0 eq {} && !$isarrow} {
2989 # this line links to its first child on row $row-2
2990 set rm2 [expr {$row - 2}]
2991 set id [lindex $displayorder $rm2]
2992 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2993 if {$xc >= 0} {
2994 set z0 [expr {$xc - $x0}]
2997 # avoid lines jigging left then immediately right
2998 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2999 insert_pad $y0 $x0 1
3000 set offs [incrange $offs $col 1]
3001 optimize_rows $y0 [expr {$x0 + 1}] $row
3004 if {!$haspad} {
3005 set o {}
3006 # Find the first column that doesn't have a line going right
3007 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3008 set o [lindex $offs $col]
3009 if {$o eq {}} {
3010 # check if this is the link to the first child
3011 set id [lindex $idlist $col]
3012 set ranges [rowranges $id]
3013 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3014 # it is, work out offset to child
3015 set y0 [expr {$row - 1}]
3016 set id [lindex $displayorder $y0]
3017 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3018 if {$x0 >= 0} {
3019 set o [expr {$x0 - $col}]
3023 if {$o eq {} || $o <= 0} break
3025 # Insert a pad at that column as long as it has a line and
3026 # isn't the last column, and adjust the next row' offsets
3027 if {$o ne {} && [incr col] < [llength $idlist]} {
3028 set y1 [expr {$row + 1}]
3029 set offs2 [lindex $rowoffsets $y1]
3030 set x1 -1
3031 foreach z $offs2 {
3032 incr x1
3033 if {$z eq {} || $x1 + $z < $col} continue
3034 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3035 break
3037 set idlist [linsert $idlist $col {}]
3038 set tmp [linsert $offs $col {}]
3039 incr col
3040 set offs [incrange $tmp $col -1]
3043 lset rowidlist $row $idlist
3044 lset rowoffsets $row $offs
3045 set col 0
3049 proc xc {row col} {
3050 global canvx0 linespc
3051 return [expr {$canvx0 + $col * $linespc}]
3054 proc yc {row} {
3055 global canvy0 linespc
3056 return [expr {$canvy0 + $row * $linespc}]
3059 proc linewidth {id} {
3060 global thickerline lthickness
3062 set wid $lthickness
3063 if {[info exists thickerline] && $id eq $thickerline} {
3064 set wid [expr {2 * $lthickness}]
3066 return $wid
3069 proc rowranges {id} {
3070 global phase idrowranges commitrow rowlaidout rowrangelist curview
3072 set ranges {}
3073 if {$phase eq {} ||
3074 ([info exists commitrow($curview,$id)]
3075 && $commitrow($curview,$id) < $rowlaidout)} {
3076 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3077 } elseif {[info exists idrowranges($id)]} {
3078 set ranges $idrowranges($id)
3080 set linenos {}
3081 foreach rid $ranges {
3082 lappend linenos $commitrow($curview,$rid)
3084 if {$linenos ne {}} {
3085 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3087 return $linenos
3090 # work around tk8.4 refusal to draw arrows on diagonal segments
3091 proc adjarrowhigh {coords} {
3092 global linespc
3094 set x0 [lindex $coords 0]
3095 set x1 [lindex $coords 2]
3096 if {$x0 != $x1} {
3097 set y0 [lindex $coords 1]
3098 set y1 [lindex $coords 3]
3099 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3100 # we have a nearby vertical segment, just trim off the diag bit
3101 set coords [lrange $coords 2 end]
3102 } else {
3103 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3104 set xi [expr {$x0 - $slope * $linespc / 2}]
3105 set yi [expr {$y0 - $linespc / 2}]
3106 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3109 return $coords
3112 proc drawlineseg {id row endrow arrowlow} {
3113 global rowidlist displayorder iddrawn linesegs
3114 global canv colormap linespc curview maxlinelen
3116 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3117 set le [expr {$row + 1}]
3118 set arrowhigh 1
3119 while {1} {
3120 set c [lsearch -exact [lindex $rowidlist $le] $id]
3121 if {$c < 0} {
3122 incr le -1
3123 break
3125 lappend cols $c
3126 set x [lindex $displayorder $le]
3127 if {$x eq $id} {
3128 set arrowhigh 0
3129 break
3131 if {[info exists iddrawn($x)] || $le == $endrow} {
3132 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3133 if {$c >= 0} {
3134 lappend cols $c
3135 set arrowhigh 0
3137 break
3139 incr le
3141 if {$le <= $row} {
3142 return $row
3145 set lines {}
3146 set i 0
3147 set joinhigh 0
3148 if {[info exists linesegs($id)]} {
3149 set lines $linesegs($id)
3150 foreach li $lines {
3151 set r0 [lindex $li 0]
3152 if {$r0 > $row} {
3153 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3154 set joinhigh 1
3156 break
3158 incr i
3161 set joinlow 0
3162 if {$i > 0} {
3163 set li [lindex $lines [expr {$i-1}]]
3164 set r1 [lindex $li 1]
3165 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3166 set joinlow 1
3170 set x [lindex $cols [expr {$le - $row}]]
3171 set xp [lindex $cols [expr {$le - 1 - $row}]]
3172 set dir [expr {$xp - $x}]
3173 if {$joinhigh} {
3174 set ith [lindex $lines $i 2]
3175 set coords [$canv coords $ith]
3176 set ah [$canv itemcget $ith -arrow]
3177 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3178 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3179 if {$x2 ne {} && $x - $x2 == $dir} {
3180 set coords [lrange $coords 0 end-2]
3182 } else {
3183 set coords [list [xc $le $x] [yc $le]]
3185 if {$joinlow} {
3186 set itl [lindex $lines [expr {$i-1}] 2]
3187 set al [$canv itemcget $itl -arrow]
3188 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3189 } elseif {$arrowlow &&
3190 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3191 set arrowlow 0
3193 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3194 for {set y $le} {[incr y -1] > $row} {} {
3195 set x $xp
3196 set xp [lindex $cols [expr {$y - 1 - $row}]]
3197 set ndir [expr {$xp - $x}]
3198 if {$dir != $ndir || $xp < 0} {
3199 lappend coords [xc $y $x] [yc $y]
3201 set dir $ndir
3203 if {!$joinlow} {
3204 if {$xp < 0} {
3205 # join parent line to first child
3206 set ch [lindex $displayorder $row]
3207 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3208 if {$xc < 0} {
3209 puts "oops: drawlineseg: child $ch not on row $row"
3210 } else {
3211 if {$xc < $x - 1} {
3212 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3213 } elseif {$xc > $x + 1} {
3214 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3216 set x $xc
3218 lappend coords [xc $row $x] [yc $row]
3219 } else {
3220 set xn [xc $row $xp]
3221 set yn [yc $row]
3222 # work around tk8.4 refusal to draw arrows on diagonal segments
3223 if {$arrowlow && $xn != [lindex $coords end-1]} {
3224 if {[llength $coords] < 4 ||
3225 [lindex $coords end-3] != [lindex $coords end-1] ||
3226 [lindex $coords end] - $yn > 2 * $linespc} {
3227 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3228 set yo [yc [expr {$row + 0.5}]]
3229 lappend coords $xn $yo $xn $yn
3231 } else {
3232 lappend coords $xn $yn
3235 if {!$joinhigh} {
3236 if {$arrowhigh} {
3237 set coords [adjarrowhigh $coords]
3239 assigncolor $id
3240 set t [$canv create line $coords -width [linewidth $id] \
3241 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3242 $canv lower $t
3243 bindline $t $id
3244 set lines [linsert $lines $i [list $row $le $t]]
3245 } else {
3246 $canv coords $ith $coords
3247 if {$arrow ne $ah} {
3248 $canv itemconf $ith -arrow $arrow
3250 lset lines $i 0 $row
3252 } else {
3253 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3254 set ndir [expr {$xo - $xp}]
3255 set clow [$canv coords $itl]
3256 if {$dir == $ndir} {
3257 set clow [lrange $clow 2 end]
3259 set coords [concat $coords $clow]
3260 if {!$joinhigh} {
3261 lset lines [expr {$i-1}] 1 $le
3262 if {$arrowhigh} {
3263 set coords [adjarrowhigh $coords]
3265 } else {
3266 # coalesce two pieces
3267 $canv delete $ith
3268 set b [lindex $lines [expr {$i-1}] 0]
3269 set e [lindex $lines $i 1]
3270 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3272 $canv coords $itl $coords
3273 if {$arrow ne $al} {
3274 $canv itemconf $itl -arrow $arrow
3278 set linesegs($id) $lines
3279 return $le
3282 proc drawparentlinks {id row} {
3283 global rowidlist canv colormap curview parentlist
3284 global idpos
3286 set rowids [lindex $rowidlist $row]
3287 set col [lsearch -exact $rowids $id]
3288 if {$col < 0} return
3289 set olds [lindex $parentlist $row]
3290 set row2 [expr {$row + 1}]
3291 set x [xc $row $col]
3292 set y [yc $row]
3293 set y2 [yc $row2]
3294 set ids [lindex $rowidlist $row2]
3295 # rmx = right-most X coord used
3296 set rmx 0
3297 foreach p $olds {
3298 set i [lsearch -exact $ids $p]
3299 if {$i < 0} {
3300 puts "oops, parent $p of $id not in list"
3301 continue
3303 set x2 [xc $row2 $i]
3304 if {$x2 > $rmx} {
3305 set rmx $x2
3307 if {[lsearch -exact $rowids $p] < 0} {
3308 # drawlineseg will do this one for us
3309 continue
3311 assigncolor $p
3312 # should handle duplicated parents here...
3313 set coords [list $x $y]
3314 if {$i < $col - 1} {
3315 lappend coords [xc $row [expr {$i + 1}]] $y
3316 } elseif {$i > $col + 1} {
3317 lappend coords [xc $row [expr {$i - 1}]] $y
3319 lappend coords $x2 $y2
3320 set t [$canv create line $coords -width [linewidth $p] \
3321 -fill $colormap($p) -tags lines.$p]
3322 $canv lower $t
3323 bindline $t $p
3325 if {$rmx > [lindex $idpos($id) 1]} {
3326 lset idpos($id) 1 $rmx
3327 redrawtags $id
3331 proc drawlines {id} {
3332 global canv
3334 $canv itemconf lines.$id -width [linewidth $id]
3337 proc drawcmittext {id row col} {
3338 global linespc canv canv2 canv3 canvy0 fgcolor curview
3339 global commitlisted commitinfo rowidlist parentlist
3340 global rowtextx idpos idtags idheads idotherrefs
3341 global linehtag linentag linedtag markingmatches
3342 global mainfont canvxmax boldrows boldnamerows fgcolor nullid
3344 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3345 set listed [lindex $commitlisted $row]
3346 if {$id eq $nullid} {
3347 set ofill red
3348 } else {
3349 set ofill [expr {$listed != 0? "blue": "white"}]
3351 set x [xc $row $col]
3352 set y [yc $row]
3353 set orad [expr {$linespc / 3}]
3354 if {$listed <= 1} {
3355 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3356 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3357 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3358 } elseif {$listed == 2} {
3359 # triangle pointing left for left-side commits
3360 set t [$canv create polygon \
3361 [expr {$x - $orad}] $y \
3362 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3363 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3364 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3365 } else {
3366 # triangle pointing right for right-side commits
3367 set t [$canv create polygon \
3368 [expr {$x + $orad - 1}] $y \
3369 [expr {$x - $orad}] [expr {$y - $orad}] \
3370 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3371 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3373 $canv raise $t
3374 $canv bind $t <1> {selcanvline {} %x %y}
3375 set rmx [llength [lindex $rowidlist $row]]
3376 set olds [lindex $parentlist $row]
3377 if {$olds ne {}} {
3378 set nextids [lindex $rowidlist [expr {$row + 1}]]
3379 foreach p $olds {
3380 set i [lsearch -exact $nextids $p]
3381 if {$i > $rmx} {
3382 set rmx $i
3386 set xt [xc $row $rmx]
3387 set rowtextx($row) $xt
3388 set idpos($id) [list $x $xt $y]
3389 if {[info exists idtags($id)] || [info exists idheads($id)]
3390 || [info exists idotherrefs($id)]} {
3391 set xt [drawtags $id $x $xt $y]
3393 set headline [lindex $commitinfo($id) 0]
3394 set name [lindex $commitinfo($id) 1]
3395 set date [lindex $commitinfo($id) 2]
3396 set date [formatdate $date]
3397 set font $mainfont
3398 set nfont $mainfont
3399 set isbold [ishighlighted $row]
3400 if {$isbold > 0} {
3401 lappend boldrows $row
3402 lappend font bold
3403 if {$isbold > 1} {
3404 lappend boldnamerows $row
3405 lappend nfont bold
3408 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3409 -text $headline -font $font -tags text]
3410 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3411 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3412 -text $name -font $nfont -tags text]
3413 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3414 -text $date -font $mainfont -tags text]
3415 set xr [expr {$xt + [font measure $mainfont $headline]}]
3416 if {$markingmatches} {
3417 markrowmatches $row $headline $name
3419 if {$xr > $canvxmax} {
3420 set canvxmax $xr
3421 setcanvscroll
3425 proc drawcmitrow {row} {
3426 global displayorder rowidlist
3427 global iddrawn
3428 global commitinfo parentlist numcommits
3429 global filehighlight fhighlights findstring nhighlights
3430 global hlview vhighlights
3431 global highlight_related rhighlights
3433 if {$row >= $numcommits} return
3435 set id [lindex $displayorder $row]
3436 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3437 askvhighlight $row $id
3439 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3440 askfilehighlight $row $id
3442 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3443 askfindhighlight $row $id
3445 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3446 askrelhighlight $row $id
3448 if {[info exists iddrawn($id)]} return
3449 set col [lsearch -exact [lindex $rowidlist $row] $id]
3450 if {$col < 0} {
3451 puts "oops, row $row id $id not in list"
3452 return
3454 if {![info exists commitinfo($id)]} {
3455 getcommit $id
3457 assigncolor $id
3458 drawcmittext $id $row $col
3459 set iddrawn($id) 1
3462 proc drawcommits {row {endrow {}}} {
3463 global numcommits iddrawn displayorder curview
3464 global parentlist rowidlist
3466 if {$row < 0} {
3467 set row 0
3469 if {$endrow eq {}} {
3470 set endrow $row
3472 if {$endrow >= $numcommits} {
3473 set endrow [expr {$numcommits - 1}]
3476 # make the lines join to already-drawn rows either side
3477 set r [expr {$row - 1}]
3478 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3479 set r $row
3481 set er [expr {$endrow + 1}]
3482 if {$er >= $numcommits ||
3483 ![info exists iddrawn([lindex $displayorder $er])]} {
3484 set er $endrow
3486 for {} {$r <= $er} {incr r} {
3487 set id [lindex $displayorder $r]
3488 set wasdrawn [info exists iddrawn($id)]
3489 drawcmitrow $r
3490 if {$r == $er} break
3491 set nextid [lindex $displayorder [expr {$r + 1}]]
3492 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3493 catch {unset prevlines}
3494 continue
3496 drawparentlinks $id $r
3498 if {[info exists lineends($r)]} {
3499 foreach lid $lineends($r) {
3500 unset prevlines($lid)
3503 set rowids [lindex $rowidlist $r]
3504 foreach lid $rowids {
3505 if {$lid eq {}} continue
3506 if {$lid eq $id} {
3507 # see if this is the first child of any of its parents
3508 foreach p [lindex $parentlist $r] {
3509 if {[lsearch -exact $rowids $p] < 0} {
3510 # make this line extend up to the child
3511 set le [drawlineseg $p $r $er 0]
3512 lappend lineends($le) $p
3513 set prevlines($p) 1
3516 } elseif {![info exists prevlines($lid)]} {
3517 set le [drawlineseg $lid $r $er 1]
3518 lappend lineends($le) $lid
3519 set prevlines($lid) 1
3525 proc drawfrac {f0 f1} {
3526 global canv linespc
3528 set ymax [lindex [$canv cget -scrollregion] 3]
3529 if {$ymax eq {} || $ymax == 0} return
3530 set y0 [expr {int($f0 * $ymax)}]
3531 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3532 set y1 [expr {int($f1 * $ymax)}]
3533 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3534 drawcommits $row $endrow
3537 proc drawvisible {} {
3538 global canv
3539 eval drawfrac [$canv yview]
3542 proc clear_display {} {
3543 global iddrawn linesegs
3544 global vhighlights fhighlights nhighlights rhighlights
3546 allcanvs delete all
3547 catch {unset iddrawn}
3548 catch {unset linesegs}
3549 catch {unset vhighlights}
3550 catch {unset fhighlights}
3551 catch {unset nhighlights}
3552 catch {unset rhighlights}
3555 proc findcrossings {id} {
3556 global rowidlist parentlist numcommits rowoffsets displayorder
3558 set cross {}
3559 set ccross {}
3560 foreach {s e} [rowranges $id] {
3561 if {$e >= $numcommits} {
3562 set e [expr {$numcommits - 1}]
3564 if {$e <= $s} continue
3565 set x [lsearch -exact [lindex $rowidlist $e] $id]
3566 if {$x < 0} {
3567 puts "findcrossings: oops, no [shortids $id] in row $e"
3568 continue
3570 for {set row $e} {[incr row -1] >= $s} {} {
3571 set olds [lindex $parentlist $row]
3572 set kid [lindex $displayorder $row]
3573 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3574 if {$kidx < 0} continue
3575 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3576 foreach p $olds {
3577 set px [lsearch -exact $nextrow $p]
3578 if {$px < 0} continue
3579 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3580 if {[lsearch -exact $ccross $p] >= 0} continue
3581 if {$x == $px + ($kidx < $px? -1: 1)} {
3582 lappend ccross $p
3583 } elseif {[lsearch -exact $cross $p] < 0} {
3584 lappend cross $p
3588 set inc [lindex $rowoffsets $row $x]
3589 if {$inc eq {}} break
3590 incr x $inc
3593 return [concat $ccross {{}} $cross]
3596 proc assigncolor {id} {
3597 global colormap colors nextcolor
3598 global commitrow parentlist children children curview
3600 if {[info exists colormap($id)]} return
3601 set ncolors [llength $colors]
3602 if {[info exists children($curview,$id)]} {
3603 set kids $children($curview,$id)
3604 } else {
3605 set kids {}
3607 if {[llength $kids] == 1} {
3608 set child [lindex $kids 0]
3609 if {[info exists colormap($child)]
3610 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3611 set colormap($id) $colormap($child)
3612 return
3615 set badcolors {}
3616 set origbad {}
3617 foreach x [findcrossings $id] {
3618 if {$x eq {}} {
3619 # delimiter between corner crossings and other crossings
3620 if {[llength $badcolors] >= $ncolors - 1} break
3621 set origbad $badcolors
3623 if {[info exists colormap($x)]
3624 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3625 lappend badcolors $colormap($x)
3628 if {[llength $badcolors] >= $ncolors} {
3629 set badcolors $origbad
3631 set origbad $badcolors
3632 if {[llength $badcolors] < $ncolors - 1} {
3633 foreach child $kids {
3634 if {[info exists colormap($child)]
3635 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3636 lappend badcolors $colormap($child)
3638 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3639 if {[info exists colormap($p)]
3640 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3641 lappend badcolors $colormap($p)
3645 if {[llength $badcolors] >= $ncolors} {
3646 set badcolors $origbad
3649 for {set i 0} {$i <= $ncolors} {incr i} {
3650 set c [lindex $colors $nextcolor]
3651 if {[incr nextcolor] >= $ncolors} {
3652 set nextcolor 0
3654 if {[lsearch -exact $badcolors $c]} break
3656 set colormap($id) $c
3659 proc bindline {t id} {
3660 global canv
3662 $canv bind $t <Enter> "lineenter %x %y $id"
3663 $canv bind $t <Motion> "linemotion %x %y $id"
3664 $canv bind $t <Leave> "lineleave $id"
3665 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3668 proc drawtags {id x xt y1} {
3669 global idtags idheads idotherrefs mainhead
3670 global linespc lthickness
3671 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3673 set marks {}
3674 set ntags 0
3675 set nheads 0
3676 if {[info exists idtags($id)]} {
3677 set marks $idtags($id)
3678 set ntags [llength $marks]
3680 if {[info exists idheads($id)]} {
3681 set marks [concat $marks $idheads($id)]
3682 set nheads [llength $idheads($id)]
3684 if {[info exists idotherrefs($id)]} {
3685 set marks [concat $marks $idotherrefs($id)]
3687 if {$marks eq {}} {
3688 return $xt
3691 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3692 set yt [expr {$y1 - 0.5 * $linespc}]
3693 set yb [expr {$yt + $linespc - 1}]
3694 set xvals {}
3695 set wvals {}
3696 set i -1
3697 foreach tag $marks {
3698 incr i
3699 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3700 set wid [font measure [concat $mainfont bold] $tag]
3701 } else {
3702 set wid [font measure $mainfont $tag]
3704 lappend xvals $xt
3705 lappend wvals $wid
3706 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3708 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3709 -width $lthickness -fill black -tags tag.$id]
3710 $canv lower $t
3711 foreach tag $marks x $xvals wid $wvals {
3712 set xl [expr {$x + $delta}]
3713 set xr [expr {$x + $delta + $wid + $lthickness}]
3714 set font $mainfont
3715 if {[incr ntags -1] >= 0} {
3716 # draw a tag
3717 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3718 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3719 -width 1 -outline black -fill yellow -tags tag.$id]
3720 $canv bind $t <1> [list showtag $tag 1]
3721 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3722 } else {
3723 # draw a head or other ref
3724 if {[incr nheads -1] >= 0} {
3725 set col green
3726 if {$tag eq $mainhead} {
3727 lappend font bold
3729 } else {
3730 set col "#ddddff"
3732 set xl [expr {$xl - $delta/2}]
3733 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3734 -width 1 -outline black -fill $col -tags tag.$id
3735 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3736 set rwid [font measure $mainfont $remoteprefix]
3737 set xi [expr {$x + 1}]
3738 set yti [expr {$yt + 1}]
3739 set xri [expr {$x + $rwid}]
3740 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3741 -width 0 -fill "#ffddaa" -tags tag.$id
3744 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3745 -font $font -tags [list tag.$id text]]
3746 if {$ntags >= 0} {
3747 $canv bind $t <1> [list showtag $tag 1]
3748 } elseif {$nheads >= 0} {
3749 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3752 return $xt
3755 proc xcoord {i level ln} {
3756 global canvx0 xspc1 xspc2
3758 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3759 if {$i > 0 && $i == $level} {
3760 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3761 } elseif {$i > $level} {
3762 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3764 return $x
3767 proc show_status {msg} {
3768 global canv mainfont fgcolor
3770 clear_display
3771 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3772 -tags text -fill $fgcolor
3775 # Insert a new commit as the child of the commit on row $row.
3776 # The new commit will be displayed on row $row and the commits
3777 # on that row and below will move down one row.
3778 proc insertrow {row newcmit} {
3779 global displayorder parentlist commitlisted children
3780 global commitrow curview rowidlist rowoffsets numcommits
3781 global rowrangelist rowlaidout rowoptim numcommits
3782 global selectedline rowchk commitidx
3784 if {$row >= $numcommits} {
3785 puts "oops, inserting new row $row but only have $numcommits rows"
3786 return
3788 set p [lindex $displayorder $row]
3789 set displayorder [linsert $displayorder $row $newcmit]
3790 set parentlist [linsert $parentlist $row $p]
3791 set kids $children($curview,$p)
3792 lappend kids $newcmit
3793 set children($curview,$p) $kids
3794 set children($curview,$newcmit) {}
3795 set commitlisted [linsert $commitlisted $row 1]
3796 set l [llength $displayorder]
3797 for {set r $row} {$r < $l} {incr r} {
3798 set id [lindex $displayorder $r]
3799 set commitrow($curview,$id) $r
3801 incr commitidx($curview)
3803 set idlist [lindex $rowidlist $row]
3804 set offs [lindex $rowoffsets $row]
3805 set newoffs {}
3806 foreach x $idlist {
3807 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3808 lappend newoffs {}
3809 } else {
3810 lappend newoffs 0
3813 if {[llength $kids] == 1} {
3814 set col [lsearch -exact $idlist $p]
3815 lset idlist $col $newcmit
3816 } else {
3817 set col [llength $idlist]
3818 lappend idlist $newcmit
3819 lappend offs {}
3820 lset rowoffsets $row $offs
3822 set rowidlist [linsert $rowidlist $row $idlist]
3823 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3825 set rowrangelist [linsert $rowrangelist $row {}]
3826 if {[llength $kids] > 1} {
3827 set rp1 [expr {$row + 1}]
3828 set ranges [lindex $rowrangelist $rp1]
3829 if {$ranges eq {}} {
3830 set ranges [list $newcmit $p]
3831 } elseif {[lindex $ranges end-1] eq $p} {
3832 lset ranges end-1 $newcmit
3834 lset rowrangelist $rp1 $ranges
3837 catch {unset rowchk}
3839 incr rowlaidout
3840 incr rowoptim
3841 incr numcommits
3843 if {[info exists selectedline] && $selectedline >= $row} {
3844 incr selectedline
3846 redisplay
3849 # Remove a commit that was inserted with insertrow on row $row.
3850 proc removerow {row} {
3851 global displayorder parentlist commitlisted children
3852 global commitrow curview rowidlist rowoffsets numcommits
3853 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3854 global linesegends selectedline rowchk commitidx
3856 if {$row >= $numcommits} {
3857 puts "oops, removing row $row but only have $numcommits rows"
3858 return
3860 set rp1 [expr {$row + 1}]
3861 set id [lindex $displayorder $row]
3862 set p [lindex $parentlist $row]
3863 set displayorder [lreplace $displayorder $row $row]
3864 set parentlist [lreplace $parentlist $row $row]
3865 set commitlisted [lreplace $commitlisted $row $row]
3866 set kids $children($curview,$p)
3867 set i [lsearch -exact $kids $id]
3868 if {$i >= 0} {
3869 set kids [lreplace $kids $i $i]
3870 set children($curview,$p) $kids
3872 set l [llength $displayorder]
3873 for {set r $row} {$r < $l} {incr r} {
3874 set id [lindex $displayorder $r]
3875 set commitrow($curview,$id) $r
3877 incr commitidx($curview) -1
3879 set rowidlist [lreplace $rowidlist $row $row]
3880 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3881 if {$kids ne {}} {
3882 set offs [lindex $rowoffsets $row]
3883 set offs [lreplace $offs end end]
3884 lset rowoffsets $row $offs
3887 set rowrangelist [lreplace $rowrangelist $row $row]
3888 if {[llength $kids] > 0} {
3889 set ranges [lindex $rowrangelist $row]
3890 if {[lindex $ranges end-1] eq $id} {
3891 set ranges [lreplace $ranges end-1 end]
3892 lset rowrangelist $row $ranges
3896 catch {unset rowchk}
3898 incr rowlaidout -1
3899 incr rowoptim -1
3900 incr numcommits -1
3902 if {[info exists selectedline] && $selectedline > $row} {
3903 incr selectedline -1
3905 redisplay
3908 # Don't change the text pane cursor if it is currently the hand cursor,
3909 # showing that we are over a sha1 ID link.
3910 proc settextcursor {c} {
3911 global ctext curtextcursor
3913 if {[$ctext cget -cursor] == $curtextcursor} {
3914 $ctext config -cursor $c
3916 set curtextcursor $c
3919 proc nowbusy {what} {
3920 global isbusy
3922 if {[array names isbusy] eq {}} {
3923 . config -cursor watch
3924 settextcursor watch
3926 set isbusy($what) 1
3929 proc notbusy {what} {
3930 global isbusy maincursor textcursor
3932 catch {unset isbusy($what)}
3933 if {[array names isbusy] eq {}} {
3934 . config -cursor $maincursor
3935 settextcursor $textcursor
3939 proc findmatches {f} {
3940 global findtype findstring
3941 if {$findtype == "Regexp"} {
3942 set matches [regexp -indices -all -inline $findstring $f]
3943 } else {
3944 set fs $findstring
3945 if {$findtype == "IgnCase"} {
3946 set f [string tolower $f]
3947 set fs [string tolower $fs]
3949 set matches {}
3950 set i 0
3951 set l [string length $fs]
3952 while {[set j [string first $fs $f $i]] >= 0} {
3953 lappend matches [list $j [expr {$j+$l-1}]]
3954 set i [expr {$j + $l}]
3957 return $matches
3960 proc dofind {{rev 0}} {
3961 global findstring findstartline findcurline selectedline numcommits
3963 unmarkmatches
3964 cancel_next_highlight
3965 focus .
3966 if {$findstring eq {} || $numcommits == 0} return
3967 if {![info exists selectedline]} {
3968 set findstartline [lindex [visiblerows] $rev]
3969 } else {
3970 set findstartline $selectedline
3972 set findcurline $findstartline
3973 nowbusy finding
3974 if {!$rev} {
3975 run findmore
3976 } else {
3977 set findcurline $findstartline
3978 if {$findcurline == 0} {
3979 set findcurline $numcommits
3981 incr findcurline -1
3982 run findmorerev
3986 proc findnext {restart} {
3987 global findcurline
3988 if {![info exists findcurline]} {
3989 if {$restart} {
3990 dofind
3991 } else {
3992 bell
3994 } else {
3995 run findmore
3996 nowbusy finding
4000 proc findprev {} {
4001 global findcurline
4002 if {![info exists findcurline]} {
4003 dofind 1
4004 } else {
4005 run findmorerev
4006 nowbusy finding
4010 proc findmore {} {
4011 global commitdata commitinfo numcommits findstring findpattern findloc
4012 global findstartline findcurline markingmatches displayorder
4014 set fldtypes {Headline Author Date Committer CDate Comments}
4015 set l [expr {$findcurline + 1}]
4016 if {$l >= $numcommits} {
4017 set l 0
4019 if {$l <= $findstartline} {
4020 set lim [expr {$findstartline + 1}]
4021 } else {
4022 set lim $numcommits
4024 if {$lim - $l > 500} {
4025 set lim [expr {$l + 500}]
4027 set last 0
4028 for {} {$l < $lim} {incr l} {
4029 set id [lindex $displayorder $l]
4030 if {![doesmatch $commitdata($id)]} continue
4031 if {![info exists commitinfo($id)]} {
4032 getcommit $id
4034 set info $commitinfo($id)
4035 foreach f $info ty $fldtypes {
4036 if {($findloc eq "All fields" || $findloc eq $ty) &&
4037 [doesmatch $f]} {
4038 set markingmatches 1
4039 findselectline $l
4040 notbusy finding
4041 return 0
4045 if {$l == $findstartline + 1} {
4046 bell
4047 unset findcurline
4048 notbusy finding
4049 return 0
4051 set findcurline [expr {$l - 1}]
4052 return 1
4055 proc findmorerev {} {
4056 global commitdata commitinfo numcommits findstring findpattern findloc
4057 global findstartline findcurline markingmatches displayorder
4059 set fldtypes {Headline Author Date Committer CDate Comments}
4060 set l $findcurline
4061 if {$l == 0} {
4062 set l $numcommits
4064 incr l -1
4065 if {$l >= $findstartline} {
4066 set lim [expr {$findstartline - 1}]
4067 } else {
4068 set lim -1
4070 if {$l - $lim > 500} {
4071 set lim [expr {$l - 500}]
4073 set last 0
4074 for {} {$l > $lim} {incr l -1} {
4075 set id [lindex $displayorder $l]
4076 if {![doesmatch $commitdata($id)]} continue
4077 if {![info exists commitinfo($id)]} {
4078 getcommit $id
4080 set info $commitinfo($id)
4081 foreach f $info ty $fldtypes {
4082 if {($findloc eq "All fields" || $findloc eq $ty) &&
4083 [doesmatch $f]} {
4084 set markingmatches 1
4085 findselectline $l
4086 notbusy finding
4087 return 0
4091 if {$l == -1} {
4092 bell
4093 unset findcurline
4094 notbusy finding
4095 return 0
4097 set findcurline [expr {$l + 1}]
4098 return 1
4101 proc findselectline {l} {
4102 global findloc commentend ctext
4103 selectline $l 1
4104 if {$findloc == "All fields" || $findloc == "Comments"} {
4105 # highlight the matches in the comments
4106 set f [$ctext get 1.0 $commentend]
4107 set matches [findmatches $f]
4108 foreach match $matches {
4109 set start [lindex $match 0]
4110 set end [expr {[lindex $match 1] + 1}]
4111 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4116 # mark the bits of a headline or author that match a find string
4117 proc markmatches {canv l str tag matches font} {
4118 set bbox [$canv bbox $tag]
4119 set x0 [lindex $bbox 0]
4120 set y0 [lindex $bbox 1]
4121 set y1 [lindex $bbox 3]
4122 foreach match $matches {
4123 set start [lindex $match 0]
4124 set end [lindex $match 1]
4125 if {$start > $end} continue
4126 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4127 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4128 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4129 [expr {$x0+$xlen+2}] $y1 \
4130 -outline {} -tags [list match$l matches] -fill yellow]
4131 $canv lower $t
4135 proc unmarkmatches {} {
4136 global findids markingmatches findcurline
4138 allcanvs delete matches
4139 catch {unset findids}
4140 set markingmatches 0
4141 catch {unset findcurline}
4144 proc selcanvline {w x y} {
4145 global canv canvy0 ctext linespc
4146 global rowtextx
4147 set ymax [lindex [$canv cget -scrollregion] 3]
4148 if {$ymax == {}} return
4149 set yfrac [lindex [$canv yview] 0]
4150 set y [expr {$y + $yfrac * $ymax}]
4151 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4152 if {$l < 0} {
4153 set l 0
4155 if {$w eq $canv} {
4156 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4158 unmarkmatches
4159 selectline $l 1
4162 proc commit_descriptor {p} {
4163 global commitinfo
4164 if {![info exists commitinfo($p)]} {
4165 getcommit $p
4167 set l "..."
4168 if {[llength $commitinfo($p)] > 1} {
4169 set l [lindex $commitinfo($p) 0]
4171 return "$p ($l)\n"
4174 # append some text to the ctext widget, and make any SHA1 ID
4175 # that we know about be a clickable link.
4176 proc appendwithlinks {text tags} {
4177 global ctext commitrow linknum curview
4179 set start [$ctext index "end - 1c"]
4180 $ctext insert end $text $tags
4181 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4182 foreach l $links {
4183 set s [lindex $l 0]
4184 set e [lindex $l 1]
4185 set linkid [string range $text $s $e]
4186 if {![info exists commitrow($curview,$linkid)]} continue
4187 incr e
4188 $ctext tag add link "$start + $s c" "$start + $e c"
4189 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4190 $ctext tag bind link$linknum <1> \
4191 [list selectline $commitrow($curview,$linkid) 1]
4192 incr linknum
4194 $ctext tag conf link -foreground blue -underline 1
4195 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4196 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4199 proc viewnextline {dir} {
4200 global canv linespc
4202 $canv delete hover
4203 set ymax [lindex [$canv cget -scrollregion] 3]
4204 set wnow [$canv yview]
4205 set wtop [expr {[lindex $wnow 0] * $ymax}]
4206 set newtop [expr {$wtop + $dir * $linespc}]
4207 if {$newtop < 0} {
4208 set newtop 0
4209 } elseif {$newtop > $ymax} {
4210 set newtop $ymax
4212 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4215 # add a list of tag or branch names at position pos
4216 # returns the number of names inserted
4217 proc appendrefs {pos ids var} {
4218 global ctext commitrow linknum curview $var maxrefs
4220 if {[catch {$ctext index $pos}]} {
4221 return 0
4223 $ctext conf -state normal
4224 $ctext delete $pos "$pos lineend"
4225 set tags {}
4226 foreach id $ids {
4227 foreach tag [set $var\($id\)] {
4228 lappend tags [list $tag $id]
4231 if {[llength $tags] > $maxrefs} {
4232 $ctext insert $pos "many ([llength $tags])"
4233 } else {
4234 set tags [lsort -index 0 -decreasing $tags]
4235 set sep {}
4236 foreach ti $tags {
4237 set id [lindex $ti 1]
4238 set lk link$linknum
4239 incr linknum
4240 $ctext tag delete $lk
4241 $ctext insert $pos $sep
4242 $ctext insert $pos [lindex $ti 0] $lk
4243 if {[info exists commitrow($curview,$id)]} {
4244 $ctext tag conf $lk -foreground blue
4245 $ctext tag bind $lk <1> \
4246 [list selectline $commitrow($curview,$id) 1]
4247 $ctext tag conf $lk -underline 1
4248 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4249 $ctext tag bind $lk <Leave> \
4250 { %W configure -cursor $curtextcursor }
4252 set sep ", "
4255 $ctext conf -state disabled
4256 return [llength $tags]
4259 # called when we have finished computing the nearby tags
4260 proc dispneartags {delay} {
4261 global selectedline currentid showneartags tagphase
4263 if {![info exists selectedline] || !$showneartags} return
4264 after cancel dispnexttag
4265 if {$delay} {
4266 after 200 dispnexttag
4267 set tagphase -1
4268 } else {
4269 after idle dispnexttag
4270 set tagphase 0
4274 proc dispnexttag {} {
4275 global selectedline currentid showneartags tagphase ctext
4277 if {![info exists selectedline] || !$showneartags} return
4278 switch -- $tagphase {
4280 set dtags [desctags $currentid]
4281 if {$dtags ne {}} {
4282 appendrefs precedes $dtags idtags
4286 set atags [anctags $currentid]
4287 if {$atags ne {}} {
4288 appendrefs follows $atags idtags
4292 set dheads [descheads $currentid]
4293 if {$dheads ne {}} {
4294 if {[appendrefs branch $dheads idheads] > 1
4295 && [$ctext get "branch -3c"] eq "h"} {
4296 # turn "Branch" into "Branches"
4297 $ctext conf -state normal
4298 $ctext insert "branch -2c" "es"
4299 $ctext conf -state disabled
4304 if {[incr tagphase] <= 2} {
4305 after idle dispnexttag
4309 proc selectline {l isnew} {
4310 global canv canv2 canv3 ctext commitinfo selectedline
4311 global displayorder linehtag linentag linedtag
4312 global canvy0 linespc parentlist children curview
4313 global currentid sha1entry
4314 global commentend idtags linknum
4315 global mergemax numcommits pending_select
4316 global cmitmode showneartags allcommits
4318 catch {unset pending_select}
4319 $canv delete hover
4320 normalline
4321 cancel_next_highlight
4322 if {$l < 0 || $l >= $numcommits} return
4323 set y [expr {$canvy0 + $l * $linespc}]
4324 set ymax [lindex [$canv cget -scrollregion] 3]
4325 set ytop [expr {$y - $linespc - 1}]
4326 set ybot [expr {$y + $linespc + 1}]
4327 set wnow [$canv yview]
4328 set wtop [expr {[lindex $wnow 0] * $ymax}]
4329 set wbot [expr {[lindex $wnow 1] * $ymax}]
4330 set wh [expr {$wbot - $wtop}]
4331 set newtop $wtop
4332 if {$ytop < $wtop} {
4333 if {$ybot < $wtop} {
4334 set newtop [expr {$y - $wh / 2.0}]
4335 } else {
4336 set newtop $ytop
4337 if {$newtop > $wtop - $linespc} {
4338 set newtop [expr {$wtop - $linespc}]
4341 } elseif {$ybot > $wbot} {
4342 if {$ytop > $wbot} {
4343 set newtop [expr {$y - $wh / 2.0}]
4344 } else {
4345 set newtop [expr {$ybot - $wh}]
4346 if {$newtop < $wtop + $linespc} {
4347 set newtop [expr {$wtop + $linespc}]
4351 if {$newtop != $wtop} {
4352 if {$newtop < 0} {
4353 set newtop 0
4355 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4356 drawvisible
4359 if {![info exists linehtag($l)]} return
4360 $canv delete secsel
4361 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4362 -tags secsel -fill [$canv cget -selectbackground]]
4363 $canv lower $t
4364 $canv2 delete secsel
4365 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4366 -tags secsel -fill [$canv2 cget -selectbackground]]
4367 $canv2 lower $t
4368 $canv3 delete secsel
4369 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4370 -tags secsel -fill [$canv3 cget -selectbackground]]
4371 $canv3 lower $t
4373 if {$isnew} {
4374 addtohistory [list selectline $l 0]
4377 set selectedline $l
4379 set id [lindex $displayorder $l]
4380 set currentid $id
4381 $sha1entry delete 0 end
4382 $sha1entry insert 0 $id
4383 $sha1entry selection from 0
4384 $sha1entry selection to end
4385 rhighlight_sel $id
4387 $ctext conf -state normal
4388 clear_ctext
4389 set linknum 0
4390 set info $commitinfo($id)
4391 set date [formatdate [lindex $info 2]]
4392 $ctext insert end "Author: [lindex $info 1] $date\n"
4393 set date [formatdate [lindex $info 4]]
4394 $ctext insert end "Committer: [lindex $info 3] $date\n"
4395 if {[info exists idtags($id)]} {
4396 $ctext insert end "Tags:"
4397 foreach tag $idtags($id) {
4398 $ctext insert end " $tag"
4400 $ctext insert end "\n"
4403 set headers {}
4404 set olds [lindex $parentlist $l]
4405 if {[llength $olds] > 1} {
4406 set np 0
4407 foreach p $olds {
4408 if {$np >= $mergemax} {
4409 set tag mmax
4410 } else {
4411 set tag m$np
4413 $ctext insert end "Parent: " $tag
4414 appendwithlinks [commit_descriptor $p] {}
4415 incr np
4417 } else {
4418 foreach p $olds {
4419 append headers "Parent: [commit_descriptor $p]"
4423 foreach c $children($curview,$id) {
4424 append headers "Child: [commit_descriptor $c]"
4427 # make anything that looks like a SHA1 ID be a clickable link
4428 appendwithlinks $headers {}
4429 if {$showneartags} {
4430 if {![info exists allcommits]} {
4431 getallcommits
4433 $ctext insert end "Branch: "
4434 $ctext mark set branch "end -1c"
4435 $ctext mark gravity branch left
4436 $ctext insert end "\nFollows: "
4437 $ctext mark set follows "end -1c"
4438 $ctext mark gravity follows left
4439 $ctext insert end "\nPrecedes: "
4440 $ctext mark set precedes "end -1c"
4441 $ctext mark gravity precedes left
4442 $ctext insert end "\n"
4443 dispneartags 1
4445 $ctext insert end "\n"
4446 set comment [lindex $info 5]
4447 if {[string first "\r" $comment] >= 0} {
4448 set comment [string map {"\r" "\n "} $comment]
4450 appendwithlinks $comment {comment}
4452 $ctext tag remove found 1.0 end
4453 $ctext conf -state disabled
4454 set commentend [$ctext index "end - 1c"]
4456 init_flist "Comments"
4457 if {$cmitmode eq "tree"} {
4458 gettree $id
4459 } elseif {[llength $olds] <= 1} {
4460 startdiff $id
4461 } else {
4462 mergediff $id $l
4466 proc selfirstline {} {
4467 unmarkmatches
4468 selectline 0 1
4471 proc sellastline {} {
4472 global numcommits
4473 unmarkmatches
4474 set l [expr {$numcommits - 1}]
4475 selectline $l 1
4478 proc selnextline {dir} {
4479 global selectedline
4480 if {![info exists selectedline]} return
4481 set l [expr {$selectedline + $dir}]
4482 unmarkmatches
4483 selectline $l 1
4486 proc selnextpage {dir} {
4487 global canv linespc selectedline numcommits
4489 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4490 if {$lpp < 1} {
4491 set lpp 1
4493 allcanvs yview scroll [expr {$dir * $lpp}] units
4494 drawvisible
4495 if {![info exists selectedline]} return
4496 set l [expr {$selectedline + $dir * $lpp}]
4497 if {$l < 0} {
4498 set l 0
4499 } elseif {$l >= $numcommits} {
4500 set l [expr $numcommits - 1]
4502 unmarkmatches
4503 selectline $l 1
4506 proc unselectline {} {
4507 global selectedline currentid
4509 catch {unset selectedline}
4510 catch {unset currentid}
4511 allcanvs delete secsel
4512 rhighlight_none
4513 cancel_next_highlight
4516 proc reselectline {} {
4517 global selectedline
4519 if {[info exists selectedline]} {
4520 selectline $selectedline 0
4524 proc addtohistory {cmd} {
4525 global history historyindex curview
4527 set elt [list $curview $cmd]
4528 if {$historyindex > 0
4529 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4530 return
4533 if {$historyindex < [llength $history]} {
4534 set history [lreplace $history $historyindex end $elt]
4535 } else {
4536 lappend history $elt
4538 incr historyindex
4539 if {$historyindex > 1} {
4540 .tf.bar.leftbut conf -state normal
4541 } else {
4542 .tf.bar.leftbut conf -state disabled
4544 .tf.bar.rightbut conf -state disabled
4547 proc godo {elt} {
4548 global curview
4550 set view [lindex $elt 0]
4551 set cmd [lindex $elt 1]
4552 if {$curview != $view} {
4553 showview $view
4555 eval $cmd
4558 proc goback {} {
4559 global history historyindex
4561 if {$historyindex > 1} {
4562 incr historyindex -1
4563 godo [lindex $history [expr {$historyindex - 1}]]
4564 .tf.bar.rightbut conf -state normal
4566 if {$historyindex <= 1} {
4567 .tf.bar.leftbut conf -state disabled
4571 proc goforw {} {
4572 global history historyindex
4574 if {$historyindex < [llength $history]} {
4575 set cmd [lindex $history $historyindex]
4576 incr historyindex
4577 godo $cmd
4578 .tf.bar.leftbut conf -state normal
4580 if {$historyindex >= [llength $history]} {
4581 .tf.bar.rightbut conf -state disabled
4585 proc gettree {id} {
4586 global treefilelist treeidlist diffids diffmergeid treepending nullid
4588 set diffids $id
4589 catch {unset diffmergeid}
4590 if {![info exists treefilelist($id)]} {
4591 if {![info exists treepending]} {
4592 if {$id ne $nullid} {
4593 set cmd [concat | git ls-tree -r $id]
4594 } else {
4595 set cmd [concat | git ls-files]
4597 if {[catch {set gtf [open $cmd r]}]} {
4598 return
4600 set treepending $id
4601 set treefilelist($id) {}
4602 set treeidlist($id) {}
4603 fconfigure $gtf -blocking 0
4604 filerun $gtf [list gettreeline $gtf $id]
4606 } else {
4607 setfilelist $id
4611 proc gettreeline {gtf id} {
4612 global treefilelist treeidlist treepending cmitmode diffids nullid
4614 set nl 0
4615 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4616 if {$diffids ne $nullid} {
4617 if {[lindex $line 1] ne "blob"} continue
4618 set i [string first "\t" $line]
4619 if {$i < 0} continue
4620 set sha1 [lindex $line 2]
4621 set fname [string range $line [expr {$i+1}] end]
4622 if {[string index $fname 0] eq "\""} {
4623 set fname [lindex $fname 0]
4625 lappend treeidlist($id) $sha1
4626 } else {
4627 set fname $line
4629 lappend treefilelist($id) $fname
4631 if {![eof $gtf]} {
4632 return [expr {$nl >= 1000? 2: 1}]
4634 close $gtf
4635 unset treepending
4636 if {$cmitmode ne "tree"} {
4637 if {![info exists diffmergeid]} {
4638 gettreediffs $diffids
4640 } elseif {$id ne $diffids} {
4641 gettree $diffids
4642 } else {
4643 setfilelist $id
4645 return 0
4648 proc showfile {f} {
4649 global treefilelist treeidlist diffids nullid
4650 global ctext commentend
4652 set i [lsearch -exact $treefilelist($diffids) $f]
4653 if {$i < 0} {
4654 puts "oops, $f not in list for id $diffids"
4655 return
4657 if {$diffids ne $nullid} {
4658 set blob [lindex $treeidlist($diffids) $i]
4659 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4660 puts "oops, error reading blob $blob: $err"
4661 return
4663 } else {
4664 if {[catch {set bf [open $f r]} err]} {
4665 puts "oops, can't read $f: $err"
4666 return
4669 fconfigure $bf -blocking 0
4670 filerun $bf [list getblobline $bf $diffids]
4671 $ctext config -state normal
4672 clear_ctext $commentend
4673 $ctext insert end "\n"
4674 $ctext insert end "$f\n" filesep
4675 $ctext config -state disabled
4676 $ctext yview $commentend
4679 proc getblobline {bf id} {
4680 global diffids cmitmode ctext
4682 if {$id ne $diffids || $cmitmode ne "tree"} {
4683 catch {close $bf}
4684 return 0
4686 $ctext config -state normal
4687 set nl 0
4688 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4689 $ctext insert end "$line\n"
4691 if {[eof $bf]} {
4692 # delete last newline
4693 $ctext delete "end - 2c" "end - 1c"
4694 close $bf
4695 return 0
4697 $ctext config -state disabled
4698 return [expr {$nl >= 1000? 2: 1}]
4701 proc mergediff {id l} {
4702 global diffmergeid diffopts mdifffd
4703 global diffids
4704 global parentlist
4706 set diffmergeid $id
4707 set diffids $id
4708 # this doesn't seem to actually affect anything...
4709 set env(GIT_DIFF_OPTS) $diffopts
4710 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4711 if {[catch {set mdf [open $cmd r]} err]} {
4712 error_popup "Error getting merge diffs: $err"
4713 return
4715 fconfigure $mdf -blocking 0
4716 set mdifffd($id) $mdf
4717 set np [llength [lindex $parentlist $l]]
4718 filerun $mdf [list getmergediffline $mdf $id $np]
4721 proc getmergediffline {mdf id np} {
4722 global diffmergeid ctext cflist mergemax
4723 global difffilestart mdifffd
4725 $ctext conf -state normal
4726 set nr 0
4727 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4728 if {![info exists diffmergeid] || $id != $diffmergeid
4729 || $mdf != $mdifffd($id)} {
4730 close $mdf
4731 return 0
4733 if {[regexp {^diff --cc (.*)} $line match fname]} {
4734 # start of a new file
4735 $ctext insert end "\n"
4736 set here [$ctext index "end - 1c"]
4737 lappend difffilestart $here
4738 add_flist [list $fname]
4739 set l [expr {(78 - [string length $fname]) / 2}]
4740 set pad [string range "----------------------------------------" 1 $l]
4741 $ctext insert end "$pad $fname $pad\n" filesep
4742 } elseif {[regexp {^@@} $line]} {
4743 $ctext insert end "$line\n" hunksep
4744 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4745 # do nothing
4746 } else {
4747 # parse the prefix - one ' ', '-' or '+' for each parent
4748 set spaces {}
4749 set minuses {}
4750 set pluses {}
4751 set isbad 0
4752 for {set j 0} {$j < $np} {incr j} {
4753 set c [string range $line $j $j]
4754 if {$c == " "} {
4755 lappend spaces $j
4756 } elseif {$c == "-"} {
4757 lappend minuses $j
4758 } elseif {$c == "+"} {
4759 lappend pluses $j
4760 } else {
4761 set isbad 1
4762 break
4765 set tags {}
4766 set num {}
4767 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4768 # line doesn't appear in result, parents in $minuses have the line
4769 set num [lindex $minuses 0]
4770 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4771 # line appears in result, parents in $pluses don't have the line
4772 lappend tags mresult
4773 set num [lindex $spaces 0]
4775 if {$num ne {}} {
4776 if {$num >= $mergemax} {
4777 set num "max"
4779 lappend tags m$num
4781 $ctext insert end "$line\n" $tags
4784 $ctext conf -state disabled
4785 if {[eof $mdf]} {
4786 close $mdf
4787 return 0
4789 return [expr {$nr >= 1000? 2: 1}]
4792 proc startdiff {ids} {
4793 global treediffs diffids treepending diffmergeid nullid
4795 set diffids $ids
4796 catch {unset diffmergeid}
4797 if {![info exists treediffs($ids)] || [lsearch -exact $ids $nullid] >= 0} {
4798 if {![info exists treepending]} {
4799 gettreediffs $ids
4801 } else {
4802 addtocflist $ids
4806 proc addtocflist {ids} {
4807 global treediffs cflist
4808 add_flist $treediffs($ids)
4809 getblobdiffs $ids
4812 proc diffcmd {ids flags} {
4813 global nullid
4815 set i [lsearch -exact $ids $nullid]
4816 if {$i >= 0} {
4817 set cmd [concat | git diff-index $flags]
4818 if {[llength $ids] > 1} {
4819 if {$i == 0} {
4820 lappend cmd -R [lindex $ids 1]
4821 } else {
4822 lappend cmd [lindex $ids 0]
4824 } else {
4825 lappend cmd HEAD
4827 } else {
4828 set cmd [concat | git diff-tree --no-commit-id -r $flags $ids]
4830 return $cmd
4833 proc gettreediffs {ids} {
4834 global treediff treepending
4836 set treepending $ids
4837 set treediff {}
4838 if {[catch {set gdtf [open [diffcmd $ids {}] r]}]} return
4839 fconfigure $gdtf -blocking 0
4840 filerun $gdtf [list gettreediffline $gdtf $ids]
4843 proc gettreediffline {gdtf ids} {
4844 global treediff treediffs treepending diffids diffmergeid
4845 global cmitmode
4847 set nr 0
4848 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4849 set i [string first "\t" $line]
4850 if {$i >= 0} {
4851 set file [string range $line [expr {$i+1}] end]
4852 if {[string index $file 0] eq "\""} {
4853 set file [lindex $file 0]
4855 lappend treediff $file
4858 if {![eof $gdtf]} {
4859 return [expr {$nr >= 1000? 2: 1}]
4861 close $gdtf
4862 set treediffs($ids) $treediff
4863 unset treepending
4864 if {$cmitmode eq "tree"} {
4865 gettree $diffids
4866 } elseif {$ids != $diffids} {
4867 if {![info exists diffmergeid]} {
4868 gettreediffs $diffids
4870 } else {
4871 addtocflist $ids
4873 return 0
4876 proc getblobdiffs {ids} {
4877 global diffopts blobdifffd diffids env
4878 global diffinhdr treediffs
4880 set env(GIT_DIFF_OPTS) $diffopts
4881 if {[catch {set bdf [open [diffcmd $ids {-p -C}] r]} err]} {
4882 puts "error getting diffs: $err"
4883 return
4885 set diffinhdr 0
4886 fconfigure $bdf -blocking 0
4887 set blobdifffd($ids) $bdf
4888 filerun $bdf [list getblobdiffline $bdf $diffids]
4891 proc setinlist {var i val} {
4892 global $var
4894 while {[llength [set $var]] < $i} {
4895 lappend $var {}
4897 if {[llength [set $var]] == $i} {
4898 lappend $var $val
4899 } else {
4900 lset $var $i $val
4904 proc makediffhdr {fname ids} {
4905 global ctext curdiffstart treediffs
4907 set i [lsearch -exact $treediffs($ids) $fname]
4908 if {$i >= 0} {
4909 setinlist difffilestart $i $curdiffstart
4911 set l [expr {(78 - [string length $fname]) / 2}]
4912 set pad [string range "----------------------------------------" 1 $l]
4913 $ctext insert $curdiffstart "$pad $fname $pad" filesep
4916 proc getblobdiffline {bdf ids} {
4917 global diffids blobdifffd ctext curdiffstart
4918 global diffnexthead diffnextnote difffilestart
4919 global diffinhdr treediffs
4921 set nr 0
4922 $ctext conf -state normal
4923 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
4924 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4925 close $bdf
4926 return 0
4928 if {![string compare -length 11 "diff --git " $line]} {
4929 # trim off "diff --git "
4930 set line [string range $line 11 end]
4931 set diffinhdr 1
4932 # start of a new file
4933 $ctext insert end "\n"
4934 set curdiffstart [$ctext index "end - 1c"]
4935 $ctext insert end "\n" filesep
4936 # If the name hasn't changed the length will be odd,
4937 # the middle char will be a space, and the two bits either
4938 # side will be a/name and b/name, or "a/name" and "b/name".
4939 # If the name has changed we'll get "rename from" and
4940 # "rename to" lines following this, and we'll use them
4941 # to get the filenames.
4942 # This complexity is necessary because spaces in the filename(s)
4943 # don't get escaped.
4944 set l [string length $line]
4945 set i [expr {$l / 2}]
4946 if {!(($l & 1) && [string index $line $i] eq " " &&
4947 [string range $line 2 [expr {$i - 1}]] eq \
4948 [string range $line [expr {$i + 3}] end])} {
4949 continue
4951 # unescape if quoted and chop off the a/ from the front
4952 if {[string index $line 0] eq "\""} {
4953 set fname [string range [lindex $line 0] 2 end]
4954 } else {
4955 set fname [string range $line 2 [expr {$i - 1}]]
4957 makediffhdr $fname $ids
4959 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
4960 $line match f1l f1c f2l f2c rest]} {
4961 $ctext insert end "$line\n" hunksep
4962 set diffinhdr 0
4964 } elseif {$diffinhdr} {
4965 if {![string compare -length 12 "rename from " $line]} {
4966 set fname [string range $line 12 end]
4967 if {[string index $fname 0] eq "\""} {
4968 set fname [lindex $fname 0]
4970 set i [lsearch -exact $treediffs($ids) $fname]
4971 if {$i >= 0} {
4972 setinlist difffilestart $i $curdiffstart
4974 } elseif {![string compare -length 10 $line "rename to "]} {
4975 set fname [string range $line 10 end]
4976 if {[string index $fname 0] eq "\""} {
4977 set fname [lindex $fname 0]
4979 makediffhdr $fname $ids
4980 } elseif {[string compare -length 3 $line "---"] == 0} {
4981 # do nothing
4982 continue
4983 } elseif {[string compare -length 3 $line "+++"] == 0} {
4984 set diffinhdr 0
4985 continue
4987 $ctext insert end "$line\n" filesep
4989 } else {
4990 set x [string range $line 0 0]
4991 if {$x == "-" || $x == "+"} {
4992 set tag [expr {$x == "+"}]
4993 $ctext insert end "$line\n" d$tag
4994 } elseif {$x == " "} {
4995 $ctext insert end "$line\n"
4996 } else {
4997 # "\ No newline at end of file",
4998 # or something else we don't recognize
4999 $ctext insert end "$line\n" hunksep
5003 $ctext conf -state disabled
5004 if {[eof $bdf]} {
5005 close $bdf
5006 return 0
5008 return [expr {$nr >= 1000? 2: 1}]
5011 proc changediffdisp {} {
5012 global ctext diffelide
5014 $ctext tag conf d0 -elide [lindex $diffelide 0]
5015 $ctext tag conf d1 -elide [lindex $diffelide 1]
5018 proc prevfile {} {
5019 global difffilestart ctext
5020 set prev [lindex $difffilestart 0]
5021 set here [$ctext index @0,0]
5022 foreach loc $difffilestart {
5023 if {[$ctext compare $loc >= $here]} {
5024 $ctext yview $prev
5025 return
5027 set prev $loc
5029 $ctext yview $prev
5032 proc nextfile {} {
5033 global difffilestart ctext
5034 set here [$ctext index @0,0]
5035 foreach loc $difffilestart {
5036 if {[$ctext compare $loc > $here]} {
5037 $ctext yview $loc
5038 return
5043 proc clear_ctext {{first 1.0}} {
5044 global ctext smarktop smarkbot
5046 set l [lindex [split $first .] 0]
5047 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5048 set smarktop $l
5050 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5051 set smarkbot $l
5053 $ctext delete $first end
5056 proc incrsearch {name ix op} {
5057 global ctext searchstring searchdirn
5059 $ctext tag remove found 1.0 end
5060 if {[catch {$ctext index anchor}]} {
5061 # no anchor set, use start of selection, or of visible area
5062 set sel [$ctext tag ranges sel]
5063 if {$sel ne {}} {
5064 $ctext mark set anchor [lindex $sel 0]
5065 } elseif {$searchdirn eq "-forwards"} {
5066 $ctext mark set anchor @0,0
5067 } else {
5068 $ctext mark set anchor @0,[winfo height $ctext]
5071 if {$searchstring ne {}} {
5072 set here [$ctext search $searchdirn -- $searchstring anchor]
5073 if {$here ne {}} {
5074 $ctext see $here
5076 searchmarkvisible 1
5080 proc dosearch {} {
5081 global sstring ctext searchstring searchdirn
5083 focus $sstring
5084 $sstring icursor end
5085 set searchdirn -forwards
5086 if {$searchstring ne {}} {
5087 set sel [$ctext tag ranges sel]
5088 if {$sel ne {}} {
5089 set start "[lindex $sel 0] + 1c"
5090 } elseif {[catch {set start [$ctext index anchor]}]} {
5091 set start "@0,0"
5093 set match [$ctext search -count mlen -- $searchstring $start]
5094 $ctext tag remove sel 1.0 end
5095 if {$match eq {}} {
5096 bell
5097 return
5099 $ctext see $match
5100 set mend "$match + $mlen c"
5101 $ctext tag add sel $match $mend
5102 $ctext mark unset anchor
5106 proc dosearchback {} {
5107 global sstring ctext searchstring searchdirn
5109 focus $sstring
5110 $sstring icursor end
5111 set searchdirn -backwards
5112 if {$searchstring ne {}} {
5113 set sel [$ctext tag ranges sel]
5114 if {$sel ne {}} {
5115 set start [lindex $sel 0]
5116 } elseif {[catch {set start [$ctext index anchor]}]} {
5117 set start @0,[winfo height $ctext]
5119 set match [$ctext search -backwards -count ml -- $searchstring $start]
5120 $ctext tag remove sel 1.0 end
5121 if {$match eq {}} {
5122 bell
5123 return
5125 $ctext see $match
5126 set mend "$match + $ml c"
5127 $ctext tag add sel $match $mend
5128 $ctext mark unset anchor
5132 proc searchmark {first last} {
5133 global ctext searchstring
5135 set mend $first.0
5136 while {1} {
5137 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5138 if {$match eq {}} break
5139 set mend "$match + $mlen c"
5140 $ctext tag add found $match $mend
5144 proc searchmarkvisible {doall} {
5145 global ctext smarktop smarkbot
5147 set topline [lindex [split [$ctext index @0,0] .] 0]
5148 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5149 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5150 # no overlap with previous
5151 searchmark $topline $botline
5152 set smarktop $topline
5153 set smarkbot $botline
5154 } else {
5155 if {$topline < $smarktop} {
5156 searchmark $topline [expr {$smarktop-1}]
5157 set smarktop $topline
5159 if {$botline > $smarkbot} {
5160 searchmark [expr {$smarkbot+1}] $botline
5161 set smarkbot $botline
5166 proc scrolltext {f0 f1} {
5167 global searchstring
5169 .bleft.sb set $f0 $f1
5170 if {$searchstring ne {}} {
5171 searchmarkvisible 0
5175 proc setcoords {} {
5176 global linespc charspc canvx0 canvy0 mainfont
5177 global xspc1 xspc2 lthickness
5179 set linespc [font metrics $mainfont -linespace]
5180 set charspc [font measure $mainfont "m"]
5181 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5182 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5183 set lthickness [expr {int($linespc / 9) + 1}]
5184 set xspc1(0) $linespc
5185 set xspc2 $linespc
5188 proc redisplay {} {
5189 global canv
5190 global selectedline
5192 set ymax [lindex [$canv cget -scrollregion] 3]
5193 if {$ymax eq {} || $ymax == 0} return
5194 set span [$canv yview]
5195 clear_display
5196 setcanvscroll
5197 allcanvs yview moveto [lindex $span 0]
5198 drawvisible
5199 if {[info exists selectedline]} {
5200 selectline $selectedline 0
5201 allcanvs yview moveto [lindex $span 0]
5205 proc incrfont {inc} {
5206 global mainfont textfont ctext canv phase cflist
5207 global charspc tabstop
5208 global stopped entries
5209 unmarkmatches
5210 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5211 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5212 setcoords
5213 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5214 $cflist conf -font $textfont
5215 $ctext tag conf filesep -font [concat $textfont bold]
5216 foreach e $entries {
5217 $e conf -font $mainfont
5219 if {$phase eq "getcommits"} {
5220 $canv itemconf textitems -font $mainfont
5222 redisplay
5225 proc clearsha1 {} {
5226 global sha1entry sha1string
5227 if {[string length $sha1string] == 40} {
5228 $sha1entry delete 0 end
5232 proc sha1change {n1 n2 op} {
5233 global sha1string currentid sha1but
5234 if {$sha1string == {}
5235 || ([info exists currentid] && $sha1string == $currentid)} {
5236 set state disabled
5237 } else {
5238 set state normal
5240 if {[$sha1but cget -state] == $state} return
5241 if {$state == "normal"} {
5242 $sha1but conf -state normal -relief raised -text "Goto: "
5243 } else {
5244 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5248 proc gotocommit {} {
5249 global sha1string currentid commitrow tagids headids
5250 global displayorder numcommits curview
5252 if {$sha1string == {}
5253 || ([info exists currentid] && $sha1string == $currentid)} return
5254 if {[info exists tagids($sha1string)]} {
5255 set id $tagids($sha1string)
5256 } elseif {[info exists headids($sha1string)]} {
5257 set id $headids($sha1string)
5258 } else {
5259 set id [string tolower $sha1string]
5260 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5261 set matches {}
5262 foreach i $displayorder {
5263 if {[string match $id* $i]} {
5264 lappend matches $i
5267 if {$matches ne {}} {
5268 if {[llength $matches] > 1} {
5269 error_popup "Short SHA1 id $id is ambiguous"
5270 return
5272 set id [lindex $matches 0]
5276 if {[info exists commitrow($curview,$id)]} {
5277 selectline $commitrow($curview,$id) 1
5278 return
5280 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5281 set type "SHA1 id"
5282 } else {
5283 set type "Tag/Head"
5285 error_popup "$type $sha1string is not known"
5288 proc lineenter {x y id} {
5289 global hoverx hovery hoverid hovertimer
5290 global commitinfo canv
5292 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5293 set hoverx $x
5294 set hovery $y
5295 set hoverid $id
5296 if {[info exists hovertimer]} {
5297 after cancel $hovertimer
5299 set hovertimer [after 500 linehover]
5300 $canv delete hover
5303 proc linemotion {x y id} {
5304 global hoverx hovery hoverid hovertimer
5306 if {[info exists hoverid] && $id == $hoverid} {
5307 set hoverx $x
5308 set hovery $y
5309 if {[info exists hovertimer]} {
5310 after cancel $hovertimer
5312 set hovertimer [after 500 linehover]
5316 proc lineleave {id} {
5317 global hoverid hovertimer canv
5319 if {[info exists hoverid] && $id == $hoverid} {
5320 $canv delete hover
5321 if {[info exists hovertimer]} {
5322 after cancel $hovertimer
5323 unset hovertimer
5325 unset hoverid
5329 proc linehover {} {
5330 global hoverx hovery hoverid hovertimer
5331 global canv linespc lthickness
5332 global commitinfo mainfont
5334 set text [lindex $commitinfo($hoverid) 0]
5335 set ymax [lindex [$canv cget -scrollregion] 3]
5336 if {$ymax == {}} return
5337 set yfrac [lindex [$canv yview] 0]
5338 set x [expr {$hoverx + 2 * $linespc}]
5339 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5340 set x0 [expr {$x - 2 * $lthickness}]
5341 set y0 [expr {$y - 2 * $lthickness}]
5342 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5343 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5344 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5345 -fill \#ffff80 -outline black -width 1 -tags hover]
5346 $canv raise $t
5347 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5348 -font $mainfont]
5349 $canv raise $t
5352 proc clickisonarrow {id y} {
5353 global lthickness
5355 set ranges [rowranges $id]
5356 set thresh [expr {2 * $lthickness + 6}]
5357 set n [expr {[llength $ranges] - 1}]
5358 for {set i 1} {$i < $n} {incr i} {
5359 set row [lindex $ranges $i]
5360 if {abs([yc $row] - $y) < $thresh} {
5361 return $i
5364 return {}
5367 proc arrowjump {id n y} {
5368 global canv
5370 # 1 <-> 2, 3 <-> 4, etc...
5371 set n [expr {(($n - 1) ^ 1) + 1}]
5372 set row [lindex [rowranges $id] $n]
5373 set yt [yc $row]
5374 set ymax [lindex [$canv cget -scrollregion] 3]
5375 if {$ymax eq {} || $ymax <= 0} return
5376 set view [$canv yview]
5377 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5378 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5379 if {$yfrac < 0} {
5380 set yfrac 0
5382 allcanvs yview moveto $yfrac
5385 proc lineclick {x y id isnew} {
5386 global ctext commitinfo children canv thickerline curview
5388 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5389 unmarkmatches
5390 unselectline
5391 normalline
5392 $canv delete hover
5393 # draw this line thicker than normal
5394 set thickerline $id
5395 drawlines $id
5396 if {$isnew} {
5397 set ymax [lindex [$canv cget -scrollregion] 3]
5398 if {$ymax eq {}} return
5399 set yfrac [lindex [$canv yview] 0]
5400 set y [expr {$y + $yfrac * $ymax}]
5402 set dirn [clickisonarrow $id $y]
5403 if {$dirn ne {}} {
5404 arrowjump $id $dirn $y
5405 return
5408 if {$isnew} {
5409 addtohistory [list lineclick $x $y $id 0]
5411 # fill the details pane with info about this line
5412 $ctext conf -state normal
5413 clear_ctext
5414 $ctext tag conf link -foreground blue -underline 1
5415 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5416 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5417 $ctext insert end "Parent:\t"
5418 $ctext insert end $id [list link link0]
5419 $ctext tag bind link0 <1> [list selbyid $id]
5420 set info $commitinfo($id)
5421 $ctext insert end "\n\t[lindex $info 0]\n"
5422 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5423 set date [formatdate [lindex $info 2]]
5424 $ctext insert end "\tDate:\t$date\n"
5425 set kids $children($curview,$id)
5426 if {$kids ne {}} {
5427 $ctext insert end "\nChildren:"
5428 set i 0
5429 foreach child $kids {
5430 incr i
5431 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5432 set info $commitinfo($child)
5433 $ctext insert end "\n\t"
5434 $ctext insert end $child [list link link$i]
5435 $ctext tag bind link$i <1> [list selbyid $child]
5436 $ctext insert end "\n\t[lindex $info 0]"
5437 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5438 set date [formatdate [lindex $info 2]]
5439 $ctext insert end "\n\tDate:\t$date\n"
5442 $ctext conf -state disabled
5443 init_flist {}
5446 proc normalline {} {
5447 global thickerline
5448 if {[info exists thickerline]} {
5449 set id $thickerline
5450 unset thickerline
5451 drawlines $id
5455 proc selbyid {id} {
5456 global commitrow curview
5457 if {[info exists commitrow($curview,$id)]} {
5458 selectline $commitrow($curview,$id) 1
5462 proc mstime {} {
5463 global startmstime
5464 if {![info exists startmstime]} {
5465 set startmstime [clock clicks -milliseconds]
5467 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5470 proc rowmenu {x y id} {
5471 global rowctxmenu commitrow selectedline rowmenuid curview
5472 global nullid fakerowmenu mainhead
5474 set rowmenuid $id
5475 if {![info exists selectedline]
5476 || $commitrow($curview,$id) eq $selectedline} {
5477 set state disabled
5478 } else {
5479 set state normal
5481 if {$id ne $nullid} {
5482 set menu $rowctxmenu
5483 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5484 } else {
5485 set menu $fakerowmenu
5487 $menu entryconfigure "Diff this*" -state $state
5488 $menu entryconfigure "Diff selected*" -state $state
5489 $menu entryconfigure "Make patch" -state $state
5490 tk_popup $menu $x $y
5493 proc diffvssel {dirn} {
5494 global rowmenuid selectedline displayorder
5496 if {![info exists selectedline]} return
5497 if {$dirn} {
5498 set oldid [lindex $displayorder $selectedline]
5499 set newid $rowmenuid
5500 } else {
5501 set oldid $rowmenuid
5502 set newid [lindex $displayorder $selectedline]
5504 addtohistory [list doseldiff $oldid $newid]
5505 doseldiff $oldid $newid
5508 proc doseldiff {oldid newid} {
5509 global ctext
5510 global commitinfo
5512 $ctext conf -state normal
5513 clear_ctext
5514 init_flist "Top"
5515 $ctext insert end "From "
5516 $ctext tag conf link -foreground blue -underline 1
5517 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5518 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5519 $ctext tag bind link0 <1> [list selbyid $oldid]
5520 $ctext insert end $oldid [list link link0]
5521 $ctext insert end "\n "
5522 $ctext insert end [lindex $commitinfo($oldid) 0]
5523 $ctext insert end "\n\nTo "
5524 $ctext tag bind link1 <1> [list selbyid $newid]
5525 $ctext insert end $newid [list link link1]
5526 $ctext insert end "\n "
5527 $ctext insert end [lindex $commitinfo($newid) 0]
5528 $ctext insert end "\n"
5529 $ctext conf -state disabled
5530 $ctext tag remove found 1.0 end
5531 startdiff [list $oldid $newid]
5534 proc mkpatch {} {
5535 global rowmenuid currentid commitinfo patchtop patchnum
5537 if {![info exists currentid]} return
5538 set oldid $currentid
5539 set oldhead [lindex $commitinfo($oldid) 0]
5540 set newid $rowmenuid
5541 set newhead [lindex $commitinfo($newid) 0]
5542 set top .patch
5543 set patchtop $top
5544 catch {destroy $top}
5545 toplevel $top
5546 label $top.title -text "Generate patch"
5547 grid $top.title - -pady 10
5548 label $top.from -text "From:"
5549 entry $top.fromsha1 -width 40 -relief flat
5550 $top.fromsha1 insert 0 $oldid
5551 $top.fromsha1 conf -state readonly
5552 grid $top.from $top.fromsha1 -sticky w
5553 entry $top.fromhead -width 60 -relief flat
5554 $top.fromhead insert 0 $oldhead
5555 $top.fromhead conf -state readonly
5556 grid x $top.fromhead -sticky w
5557 label $top.to -text "To:"
5558 entry $top.tosha1 -width 40 -relief flat
5559 $top.tosha1 insert 0 $newid
5560 $top.tosha1 conf -state readonly
5561 grid $top.to $top.tosha1 -sticky w
5562 entry $top.tohead -width 60 -relief flat
5563 $top.tohead insert 0 $newhead
5564 $top.tohead conf -state readonly
5565 grid x $top.tohead -sticky w
5566 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5567 grid $top.rev x -pady 10
5568 label $top.flab -text "Output file:"
5569 entry $top.fname -width 60
5570 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5571 incr patchnum
5572 grid $top.flab $top.fname -sticky w
5573 frame $top.buts
5574 button $top.buts.gen -text "Generate" -command mkpatchgo
5575 button $top.buts.can -text "Cancel" -command mkpatchcan
5576 grid $top.buts.gen $top.buts.can
5577 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5578 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5579 grid $top.buts - -pady 10 -sticky ew
5580 focus $top.fname
5583 proc mkpatchrev {} {
5584 global patchtop
5586 set oldid [$patchtop.fromsha1 get]
5587 set oldhead [$patchtop.fromhead get]
5588 set newid [$patchtop.tosha1 get]
5589 set newhead [$patchtop.tohead get]
5590 foreach e [list fromsha1 fromhead tosha1 tohead] \
5591 v [list $newid $newhead $oldid $oldhead] {
5592 $patchtop.$e conf -state normal
5593 $patchtop.$e delete 0 end
5594 $patchtop.$e insert 0 $v
5595 $patchtop.$e conf -state readonly
5599 proc mkpatchgo {} {
5600 global patchtop nullid
5602 set oldid [$patchtop.fromsha1 get]
5603 set newid [$patchtop.tosha1 get]
5604 set fname [$patchtop.fname get]
5605 if {$newid eq $nullid} {
5606 set cmd [list git diff-index -p $oldid]
5607 } elseif {$oldid eq $nullid} {
5608 set cmd [list git diff-index -p -R $newid]
5609 } else {
5610 set cmd [list git diff-tree -p $oldid $newid]
5612 lappend cmd >$fname &
5613 if {[catch {eval exec $cmd} err]} {
5614 error_popup "Error creating patch: $err"
5616 catch {destroy $patchtop}
5617 unset patchtop
5620 proc mkpatchcan {} {
5621 global patchtop
5623 catch {destroy $patchtop}
5624 unset patchtop
5627 proc mktag {} {
5628 global rowmenuid mktagtop commitinfo
5630 set top .maketag
5631 set mktagtop $top
5632 catch {destroy $top}
5633 toplevel $top
5634 label $top.title -text "Create tag"
5635 grid $top.title - -pady 10
5636 label $top.id -text "ID:"
5637 entry $top.sha1 -width 40 -relief flat
5638 $top.sha1 insert 0 $rowmenuid
5639 $top.sha1 conf -state readonly
5640 grid $top.id $top.sha1 -sticky w
5641 entry $top.head -width 60 -relief flat
5642 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5643 $top.head conf -state readonly
5644 grid x $top.head -sticky w
5645 label $top.tlab -text "Tag name:"
5646 entry $top.tag -width 60
5647 grid $top.tlab $top.tag -sticky w
5648 frame $top.buts
5649 button $top.buts.gen -text "Create" -command mktaggo
5650 button $top.buts.can -text "Cancel" -command mktagcan
5651 grid $top.buts.gen $top.buts.can
5652 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5653 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5654 grid $top.buts - -pady 10 -sticky ew
5655 focus $top.tag
5658 proc domktag {} {
5659 global mktagtop env tagids idtags
5661 set id [$mktagtop.sha1 get]
5662 set tag [$mktagtop.tag get]
5663 if {$tag == {}} {
5664 error_popup "No tag name specified"
5665 return
5667 if {[info exists tagids($tag)]} {
5668 error_popup "Tag \"$tag\" already exists"
5669 return
5671 if {[catch {
5672 set dir [gitdir]
5673 set fname [file join $dir "refs/tags" $tag]
5674 set f [open $fname w]
5675 puts $f $id
5676 close $f
5677 } err]} {
5678 error_popup "Error creating tag: $err"
5679 return
5682 set tagids($tag) $id
5683 lappend idtags($id) $tag
5684 redrawtags $id
5685 addedtag $id
5688 proc redrawtags {id} {
5689 global canv linehtag commitrow idpos selectedline curview
5690 global mainfont canvxmax iddrawn
5692 if {![info exists commitrow($curview,$id)]} return
5693 if {![info exists iddrawn($id)]} return
5694 drawcommits $commitrow($curview,$id)
5695 $canv delete tag.$id
5696 set xt [eval drawtags $id $idpos($id)]
5697 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5698 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5699 set xr [expr {$xt + [font measure $mainfont $text]}]
5700 if {$xr > $canvxmax} {
5701 set canvxmax $xr
5702 setcanvscroll
5704 if {[info exists selectedline]
5705 && $selectedline == $commitrow($curview,$id)} {
5706 selectline $selectedline 0
5710 proc mktagcan {} {
5711 global mktagtop
5713 catch {destroy $mktagtop}
5714 unset mktagtop
5717 proc mktaggo {} {
5718 domktag
5719 mktagcan
5722 proc writecommit {} {
5723 global rowmenuid wrcomtop commitinfo wrcomcmd
5725 set top .writecommit
5726 set wrcomtop $top
5727 catch {destroy $top}
5728 toplevel $top
5729 label $top.title -text "Write commit to file"
5730 grid $top.title - -pady 10
5731 label $top.id -text "ID:"
5732 entry $top.sha1 -width 40 -relief flat
5733 $top.sha1 insert 0 $rowmenuid
5734 $top.sha1 conf -state readonly
5735 grid $top.id $top.sha1 -sticky w
5736 entry $top.head -width 60 -relief flat
5737 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5738 $top.head conf -state readonly
5739 grid x $top.head -sticky w
5740 label $top.clab -text "Command:"
5741 entry $top.cmd -width 60 -textvariable wrcomcmd
5742 grid $top.clab $top.cmd -sticky w -pady 10
5743 label $top.flab -text "Output file:"
5744 entry $top.fname -width 60
5745 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5746 grid $top.flab $top.fname -sticky w
5747 frame $top.buts
5748 button $top.buts.gen -text "Write" -command wrcomgo
5749 button $top.buts.can -text "Cancel" -command wrcomcan
5750 grid $top.buts.gen $top.buts.can
5751 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5752 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5753 grid $top.buts - -pady 10 -sticky ew
5754 focus $top.fname
5757 proc wrcomgo {} {
5758 global wrcomtop
5760 set id [$wrcomtop.sha1 get]
5761 set cmd "echo $id | [$wrcomtop.cmd get]"
5762 set fname [$wrcomtop.fname get]
5763 if {[catch {exec sh -c $cmd >$fname &} err]} {
5764 error_popup "Error writing commit: $err"
5766 catch {destroy $wrcomtop}
5767 unset wrcomtop
5770 proc wrcomcan {} {
5771 global wrcomtop
5773 catch {destroy $wrcomtop}
5774 unset wrcomtop
5777 proc mkbranch {} {
5778 global rowmenuid mkbrtop
5780 set top .makebranch
5781 catch {destroy $top}
5782 toplevel $top
5783 label $top.title -text "Create new branch"
5784 grid $top.title - -pady 10
5785 label $top.id -text "ID:"
5786 entry $top.sha1 -width 40 -relief flat
5787 $top.sha1 insert 0 $rowmenuid
5788 $top.sha1 conf -state readonly
5789 grid $top.id $top.sha1 -sticky w
5790 label $top.nlab -text "Name:"
5791 entry $top.name -width 40
5792 grid $top.nlab $top.name -sticky w
5793 frame $top.buts
5794 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5795 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5796 grid $top.buts.go $top.buts.can
5797 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5798 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5799 grid $top.buts - -pady 10 -sticky ew
5800 focus $top.name
5803 proc mkbrgo {top} {
5804 global headids idheads
5806 set name [$top.name get]
5807 set id [$top.sha1 get]
5808 if {$name eq {}} {
5809 error_popup "Please specify a name for the new branch"
5810 return
5812 catch {destroy $top}
5813 nowbusy newbranch
5814 update
5815 if {[catch {
5816 exec git branch $name $id
5817 } err]} {
5818 notbusy newbranch
5819 error_popup $err
5820 } else {
5821 set headids($name) $id
5822 lappend idheads($id) $name
5823 addedhead $id $name
5824 notbusy newbranch
5825 redrawtags $id
5826 dispneartags 0
5830 proc cherrypick {} {
5831 global rowmenuid curview commitrow
5832 global mainhead
5834 set oldhead [exec git rev-parse HEAD]
5835 set dheads [descheads $rowmenuid]
5836 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5837 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5838 included in branch $mainhead -- really re-apply it?"]
5839 if {!$ok} return
5841 nowbusy cherrypick
5842 update
5843 # Unfortunately git-cherry-pick writes stuff to stderr even when
5844 # no error occurs, and exec takes that as an indication of error...
5845 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5846 notbusy cherrypick
5847 error_popup $err
5848 return
5850 set newhead [exec git rev-parse HEAD]
5851 if {$newhead eq $oldhead} {
5852 notbusy cherrypick
5853 error_popup "No changes committed"
5854 return
5856 addnewchild $newhead $oldhead
5857 if {[info exists commitrow($curview,$oldhead)]} {
5858 insertrow $commitrow($curview,$oldhead) $newhead
5859 if {$mainhead ne {}} {
5860 movehead $newhead $mainhead
5861 movedhead $newhead $mainhead
5863 redrawtags $oldhead
5864 redrawtags $newhead
5866 notbusy cherrypick
5869 proc resethead {} {
5870 global mainheadid mainhead rowmenuid confirm_ok resettype
5871 global showlocalchanges
5873 set confirm_ok 0
5874 set w ".confirmreset"
5875 toplevel $w
5876 wm transient $w .
5877 wm title $w "Confirm reset"
5878 message $w.m -text \
5879 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5880 -justify center -aspect 1000
5881 pack $w.m -side top -fill x -padx 20 -pady 20
5882 frame $w.f -relief sunken -border 2
5883 message $w.f.rt -text "Reset type:" -aspect 1000
5884 grid $w.f.rt -sticky w
5885 set resettype mixed
5886 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5887 -text "Soft: Leave working tree and index untouched"
5888 grid $w.f.soft -sticky w
5889 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5890 -text "Mixed: Leave working tree untouched, reset index"
5891 grid $w.f.mixed -sticky w
5892 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5893 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5894 grid $w.f.hard -sticky w
5895 pack $w.f -side top -fill x
5896 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5897 pack $w.ok -side left -fill x -padx 20 -pady 20
5898 button $w.cancel -text Cancel -command "destroy $w"
5899 pack $w.cancel -side right -fill x -padx 20 -pady 20
5900 bind $w <Visibility> "grab $w; focus $w"
5901 tkwait window $w
5902 if {!$confirm_ok} return
5903 if {[catch {set fd [open \
5904 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5905 error_popup $err
5906 } else {
5907 dohidelocalchanges
5908 set w ".resetprogress"
5909 filerun $fd [list readresetstat $fd $w]
5910 toplevel $w
5911 wm transient $w
5912 wm title $w "Reset progress"
5913 message $w.m -text "Reset in progress, please wait..." \
5914 -justify center -aspect 1000
5915 pack $w.m -side top -fill x -padx 20 -pady 5
5916 canvas $w.c -width 150 -height 20 -bg white
5917 $w.c create rect 0 0 0 20 -fill green -tags rect
5918 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
5919 nowbusy reset
5923 proc readresetstat {fd w} {
5924 global mainhead mainheadid showlocalchanges
5926 if {[gets $fd line] >= 0} {
5927 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
5928 set x [expr {($m * 150) / $n}]
5929 $w.c coords rect 0 0 $x 20
5931 return 1
5933 destroy $w
5934 notbusy reset
5935 if {[catch {close $fd} err]} {
5936 error_popup $err
5938 set oldhead $mainheadid
5939 set newhead [exec git rev-parse HEAD]
5940 if {$newhead ne $oldhead} {
5941 movehead $newhead $mainhead
5942 movedhead $newhead $mainhead
5943 set mainheadid $newhead
5944 redrawtags $oldhead
5945 redrawtags $newhead
5947 if {$showlocalchanges} {
5948 doshowlocalchanges
5950 return 0
5953 # context menu for a head
5954 proc headmenu {x y id head} {
5955 global headmenuid headmenuhead headctxmenu mainhead
5957 set headmenuid $id
5958 set headmenuhead $head
5959 set state normal
5960 if {$head eq $mainhead} {
5961 set state disabled
5963 $headctxmenu entryconfigure 0 -state $state
5964 $headctxmenu entryconfigure 1 -state $state
5965 tk_popup $headctxmenu $x $y
5968 proc cobranch {} {
5969 global headmenuid headmenuhead mainhead headids
5970 global showlocalchanges mainheadid
5972 # check the tree is clean first??
5973 set oldmainhead $mainhead
5974 nowbusy checkout
5975 update
5976 dohidelocalchanges
5977 if {[catch {
5978 exec git checkout -q $headmenuhead
5979 } err]} {
5980 notbusy checkout
5981 error_popup $err
5982 } else {
5983 notbusy checkout
5984 set mainhead $headmenuhead
5985 set mainheadid $headmenuid
5986 if {[info exists headids($oldmainhead)]} {
5987 redrawtags $headids($oldmainhead)
5989 redrawtags $headmenuid
5991 if {$showlocalchanges} {
5992 dodiffindex
5996 proc rmbranch {} {
5997 global headmenuid headmenuhead mainhead
5998 global headids idheads
6000 set head $headmenuhead
6001 set id $headmenuid
6002 # this check shouldn't be needed any more...
6003 if {$head eq $mainhead} {
6004 error_popup "Cannot delete the currently checked-out branch"
6005 return
6007 set dheads [descheads $id]
6008 if {$dheads eq $headids($head)} {
6009 # the stuff on this branch isn't on any other branch
6010 if {![confirm_popup "The commits on branch $head aren't on any other\
6011 branch.\nReally delete branch $head?"]} return
6013 nowbusy rmbranch
6014 update
6015 if {[catch {exec git branch -D $head} err]} {
6016 notbusy rmbranch
6017 error_popup $err
6018 return
6020 removehead $id $head
6021 removedhead $id $head
6022 redrawtags $id
6023 notbusy rmbranch
6024 dispneartags 0
6027 # Stuff for finding nearby tags
6028 proc getallcommits {} {
6029 global allcommits allids nbmp nextarc seeds
6031 set allids {}
6032 set nbmp 0
6033 set nextarc 0
6034 set allcommits 0
6035 set seeds {}
6036 regetallcommits
6039 # Called when the graph might have changed
6040 proc regetallcommits {} {
6041 global allcommits seeds
6043 set cmd [concat | git rev-list --all --parents]
6044 foreach id $seeds {
6045 lappend cmd "^$id"
6047 set fd [open $cmd r]
6048 fconfigure $fd -blocking 0
6049 incr allcommits
6050 nowbusy allcommits
6051 filerun $fd [list getallclines $fd]
6054 # Since most commits have 1 parent and 1 child, we group strings of
6055 # such commits into "arcs" joining branch/merge points (BMPs), which
6056 # are commits that either don't have 1 parent or don't have 1 child.
6058 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6059 # arcout(id) - outgoing arcs for BMP
6060 # arcids(a) - list of IDs on arc including end but not start
6061 # arcstart(a) - BMP ID at start of arc
6062 # arcend(a) - BMP ID at end of arc
6063 # growing(a) - arc a is still growing
6064 # arctags(a) - IDs out of arcids (excluding end) that have tags
6065 # archeads(a) - IDs out of arcids (excluding end) that have heads
6066 # The start of an arc is at the descendent end, so "incoming" means
6067 # coming from descendents, and "outgoing" means going towards ancestors.
6069 proc getallclines {fd} {
6070 global allids allparents allchildren idtags idheads nextarc nbmp
6071 global arcnos arcids arctags arcout arcend arcstart archeads growing
6072 global seeds allcommits
6074 set nid 0
6075 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6076 set id [lindex $line 0]
6077 if {[info exists allparents($id)]} {
6078 # seen it already
6079 continue
6081 lappend allids $id
6082 set olds [lrange $line 1 end]
6083 set allparents($id) $olds
6084 if {![info exists allchildren($id)]} {
6085 set allchildren($id) {}
6086 set arcnos($id) {}
6087 lappend seeds $id
6088 } else {
6089 set a $arcnos($id)
6090 if {[llength $olds] == 1 && [llength $a] == 1} {
6091 lappend arcids($a) $id
6092 if {[info exists idtags($id)]} {
6093 lappend arctags($a) $id
6095 if {[info exists idheads($id)]} {
6096 lappend archeads($a) $id
6098 if {[info exists allparents($olds)]} {
6099 # seen parent already
6100 if {![info exists arcout($olds)]} {
6101 splitarc $olds
6103 lappend arcids($a) $olds
6104 set arcend($a) $olds
6105 unset growing($a)
6107 lappend allchildren($olds) $id
6108 lappend arcnos($olds) $a
6109 continue
6112 incr nbmp
6113 foreach a $arcnos($id) {
6114 lappend arcids($a) $id
6115 set arcend($a) $id
6116 unset growing($a)
6119 set ao {}
6120 foreach p $olds {
6121 lappend allchildren($p) $id
6122 set a [incr nextarc]
6123 set arcstart($a) $id
6124 set archeads($a) {}
6125 set arctags($a) {}
6126 set archeads($a) {}
6127 set arcids($a) {}
6128 lappend ao $a
6129 set growing($a) 1
6130 if {[info exists allparents($p)]} {
6131 # seen it already, may need to make a new branch
6132 if {![info exists arcout($p)]} {
6133 splitarc $p
6135 lappend arcids($a) $p
6136 set arcend($a) $p
6137 unset growing($a)
6139 lappend arcnos($p) $a
6141 set arcout($id) $ao
6143 if {$nid > 0} {
6144 global cached_dheads cached_dtags cached_atags
6145 catch {unset cached_dheads}
6146 catch {unset cached_dtags}
6147 catch {unset cached_atags}
6149 if {![eof $fd]} {
6150 return [expr {$nid >= 1000? 2: 1}]
6152 close $fd
6153 if {[incr allcommits -1] == 0} {
6154 notbusy allcommits
6156 dispneartags 0
6157 return 0
6160 proc recalcarc {a} {
6161 global arctags archeads arcids idtags idheads
6163 set at {}
6164 set ah {}
6165 foreach id [lrange $arcids($a) 0 end-1] {
6166 if {[info exists idtags($id)]} {
6167 lappend at $id
6169 if {[info exists idheads($id)]} {
6170 lappend ah $id
6173 set arctags($a) $at
6174 set archeads($a) $ah
6177 proc splitarc {p} {
6178 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6179 global arcstart arcend arcout allparents growing
6181 set a $arcnos($p)
6182 if {[llength $a] != 1} {
6183 puts "oops splitarc called but [llength $a] arcs already"
6184 return
6186 set a [lindex $a 0]
6187 set i [lsearch -exact $arcids($a) $p]
6188 if {$i < 0} {
6189 puts "oops splitarc $p not in arc $a"
6190 return
6192 set na [incr nextarc]
6193 if {[info exists arcend($a)]} {
6194 set arcend($na) $arcend($a)
6195 } else {
6196 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6197 set j [lsearch -exact $arcnos($l) $a]
6198 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6200 set tail [lrange $arcids($a) [expr {$i+1}] end]
6201 set arcids($a) [lrange $arcids($a) 0 $i]
6202 set arcend($a) $p
6203 set arcstart($na) $p
6204 set arcout($p) $na
6205 set arcids($na) $tail
6206 if {[info exists growing($a)]} {
6207 set growing($na) 1
6208 unset growing($a)
6210 incr nbmp
6212 foreach id $tail {
6213 if {[llength $arcnos($id)] == 1} {
6214 set arcnos($id) $na
6215 } else {
6216 set j [lsearch -exact $arcnos($id) $a]
6217 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6221 # reconstruct tags and heads lists
6222 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6223 recalcarc $a
6224 recalcarc $na
6225 } else {
6226 set arctags($na) {}
6227 set archeads($na) {}
6231 # Update things for a new commit added that is a child of one
6232 # existing commit. Used when cherry-picking.
6233 proc addnewchild {id p} {
6234 global allids allparents allchildren idtags nextarc nbmp
6235 global arcnos arcids arctags arcout arcend arcstart archeads growing
6236 global seeds
6238 lappend allids $id
6239 set allparents($id) [list $p]
6240 set allchildren($id) {}
6241 set arcnos($id) {}
6242 lappend seeds $id
6243 incr nbmp
6244 lappend allchildren($p) $id
6245 set a [incr nextarc]
6246 set arcstart($a) $id
6247 set archeads($a) {}
6248 set arctags($a) {}
6249 set arcids($a) [list $p]
6250 set arcend($a) $p
6251 if {![info exists arcout($p)]} {
6252 splitarc $p
6254 lappend arcnos($p) $a
6255 set arcout($id) [list $a]
6258 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6259 # or 0 if neither is true.
6260 proc anc_or_desc {a b} {
6261 global arcout arcstart arcend arcnos cached_isanc
6263 if {$arcnos($a) eq $arcnos($b)} {
6264 # Both are on the same arc(s); either both are the same BMP,
6265 # or if one is not a BMP, the other is also not a BMP or is
6266 # the BMP at end of the arc (and it only has 1 incoming arc).
6267 # Or both can be BMPs with no incoming arcs.
6268 if {$a eq $b || $arcnos($a) eq {}} {
6269 return 0
6271 # assert {[llength $arcnos($a)] == 1}
6272 set arc [lindex $arcnos($a) 0]
6273 set i [lsearch -exact $arcids($arc) $a]
6274 set j [lsearch -exact $arcids($arc) $b]
6275 if {$i < 0 || $i > $j} {
6276 return 1
6277 } else {
6278 return -1
6282 if {![info exists arcout($a)]} {
6283 set arc [lindex $arcnos($a) 0]
6284 if {[info exists arcend($arc)]} {
6285 set aend $arcend($arc)
6286 } else {
6287 set aend {}
6289 set a $arcstart($arc)
6290 } else {
6291 set aend $a
6293 if {![info exists arcout($b)]} {
6294 set arc [lindex $arcnos($b) 0]
6295 if {[info exists arcend($arc)]} {
6296 set bend $arcend($arc)
6297 } else {
6298 set bend {}
6300 set b $arcstart($arc)
6301 } else {
6302 set bend $b
6304 if {$a eq $bend} {
6305 return 1
6307 if {$b eq $aend} {
6308 return -1
6310 if {[info exists cached_isanc($a,$bend)]} {
6311 if {$cached_isanc($a,$bend)} {
6312 return 1
6315 if {[info exists cached_isanc($b,$aend)]} {
6316 if {$cached_isanc($b,$aend)} {
6317 return -1
6319 if {[info exists cached_isanc($a,$bend)]} {
6320 return 0
6324 set todo [list $a $b]
6325 set anc($a) a
6326 set anc($b) b
6327 for {set i 0} {$i < [llength $todo]} {incr i} {
6328 set x [lindex $todo $i]
6329 if {$anc($x) eq {}} {
6330 continue
6332 foreach arc $arcnos($x) {
6333 set xd $arcstart($arc)
6334 if {$xd eq $bend} {
6335 set cached_isanc($a,$bend) 1
6336 set cached_isanc($b,$aend) 0
6337 return 1
6338 } elseif {$xd eq $aend} {
6339 set cached_isanc($b,$aend) 1
6340 set cached_isanc($a,$bend) 0
6341 return -1
6343 if {![info exists anc($xd)]} {
6344 set anc($xd) $anc($x)
6345 lappend todo $xd
6346 } elseif {$anc($xd) ne $anc($x)} {
6347 set anc($xd) {}
6351 set cached_isanc($a,$bend) 0
6352 set cached_isanc($b,$aend) 0
6353 return 0
6356 # This identifies whether $desc has an ancestor that is
6357 # a growing tip of the graph and which is not an ancestor of $anc
6358 # and returns 0 if so and 1 if not.
6359 # If we subsequently discover a tag on such a growing tip, and that
6360 # turns out to be a descendent of $anc (which it could, since we
6361 # don't necessarily see children before parents), then $desc
6362 # isn't a good choice to display as a descendent tag of
6363 # $anc (since it is the descendent of another tag which is
6364 # a descendent of $anc). Similarly, $anc isn't a good choice to
6365 # display as a ancestor tag of $desc.
6367 proc is_certain {desc anc} {
6368 global arcnos arcout arcstart arcend growing problems
6370 set certain {}
6371 if {[llength $arcnos($anc)] == 1} {
6372 # tags on the same arc are certain
6373 if {$arcnos($desc) eq $arcnos($anc)} {
6374 return 1
6376 if {![info exists arcout($anc)]} {
6377 # if $anc is partway along an arc, use the start of the arc instead
6378 set a [lindex $arcnos($anc) 0]
6379 set anc $arcstart($a)
6382 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6383 set x $desc
6384 } else {
6385 set a [lindex $arcnos($desc) 0]
6386 set x $arcend($a)
6388 if {$x == $anc} {
6389 return 1
6391 set anclist [list $x]
6392 set dl($x) 1
6393 set nnh 1
6394 set ngrowanc 0
6395 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6396 set x [lindex $anclist $i]
6397 if {$dl($x)} {
6398 incr nnh -1
6400 set done($x) 1
6401 foreach a $arcout($x) {
6402 if {[info exists growing($a)]} {
6403 if {![info exists growanc($x)] && $dl($x)} {
6404 set growanc($x) 1
6405 incr ngrowanc
6407 } else {
6408 set y $arcend($a)
6409 if {[info exists dl($y)]} {
6410 if {$dl($y)} {
6411 if {!$dl($x)} {
6412 set dl($y) 0
6413 if {![info exists done($y)]} {
6414 incr nnh -1
6416 if {[info exists growanc($x)]} {
6417 incr ngrowanc -1
6419 set xl [list $y]
6420 for {set k 0} {$k < [llength $xl]} {incr k} {
6421 set z [lindex $xl $k]
6422 foreach c $arcout($z) {
6423 if {[info exists arcend($c)]} {
6424 set v $arcend($c)
6425 if {[info exists dl($v)] && $dl($v)} {
6426 set dl($v) 0
6427 if {![info exists done($v)]} {
6428 incr nnh -1
6430 if {[info exists growanc($v)]} {
6431 incr ngrowanc -1
6433 lappend xl $v
6440 } elseif {$y eq $anc || !$dl($x)} {
6441 set dl($y) 0
6442 lappend anclist $y
6443 } else {
6444 set dl($y) 1
6445 lappend anclist $y
6446 incr nnh
6451 foreach x [array names growanc] {
6452 if {$dl($x)} {
6453 return 0
6455 return 0
6457 return 1
6460 proc validate_arctags {a} {
6461 global arctags idtags
6463 set i -1
6464 set na $arctags($a)
6465 foreach id $arctags($a) {
6466 incr i
6467 if {![info exists idtags($id)]} {
6468 set na [lreplace $na $i $i]
6469 incr i -1
6472 set arctags($a) $na
6475 proc validate_archeads {a} {
6476 global archeads idheads
6478 set i -1
6479 set na $archeads($a)
6480 foreach id $archeads($a) {
6481 incr i
6482 if {![info exists idheads($id)]} {
6483 set na [lreplace $na $i $i]
6484 incr i -1
6487 set archeads($a) $na
6490 # Return the list of IDs that have tags that are descendents of id,
6491 # ignoring IDs that are descendents of IDs already reported.
6492 proc desctags {id} {
6493 global arcnos arcstart arcids arctags idtags allparents
6494 global growing cached_dtags
6496 if {![info exists allparents($id)]} {
6497 return {}
6499 set t1 [clock clicks -milliseconds]
6500 set argid $id
6501 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6502 # part-way along an arc; check that arc first
6503 set a [lindex $arcnos($id) 0]
6504 if {$arctags($a) ne {}} {
6505 validate_arctags $a
6506 set i [lsearch -exact $arcids($a) $id]
6507 set tid {}
6508 foreach t $arctags($a) {
6509 set j [lsearch -exact $arcids($a) $t]
6510 if {$j >= $i} break
6511 set tid $t
6513 if {$tid ne {}} {
6514 return $tid
6517 set id $arcstart($a)
6518 if {[info exists idtags($id)]} {
6519 return $id
6522 if {[info exists cached_dtags($id)]} {
6523 return $cached_dtags($id)
6526 set origid $id
6527 set todo [list $id]
6528 set queued($id) 1
6529 set nc 1
6530 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6531 set id [lindex $todo $i]
6532 set done($id) 1
6533 set ta [info exists hastaggedancestor($id)]
6534 if {!$ta} {
6535 incr nc -1
6537 # ignore tags on starting node
6538 if {!$ta && $i > 0} {
6539 if {[info exists idtags($id)]} {
6540 set tagloc($id) $id
6541 set ta 1
6542 } elseif {[info exists cached_dtags($id)]} {
6543 set tagloc($id) $cached_dtags($id)
6544 set ta 1
6547 foreach a $arcnos($id) {
6548 set d $arcstart($a)
6549 if {!$ta && $arctags($a) ne {}} {
6550 validate_arctags $a
6551 if {$arctags($a) ne {}} {
6552 lappend tagloc($id) [lindex $arctags($a) end]
6555 if {$ta || $arctags($a) ne {}} {
6556 set tomark [list $d]
6557 for {set j 0} {$j < [llength $tomark]} {incr j} {
6558 set dd [lindex $tomark $j]
6559 if {![info exists hastaggedancestor($dd)]} {
6560 if {[info exists done($dd)]} {
6561 foreach b $arcnos($dd) {
6562 lappend tomark $arcstart($b)
6564 if {[info exists tagloc($dd)]} {
6565 unset tagloc($dd)
6567 } elseif {[info exists queued($dd)]} {
6568 incr nc -1
6570 set hastaggedancestor($dd) 1
6574 if {![info exists queued($d)]} {
6575 lappend todo $d
6576 set queued($d) 1
6577 if {![info exists hastaggedancestor($d)]} {
6578 incr nc
6583 set tags {}
6584 foreach id [array names tagloc] {
6585 if {![info exists hastaggedancestor($id)]} {
6586 foreach t $tagloc($id) {
6587 if {[lsearch -exact $tags $t] < 0} {
6588 lappend tags $t
6593 set t2 [clock clicks -milliseconds]
6594 set loopix $i
6596 # remove tags that are descendents of other tags
6597 for {set i 0} {$i < [llength $tags]} {incr i} {
6598 set a [lindex $tags $i]
6599 for {set j 0} {$j < $i} {incr j} {
6600 set b [lindex $tags $j]
6601 set r [anc_or_desc $a $b]
6602 if {$r == 1} {
6603 set tags [lreplace $tags $j $j]
6604 incr j -1
6605 incr i -1
6606 } elseif {$r == -1} {
6607 set tags [lreplace $tags $i $i]
6608 incr i -1
6609 break
6614 if {[array names growing] ne {}} {
6615 # graph isn't finished, need to check if any tag could get
6616 # eclipsed by another tag coming later. Simply ignore any
6617 # tags that could later get eclipsed.
6618 set ctags {}
6619 foreach t $tags {
6620 if {[is_certain $t $origid]} {
6621 lappend ctags $t
6624 if {$tags eq $ctags} {
6625 set cached_dtags($origid) $tags
6626 } else {
6627 set tags $ctags
6629 } else {
6630 set cached_dtags($origid) $tags
6632 set t3 [clock clicks -milliseconds]
6633 if {0 && $t3 - $t1 >= 100} {
6634 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6635 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6637 return $tags
6640 proc anctags {id} {
6641 global arcnos arcids arcout arcend arctags idtags allparents
6642 global growing cached_atags
6644 if {![info exists allparents($id)]} {
6645 return {}
6647 set t1 [clock clicks -milliseconds]
6648 set argid $id
6649 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6650 # part-way along an arc; check that arc first
6651 set a [lindex $arcnos($id) 0]
6652 if {$arctags($a) ne {}} {
6653 validate_arctags $a
6654 set i [lsearch -exact $arcids($a) $id]
6655 foreach t $arctags($a) {
6656 set j [lsearch -exact $arcids($a) $t]
6657 if {$j > $i} {
6658 return $t
6662 if {![info exists arcend($a)]} {
6663 return {}
6665 set id $arcend($a)
6666 if {[info exists idtags($id)]} {
6667 return $id
6670 if {[info exists cached_atags($id)]} {
6671 return $cached_atags($id)
6674 set origid $id
6675 set todo [list $id]
6676 set queued($id) 1
6677 set taglist {}
6678 set nc 1
6679 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6680 set id [lindex $todo $i]
6681 set done($id) 1
6682 set td [info exists hastaggeddescendent($id)]
6683 if {!$td} {
6684 incr nc -1
6686 # ignore tags on starting node
6687 if {!$td && $i > 0} {
6688 if {[info exists idtags($id)]} {
6689 set tagloc($id) $id
6690 set td 1
6691 } elseif {[info exists cached_atags($id)]} {
6692 set tagloc($id) $cached_atags($id)
6693 set td 1
6696 foreach a $arcout($id) {
6697 if {!$td && $arctags($a) ne {}} {
6698 validate_arctags $a
6699 if {$arctags($a) ne {}} {
6700 lappend tagloc($id) [lindex $arctags($a) 0]
6703 if {![info exists arcend($a)]} continue
6704 set d $arcend($a)
6705 if {$td || $arctags($a) ne {}} {
6706 set tomark [list $d]
6707 for {set j 0} {$j < [llength $tomark]} {incr j} {
6708 set dd [lindex $tomark $j]
6709 if {![info exists hastaggeddescendent($dd)]} {
6710 if {[info exists done($dd)]} {
6711 foreach b $arcout($dd) {
6712 if {[info exists arcend($b)]} {
6713 lappend tomark $arcend($b)
6716 if {[info exists tagloc($dd)]} {
6717 unset tagloc($dd)
6719 } elseif {[info exists queued($dd)]} {
6720 incr nc -1
6722 set hastaggeddescendent($dd) 1
6726 if {![info exists queued($d)]} {
6727 lappend todo $d
6728 set queued($d) 1
6729 if {![info exists hastaggeddescendent($d)]} {
6730 incr nc
6735 set t2 [clock clicks -milliseconds]
6736 set loopix $i
6737 set tags {}
6738 foreach id [array names tagloc] {
6739 if {![info exists hastaggeddescendent($id)]} {
6740 foreach t $tagloc($id) {
6741 if {[lsearch -exact $tags $t] < 0} {
6742 lappend tags $t
6748 # remove tags that are ancestors of other tags
6749 for {set i 0} {$i < [llength $tags]} {incr i} {
6750 set a [lindex $tags $i]
6751 for {set j 0} {$j < $i} {incr j} {
6752 set b [lindex $tags $j]
6753 set r [anc_or_desc $a $b]
6754 if {$r == -1} {
6755 set tags [lreplace $tags $j $j]
6756 incr j -1
6757 incr i -1
6758 } elseif {$r == 1} {
6759 set tags [lreplace $tags $i $i]
6760 incr i -1
6761 break
6766 if {[array names growing] ne {}} {
6767 # graph isn't finished, need to check if any tag could get
6768 # eclipsed by another tag coming later. Simply ignore any
6769 # tags that could later get eclipsed.
6770 set ctags {}
6771 foreach t $tags {
6772 if {[is_certain $origid $t]} {
6773 lappend ctags $t
6776 if {$tags eq $ctags} {
6777 set cached_atags($origid) $tags
6778 } else {
6779 set tags $ctags
6781 } else {
6782 set cached_atags($origid) $tags
6784 set t3 [clock clicks -milliseconds]
6785 if {0 && $t3 - $t1 >= 100} {
6786 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6787 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6789 return $tags
6792 # Return the list of IDs that have heads that are descendents of id,
6793 # including id itself if it has a head.
6794 proc descheads {id} {
6795 global arcnos arcstart arcids archeads idheads cached_dheads
6796 global allparents
6798 if {![info exists allparents($id)]} {
6799 return {}
6801 set aret {}
6802 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6803 # part-way along an arc; check it first
6804 set a [lindex $arcnos($id) 0]
6805 if {$archeads($a) ne {}} {
6806 validate_archeads $a
6807 set i [lsearch -exact $arcids($a) $id]
6808 foreach t $archeads($a) {
6809 set j [lsearch -exact $arcids($a) $t]
6810 if {$j > $i} break
6811 lappend aret $t
6814 set id $arcstart($a)
6816 set origid $id
6817 set todo [list $id]
6818 set seen($id) 1
6819 set ret {}
6820 for {set i 0} {$i < [llength $todo]} {incr i} {
6821 set id [lindex $todo $i]
6822 if {[info exists cached_dheads($id)]} {
6823 set ret [concat $ret $cached_dheads($id)]
6824 } else {
6825 if {[info exists idheads($id)]} {
6826 lappend ret $id
6828 foreach a $arcnos($id) {
6829 if {$archeads($a) ne {}} {
6830 validate_archeads $a
6831 if {$archeads($a) ne {}} {
6832 set ret [concat $ret $archeads($a)]
6835 set d $arcstart($a)
6836 if {![info exists seen($d)]} {
6837 lappend todo $d
6838 set seen($d) 1
6843 set ret [lsort -unique $ret]
6844 set cached_dheads($origid) $ret
6845 return [concat $ret $aret]
6848 proc addedtag {id} {
6849 global arcnos arcout cached_dtags cached_atags
6851 if {![info exists arcnos($id)]} return
6852 if {![info exists arcout($id)]} {
6853 recalcarc [lindex $arcnos($id) 0]
6855 catch {unset cached_dtags}
6856 catch {unset cached_atags}
6859 proc addedhead {hid head} {
6860 global arcnos arcout cached_dheads
6862 if {![info exists arcnos($hid)]} return
6863 if {![info exists arcout($hid)]} {
6864 recalcarc [lindex $arcnos($hid) 0]
6866 catch {unset cached_dheads}
6869 proc removedhead {hid head} {
6870 global cached_dheads
6872 catch {unset cached_dheads}
6875 proc movedhead {hid head} {
6876 global arcnos arcout cached_dheads
6878 if {![info exists arcnos($hid)]} return
6879 if {![info exists arcout($hid)]} {
6880 recalcarc [lindex $arcnos($hid) 0]
6882 catch {unset cached_dheads}
6885 proc changedrefs {} {
6886 global cached_dheads cached_dtags cached_atags
6887 global arctags archeads arcnos arcout idheads idtags
6889 foreach id [concat [array names idheads] [array names idtags]] {
6890 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6891 set a [lindex $arcnos($id) 0]
6892 if {![info exists donearc($a)]} {
6893 recalcarc $a
6894 set donearc($a) 1
6898 catch {unset cached_dtags}
6899 catch {unset cached_atags}
6900 catch {unset cached_dheads}
6903 proc rereadrefs {} {
6904 global idtags idheads idotherrefs mainhead
6906 set refids [concat [array names idtags] \
6907 [array names idheads] [array names idotherrefs]]
6908 foreach id $refids {
6909 if {![info exists ref($id)]} {
6910 set ref($id) [listrefs $id]
6913 set oldmainhead $mainhead
6914 readrefs
6915 changedrefs
6916 set refids [lsort -unique [concat $refids [array names idtags] \
6917 [array names idheads] [array names idotherrefs]]]
6918 foreach id $refids {
6919 set v [listrefs $id]
6920 if {![info exists ref($id)] || $ref($id) != $v ||
6921 ($id eq $oldmainhead && $id ne $mainhead) ||
6922 ($id eq $mainhead && $id ne $oldmainhead)} {
6923 redrawtags $id
6928 proc listrefs {id} {
6929 global idtags idheads idotherrefs
6931 set x {}
6932 if {[info exists idtags($id)]} {
6933 set x $idtags($id)
6935 set y {}
6936 if {[info exists idheads($id)]} {
6937 set y $idheads($id)
6939 set z {}
6940 if {[info exists idotherrefs($id)]} {
6941 set z $idotherrefs($id)
6943 return [list $x $y $z]
6946 proc showtag {tag isnew} {
6947 global ctext tagcontents tagids linknum tagobjid
6949 if {$isnew} {
6950 addtohistory [list showtag $tag 0]
6952 $ctext conf -state normal
6953 clear_ctext
6954 set linknum 0
6955 if {![info exists tagcontents($tag)]} {
6956 catch {
6957 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
6960 if {[info exists tagcontents($tag)]} {
6961 set text $tagcontents($tag)
6962 } else {
6963 set text "Tag: $tag\nId: $tagids($tag)"
6965 appendwithlinks $text {}
6966 $ctext conf -state disabled
6967 init_flist {}
6970 proc doquit {} {
6971 global stopped
6972 set stopped 100
6973 savestuff .
6974 destroy .
6977 proc doprefs {} {
6978 global maxwidth maxgraphpct diffopts
6979 global oldprefs prefstop showneartags showlocalchanges
6980 global bgcolor fgcolor ctext diffcolors selectbgcolor
6981 global uifont tabstop
6983 set top .gitkprefs
6984 set prefstop $top
6985 if {[winfo exists $top]} {
6986 raise $top
6987 return
6989 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
6990 set oldprefs($v) [set $v]
6992 toplevel $top
6993 wm title $top "Gitk preferences"
6994 label $top.ldisp -text "Commit list display options"
6995 $top.ldisp configure -font $uifont
6996 grid $top.ldisp - -sticky w -pady 10
6997 label $top.spacer -text " "
6998 label $top.maxwidthl -text "Maximum graph width (lines)" \
6999 -font optionfont
7000 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7001 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7002 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7003 -font optionfont
7004 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7005 grid x $top.maxpctl $top.maxpct -sticky w
7006 frame $top.showlocal
7007 label $top.showlocal.l -text "Show local changes" -font optionfont
7008 checkbutton $top.showlocal.b -variable showlocalchanges
7009 pack $top.showlocal.b $top.showlocal.l -side left
7010 grid x $top.showlocal -sticky w
7012 label $top.ddisp -text "Diff display options"
7013 $top.ddisp configure -font $uifont
7014 grid $top.ddisp - -sticky w -pady 10
7015 label $top.diffoptl -text "Options for diff program" \
7016 -font optionfont
7017 entry $top.diffopt -width 20 -textvariable diffopts
7018 grid x $top.diffoptl $top.diffopt -sticky w
7019 frame $top.ntag
7020 label $top.ntag.l -text "Display nearby tags" -font optionfont
7021 checkbutton $top.ntag.b -variable showneartags
7022 pack $top.ntag.b $top.ntag.l -side left
7023 grid x $top.ntag -sticky w
7024 label $top.tabstopl -text "tabstop" -font optionfont
7025 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7026 grid x $top.tabstopl $top.tabstop -sticky w
7028 label $top.cdisp -text "Colors: press to choose"
7029 $top.cdisp configure -font $uifont
7030 grid $top.cdisp - -sticky w -pady 10
7031 label $top.bg -padx 40 -relief sunk -background $bgcolor
7032 button $top.bgbut -text "Background" -font optionfont \
7033 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7034 grid x $top.bgbut $top.bg -sticky w
7035 label $top.fg -padx 40 -relief sunk -background $fgcolor
7036 button $top.fgbut -text "Foreground" -font optionfont \
7037 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7038 grid x $top.fgbut $top.fg -sticky w
7039 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7040 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7041 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7042 [list $ctext tag conf d0 -foreground]]
7043 grid x $top.diffoldbut $top.diffold -sticky w
7044 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7045 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7046 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7047 [list $ctext tag conf d1 -foreground]]
7048 grid x $top.diffnewbut $top.diffnew -sticky w
7049 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7050 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7051 -command [list choosecolor diffcolors 2 $top.hunksep \
7052 "diff hunk header" \
7053 [list $ctext tag conf hunksep -foreground]]
7054 grid x $top.hunksepbut $top.hunksep -sticky w
7055 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7056 button $top.selbgbut -text "Select bg" -font optionfont \
7057 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7058 grid x $top.selbgbut $top.selbgsep -sticky w
7060 frame $top.buts
7061 button $top.buts.ok -text "OK" -command prefsok -default active
7062 $top.buts.ok configure -font $uifont
7063 button $top.buts.can -text "Cancel" -command prefscan -default normal
7064 $top.buts.can configure -font $uifont
7065 grid $top.buts.ok $top.buts.can
7066 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7067 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7068 grid $top.buts - - -pady 10 -sticky ew
7069 bind $top <Visibility> "focus $top.buts.ok"
7072 proc choosecolor {v vi w x cmd} {
7073 global $v
7075 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7076 -title "Gitk: choose color for $x"]
7077 if {$c eq {}} return
7078 $w conf -background $c
7079 lset $v $vi $c
7080 eval $cmd $c
7083 proc setselbg {c} {
7084 global bglist cflist
7085 foreach w $bglist {
7086 $w configure -selectbackground $c
7088 $cflist tag configure highlight \
7089 -background [$cflist cget -selectbackground]
7090 allcanvs itemconf secsel -fill $c
7093 proc setbg {c} {
7094 global bglist
7096 foreach w $bglist {
7097 $w conf -background $c
7101 proc setfg {c} {
7102 global fglist canv
7104 foreach w $fglist {
7105 $w conf -foreground $c
7107 allcanvs itemconf text -fill $c
7108 $canv itemconf circle -outline $c
7111 proc prefscan {} {
7112 global maxwidth maxgraphpct diffopts
7113 global oldprefs prefstop showneartags showlocalchanges
7115 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7116 set $v $oldprefs($v)
7118 catch {destroy $prefstop}
7119 unset prefstop
7122 proc prefsok {} {
7123 global maxwidth maxgraphpct
7124 global oldprefs prefstop showneartags showlocalchanges
7125 global charspc ctext tabstop
7127 catch {destroy $prefstop}
7128 unset prefstop
7129 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7130 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7131 if {$showlocalchanges} {
7132 doshowlocalchanges
7133 } else {
7134 dohidelocalchanges
7137 if {$maxwidth != $oldprefs(maxwidth)
7138 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7139 redisplay
7140 } elseif {$showneartags != $oldprefs(showneartags)} {
7141 reselectline
7145 proc formatdate {d} {
7146 if {$d ne {}} {
7147 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7149 return $d
7152 # This list of encoding names and aliases is distilled from
7153 # http://www.iana.org/assignments/character-sets.
7154 # Not all of them are supported by Tcl.
7155 set encoding_aliases {
7156 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7157 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7158 { ISO-10646-UTF-1 csISO10646UTF1 }
7159 { ISO_646.basic:1983 ref csISO646basic1983 }
7160 { INVARIANT csINVARIANT }
7161 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7162 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7163 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7164 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7165 { NATS-DANO iso-ir-9-1 csNATSDANO }
7166 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7167 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7168 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7169 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7170 { ISO-2022-KR csISO2022KR }
7171 { EUC-KR csEUCKR }
7172 { ISO-2022-JP csISO2022JP }
7173 { ISO-2022-JP-2 csISO2022JP2 }
7174 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7175 csISO13JISC6220jp }
7176 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7177 { IT iso-ir-15 ISO646-IT csISO15Italian }
7178 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7179 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7180 { greek7-old iso-ir-18 csISO18Greek7Old }
7181 { latin-greek iso-ir-19 csISO19LatinGreek }
7182 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7183 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7184 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7185 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7186 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7187 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7188 { INIS iso-ir-49 csISO49INIS }
7189 { INIS-8 iso-ir-50 csISO50INIS8 }
7190 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7191 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7192 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7193 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7194 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7195 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7196 csISO60Norwegian1 }
7197 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7198 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7199 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7200 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7201 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7202 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7203 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7204 { greek7 iso-ir-88 csISO88Greek7 }
7205 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7206 { iso-ir-90 csISO90 }
7207 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7208 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7209 csISO92JISC62991984b }
7210 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7211 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7212 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7213 csISO95JIS62291984handadd }
7214 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7215 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7216 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7217 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7218 CP819 csISOLatin1 }
7219 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7220 { T.61-7bit iso-ir-102 csISO102T617bit }
7221 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7222 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7223 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7224 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7225 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7226 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7227 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7228 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7229 arabic csISOLatinArabic }
7230 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7231 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7232 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7233 greek greek8 csISOLatinGreek }
7234 { T.101-G2 iso-ir-128 csISO128T101G2 }
7235 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7236 csISOLatinHebrew }
7237 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7238 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7239 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7240 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7241 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7242 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7243 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7244 csISOLatinCyrillic }
7245 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7246 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7247 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7248 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7249 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7250 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7251 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7252 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7253 { ISO_10367-box iso-ir-155 csISO10367Box }
7254 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7255 { latin-lap lap iso-ir-158 csISO158Lap }
7256 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7257 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7258 { us-dk csUSDK }
7259 { dk-us csDKUS }
7260 { JIS_X0201 X0201 csHalfWidthKatakana }
7261 { KSC5636 ISO646-KR csKSC5636 }
7262 { ISO-10646-UCS-2 csUnicode }
7263 { ISO-10646-UCS-4 csUCS4 }
7264 { DEC-MCS dec csDECMCS }
7265 { hp-roman8 roman8 r8 csHPRoman8 }
7266 { macintosh mac csMacintosh }
7267 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7268 csIBM037 }
7269 { IBM038 EBCDIC-INT cp038 csIBM038 }
7270 { IBM273 CP273 csIBM273 }
7271 { IBM274 EBCDIC-BE CP274 csIBM274 }
7272 { IBM275 EBCDIC-BR cp275 csIBM275 }
7273 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7274 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7275 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7276 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7277 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7278 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7279 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7280 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7281 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7282 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7283 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7284 { IBM437 cp437 437 csPC8CodePage437 }
7285 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7286 { IBM775 cp775 csPC775Baltic }
7287 { IBM850 cp850 850 csPC850Multilingual }
7288 { IBM851 cp851 851 csIBM851 }
7289 { IBM852 cp852 852 csPCp852 }
7290 { IBM855 cp855 855 csIBM855 }
7291 { IBM857 cp857 857 csIBM857 }
7292 { IBM860 cp860 860 csIBM860 }
7293 { IBM861 cp861 861 cp-is csIBM861 }
7294 { IBM862 cp862 862 csPC862LatinHebrew }
7295 { IBM863 cp863 863 csIBM863 }
7296 { IBM864 cp864 csIBM864 }
7297 { IBM865 cp865 865 csIBM865 }
7298 { IBM866 cp866 866 csIBM866 }
7299 { IBM868 CP868 cp-ar csIBM868 }
7300 { IBM869 cp869 869 cp-gr csIBM869 }
7301 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7302 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7303 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7304 { IBM891 cp891 csIBM891 }
7305 { IBM903 cp903 csIBM903 }
7306 { IBM904 cp904 904 csIBBM904 }
7307 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7308 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7309 { IBM1026 CP1026 csIBM1026 }
7310 { EBCDIC-AT-DE csIBMEBCDICATDE }
7311 { EBCDIC-AT-DE-A csEBCDICATDEA }
7312 { EBCDIC-CA-FR csEBCDICCAFR }
7313 { EBCDIC-DK-NO csEBCDICDKNO }
7314 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7315 { EBCDIC-FI-SE csEBCDICFISE }
7316 { EBCDIC-FI-SE-A csEBCDICFISEA }
7317 { EBCDIC-FR csEBCDICFR }
7318 { EBCDIC-IT csEBCDICIT }
7319 { EBCDIC-PT csEBCDICPT }
7320 { EBCDIC-ES csEBCDICES }
7321 { EBCDIC-ES-A csEBCDICESA }
7322 { EBCDIC-ES-S csEBCDICESS }
7323 { EBCDIC-UK csEBCDICUK }
7324 { EBCDIC-US csEBCDICUS }
7325 { UNKNOWN-8BIT csUnknown8BiT }
7326 { MNEMONIC csMnemonic }
7327 { MNEM csMnem }
7328 { VISCII csVISCII }
7329 { VIQR csVIQR }
7330 { KOI8-R csKOI8R }
7331 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7332 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7333 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7334 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7335 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7336 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7337 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7338 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7339 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7340 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7341 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7342 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7343 { IBM1047 IBM-1047 }
7344 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7345 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7346 { UNICODE-1-1 csUnicode11 }
7347 { CESU-8 csCESU-8 }
7348 { BOCU-1 csBOCU-1 }
7349 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7350 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7351 l8 }
7352 { ISO-8859-15 ISO_8859-15 Latin-9 }
7353 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7354 { GBK CP936 MS936 windows-936 }
7355 { JIS_Encoding csJISEncoding }
7356 { Shift_JIS MS_Kanji csShiftJIS }
7357 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7358 EUC-JP }
7359 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7360 { ISO-10646-UCS-Basic csUnicodeASCII }
7361 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7362 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7363 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7364 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7365 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7366 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7367 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7368 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7369 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7370 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7371 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7372 { Ventura-US csVenturaUS }
7373 { Ventura-International csVenturaInternational }
7374 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7375 { PC8-Turkish csPC8Turkish }
7376 { IBM-Symbols csIBMSymbols }
7377 { IBM-Thai csIBMThai }
7378 { HP-Legal csHPLegal }
7379 { HP-Pi-font csHPPiFont }
7380 { HP-Math8 csHPMath8 }
7381 { Adobe-Symbol-Encoding csHPPSMath }
7382 { HP-DeskTop csHPDesktop }
7383 { Ventura-Math csVenturaMath }
7384 { Microsoft-Publishing csMicrosoftPublishing }
7385 { Windows-31J csWindows31J }
7386 { GB2312 csGB2312 }
7387 { Big5 csBig5 }
7390 proc tcl_encoding {enc} {
7391 global encoding_aliases
7392 set names [encoding names]
7393 set lcnames [string tolower $names]
7394 set enc [string tolower $enc]
7395 set i [lsearch -exact $lcnames $enc]
7396 if {$i < 0} {
7397 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7398 if {[regsub {^iso[-_]} $enc iso encx]} {
7399 set i [lsearch -exact $lcnames $encx]
7402 if {$i < 0} {
7403 foreach l $encoding_aliases {
7404 set ll [string tolower $l]
7405 if {[lsearch -exact $ll $enc] < 0} continue
7406 # look through the aliases for one that tcl knows about
7407 foreach e $ll {
7408 set i [lsearch -exact $lcnames $e]
7409 if {$i < 0} {
7410 if {[regsub {^iso[-_]} $e iso ex]} {
7411 set i [lsearch -exact $lcnames $ex]
7414 if {$i >= 0} break
7416 break
7419 if {$i >= 0} {
7420 return [lindex $names $i]
7422 return {}
7425 # defaults...
7426 set datemode 0
7427 set diffopts "-U 5 -p"
7428 set wrcomcmd "git diff-tree --stdin -p --pretty"
7430 set gitencoding {}
7431 catch {
7432 set gitencoding [exec git config --get i18n.commitencoding]
7434 if {$gitencoding == ""} {
7435 set gitencoding "utf-8"
7437 set tclencoding [tcl_encoding $gitencoding]
7438 if {$tclencoding == {}} {
7439 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7442 set mainfont {Helvetica 9}
7443 set textfont {Courier 9}
7444 set uifont {Helvetica 9 bold}
7445 set tabstop 8
7446 set findmergefiles 0
7447 set maxgraphpct 50
7448 set maxwidth 16
7449 set revlistorder 0
7450 set fastdate 0
7451 set uparrowlen 7
7452 set downarrowlen 7
7453 set mingaplen 30
7454 set cmitmode "patch"
7455 set wrapcomment "none"
7456 set showneartags 1
7457 set maxrefs 20
7458 set maxlinelen 200
7459 set showlocalchanges 1
7461 set colors {green red blue magenta darkgrey brown orange}
7462 set bgcolor white
7463 set fgcolor black
7464 set diffcolors {red "#00a000" blue}
7465 set selectbgcolor gray85
7467 catch {source ~/.gitk}
7469 font create optionfont -family sans-serif -size -12
7471 # check that we can find a .git directory somewhere...
7472 set gitdir [gitdir]
7473 if {![file isdirectory $gitdir]} {
7474 show_error {} . "Cannot find the git directory \"$gitdir\"."
7475 exit 1
7478 set revtreeargs {}
7479 set cmdline_files {}
7480 set i 0
7481 foreach arg $argv {
7482 switch -- $arg {
7483 "" { }
7484 "-d" { set datemode 1 }
7485 "--" {
7486 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7487 break
7489 default {
7490 lappend revtreeargs $arg
7493 incr i
7496 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7497 # no -- on command line, but some arguments (other than -d)
7498 if {[catch {
7499 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7500 set cmdline_files [split $f "\n"]
7501 set n [llength $cmdline_files]
7502 set revtreeargs [lrange $revtreeargs 0 end-$n]
7503 # Unfortunately git rev-parse doesn't produce an error when
7504 # something is both a revision and a filename. To be consistent
7505 # with git log and git rev-list, check revtreeargs for filenames.
7506 foreach arg $revtreeargs {
7507 if {[file exists $arg]} {
7508 show_error {} . "Ambiguous argument '$arg': both revision\
7509 and filename"
7510 exit 1
7513 } err]} {
7514 # unfortunately we get both stdout and stderr in $err,
7515 # so look for "fatal:".
7516 set i [string first "fatal:" $err]
7517 if {$i > 0} {
7518 set err [string range $err [expr {$i + 6}] end]
7520 show_error {} . "Bad arguments to gitk:\n$err"
7521 exit 1
7525 set nullid "0000000000000000000000000000000000000000"
7527 set runq {}
7528 set history {}
7529 set historyindex 0
7530 set fh_serial 0
7531 set nhl_names {}
7532 set highlight_paths {}
7533 set searchdirn -forwards
7534 set boldrows {}
7535 set boldnamerows {}
7536 set diffelide {0 0}
7537 set markingmatches 0
7539 set optim_delay 16
7541 set nextviewnum 1
7542 set curview 0
7543 set selectedview 0
7544 set selectedhlview None
7545 set viewfiles(0) {}
7546 set viewperm(0) 0
7547 set viewargs(0) {}
7549 set cmdlineok 0
7550 set stopped 0
7551 set stuffsaved 0
7552 set patchnum 0
7553 set lookingforhead 0
7554 set localrow -1
7555 set lserial 0
7556 setcoords
7557 makewindow
7558 wm title . "[file tail $argv0]: [file tail [pwd]]"
7559 readrefs
7561 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7562 # create a view for the files/dirs specified on the command line
7563 set curview 1
7564 set selectedview 1
7565 set nextviewnum 2
7566 set viewname(1) "Command line"
7567 set viewfiles(1) $cmdline_files
7568 set viewargs(1) $revtreeargs
7569 set viewperm(1) 0
7570 addviewmenu 1
7571 .bar.view entryconf Edit* -state normal
7572 .bar.view entryconf Delete* -state normal
7575 if {[info exists permviews]} {
7576 foreach v $permviews {
7577 set n $nextviewnum
7578 incr nextviewnum
7579 set viewname($n) [lindex $v 0]
7580 set viewfiles($n) [lindex $v 1]
7581 set viewargs($n) [lindex $v 2]
7582 set viewperm($n) 1
7583 addviewmenu $n
7586 getcommits