[PATCH] gitk: Ignore ctrl-z as EOF on windows
[git.git] / gitk
blobd6f62b2a0f72504dc63e537bd24931737b9647f8
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms. Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25 global isonrunq runq
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
36 proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
40 proc filereadable {fd script} {
41 global runq
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
47 lappend runq [list $fd $script]
50 proc dorunq {} {
51 global isonrunq runq
53 set tstart [clock clicks -milliseconds]
54 set t0 $tstart
55 while {$runq ne {}} {
56 set fd [lindex $runq 0 0]
57 set script [lindex $runq 0 1]
58 set repeat [eval $script]
59 set t1 [clock clicks -milliseconds]
60 set t [expr {$t1 - $t0}]
61 set runq [lrange $runq 1 end]
62 if {$repeat ne {} && $repeat} {
63 if {$fd eq {} || $repeat == 2} {
64 # script returns 1 if it wants to be readded
65 # file readers return 2 if they could do more straight away
66 lappend runq [list $fd $script]
67 } else {
68 fileevent $fd readable [list filereadable $fd $script]
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
76 if {$runq ne {}} {
77 after idle dorunq
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx
86 global lookingforhead showlocalchanges
88 set startmsecs [clock clicks -milliseconds]
89 set commitidx($view) 0
90 set order "--topo-order"
91 if {$datemode} {
92 set order "--date-order"
94 if {[catch {
95 set fd [open [concat | git log -z --pretty=raw $order --parents \
96 --boundary $viewargs($view) "--" $viewfiles($view)] r]
97 } err]} {
98 error_popup "Error executing git rev-list: $err"
99 exit 1
101 set commfd($view) $fd
102 set leftover($view) {}
103 set lookingforhead $showlocalchanges
104 fconfigure $fd -blocking 0 -translation lf -eofchar {}
105 if {$tclencoding != {}} {
106 fconfigure $fd -encoding $tclencoding
108 filerun $fd [list getcommitlines $fd $view]
109 nowbusy $view
112 proc stop_rev_list {} {
113 global commfd curview
115 if {![info exists commfd($curview)]} return
116 set fd $commfd($curview)
117 catch {
118 set pid [pid $fd]
119 exec kill $pid
121 catch {close $fd}
122 unset commfd($curview)
125 proc getcommits {} {
126 global phase canv mainfont curview
128 set phase getcommits
129 initlayout
130 start_rev_list $curview
131 show_status "Reading commits..."
134 proc getcommitlines {fd view} {
135 global commitlisted
136 global leftover commfd
137 global displayorder commitidx commitrow commitdata
138 global parentlist children curview hlview
139 global vparentlist vdisporder vcmitlisted
141 set stuff [read $fd 500000]
142 if {$stuff == {}} {
143 if {![eof $fd]} {
144 return 1
146 global viewname
147 unset commfd($view)
148 notbusy $view
149 # set it blocking so we wait for the process to terminate
150 fconfigure $fd -blocking 1
151 if {[catch {close $fd} err]} {
152 set fv {}
153 if {$view != $curview} {
154 set fv " for the \"$viewname($view)\" view"
156 if {[string range $err 0 4] == "usage"} {
157 set err "Gitk: error reading commits$fv:\
158 bad arguments to git rev-list."
159 if {$viewname($view) eq "Command line"} {
160 append err \
161 " (Note: arguments to gitk are passed to git rev-list\
162 to allow selection of commits to be displayed.)"
164 } else {
165 set err "Error reading commits$fv: $err"
167 error_popup $err
169 if {$view == $curview} {
170 run chewcommits $view
172 return 0
174 set start 0
175 set gotsome 0
176 while 1 {
177 set i [string first "\0" $stuff $start]
178 if {$i < 0} {
179 append leftover($view) [string range $stuff $start end]
180 break
182 if {$start == 0} {
183 set cmit $leftover($view)
184 append cmit [string range $stuff 0 [expr {$i - 1}]]
185 set leftover($view) {}
186 } else {
187 set cmit [string range $stuff $start [expr {$i - 1}]]
189 set start [expr {$i + 1}]
190 set j [string first "\n" $cmit]
191 set ok 0
192 set listed 1
193 if {$j >= 0 && [string match "commit *" $cmit]} {
194 set ids [string range $cmit 7 [expr {$j - 1}]]
195 if {[string match {[-<>]*} $ids]} {
196 switch -- [string index $ids 0] {
197 "-" {set listed 0}
198 "<" {set listed 2}
199 ">" {set listed 3}
201 set ids [string range $ids 1 end]
203 set ok 1
204 foreach id $ids {
205 if {[string length $id] != 40} {
206 set ok 0
207 break
211 if {!$ok} {
212 set shortcmit $cmit
213 if {[string length $shortcmit] > 80} {
214 set shortcmit "[string range $shortcmit 0 80]..."
216 error_popup "Can't parse git log output: {$shortcmit}"
217 exit 1
219 set id [lindex $ids 0]
220 if {$listed} {
221 set olds [lrange $ids 1 end]
222 set i 0
223 foreach p $olds {
224 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
225 lappend children($view,$p) $id
227 incr i
229 } else {
230 set olds {}
232 if {![info exists children($view,$id)]} {
233 set children($view,$id) {}
235 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
236 set commitrow($view,$id) $commitidx($view)
237 incr commitidx($view)
238 if {$view == $curview} {
239 lappend parentlist $olds
240 lappend displayorder $id
241 lappend commitlisted $listed
242 } else {
243 lappend vparentlist($view) $olds
244 lappend vdisporder($view) $id
245 lappend vcmitlisted($view) $listed
247 set gotsome 1
249 if {$gotsome} {
250 run chewcommits $view
252 return 2
255 proc chewcommits {view} {
256 global curview hlview commfd
257 global selectedline pending_select
259 set more 0
260 if {$view == $curview} {
261 set allread [expr {![info exists commfd($view)]}]
262 set tlimit [expr {[clock clicks -milliseconds] + 50}]
263 set more [layoutmore $tlimit $allread]
264 if {$allread && !$more} {
265 global displayorder commitidx phase
266 global numcommits startmsecs
268 if {[info exists pending_select]} {
269 set row [first_real_row]
270 selectline $row 1
272 if {$commitidx($curview) > 0} {
273 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
274 #puts "overall $ms ms for $numcommits commits"
275 } else {
276 show_status "No commits selected"
278 notbusy layout
279 set phase {}
282 if {[info exists hlview] && $view == $hlview} {
283 vhighlightmore
285 return $more
288 proc readcommit {id} {
289 if {[catch {set contents [exec git cat-file commit $id]}]} return
290 parsecommit $id $contents 0
293 proc updatecommits {} {
294 global viewdata curview phase displayorder
295 global children commitrow selectedline thickerline
297 if {$phase ne {}} {
298 stop_rev_list
299 set phase {}
301 set n $curview
302 foreach id $displayorder {
303 catch {unset children($n,$id)}
304 catch {unset commitrow($n,$id)}
306 set curview -1
307 catch {unset selectedline}
308 catch {unset thickerline}
309 catch {unset viewdata($n)}
310 readrefs
311 changedrefs
312 regetallcommits
313 showview $n
316 proc parsecommit {id contents listed} {
317 global commitinfo cdate
319 set inhdr 1
320 set comment {}
321 set headline {}
322 set auname {}
323 set audate {}
324 set comname {}
325 set comdate {}
326 set hdrend [string first "\n\n" $contents]
327 if {$hdrend < 0} {
328 # should never happen...
329 set hdrend [string length $contents]
331 set header [string range $contents 0 [expr {$hdrend - 1}]]
332 set comment [string range $contents [expr {$hdrend + 2}] end]
333 foreach line [split $header "\n"] {
334 set tag [lindex $line 0]
335 if {$tag == "author"} {
336 set audate [lindex $line end-1]
337 set auname [lrange $line 1 end-2]
338 } elseif {$tag == "committer"} {
339 set comdate [lindex $line end-1]
340 set comname [lrange $line 1 end-2]
343 set headline {}
344 # take the first non-blank line of the comment as the headline
345 set headline [string trimleft $comment]
346 set i [string first "\n" $headline]
347 if {$i >= 0} {
348 set headline [string range $headline 0 $i]
350 set headline [string trimright $headline]
351 set i [string first "\r" $headline]
352 if {$i >= 0} {
353 set headline [string trimright [string range $headline 0 $i]]
355 if {!$listed} {
356 # git rev-list indents the comment by 4 spaces;
357 # if we got this via git cat-file, add the indentation
358 set newcomment {}
359 foreach line [split $comment "\n"] {
360 append newcomment " "
361 append newcomment $line
362 append newcomment "\n"
364 set comment $newcomment
366 if {$comdate != {}} {
367 set cdate($id) $comdate
369 set commitinfo($id) [list $headline $auname $audate \
370 $comname $comdate $comment]
373 proc getcommit {id} {
374 global commitdata commitinfo
376 if {[info exists commitdata($id)]} {
377 parsecommit $id $commitdata($id) 1
378 } else {
379 readcommit $id
380 if {![info exists commitinfo($id)]} {
381 set commitinfo($id) {"No commit information available"}
384 return 1
387 proc readrefs {} {
388 global tagids idtags headids idheads tagobjid
389 global otherrefids idotherrefs mainhead mainheadid
391 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
392 catch {unset $v}
394 set refd [open [list | git show-ref -d] r]
395 while {[gets $refd line] >= 0} {
396 if {[string index $line 40] ne " "} continue
397 set id [string range $line 0 39]
398 set ref [string range $line 41 end]
399 if {![string match "refs/*" $ref]} continue
400 set name [string range $ref 5 end]
401 if {[string match "remotes/*" $name]} {
402 if {![string match "*/HEAD" $name]} {
403 set headids($name) $id
404 lappend idheads($id) $name
406 } elseif {[string match "heads/*" $name]} {
407 set name [string range $name 6 end]
408 set headids($name) $id
409 lappend idheads($id) $name
410 } elseif {[string match "tags/*" $name]} {
411 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
412 # which is what we want since the former is the commit ID
413 set name [string range $name 5 end]
414 if {[string match "*^{}" $name]} {
415 set name [string range $name 0 end-3]
416 } else {
417 set tagobjid($name) $id
419 set tagids($name) $id
420 lappend idtags($id) $name
421 } else {
422 set otherrefids($name) $id
423 lappend idotherrefs($id) $name
426 close $refd
427 set mainhead {}
428 set mainheadid {}
429 catch {
430 set thehead [exec git symbolic-ref HEAD]
431 if {[string match "refs/heads/*" $thehead]} {
432 set mainhead [string range $thehead 11 end]
433 if {[info exists headids($mainhead)]} {
434 set mainheadid $headids($mainhead)
440 # skip over fake commits
441 proc first_real_row {} {
442 global nullid nullid2 displayorder numcommits
444 for {set row 0} {$row < $numcommits} {incr row} {
445 set id [lindex $displayorder $row]
446 if {$id ne $nullid && $id ne $nullid2} {
447 break
450 return $row
453 # update things for a head moved to a child of its previous location
454 proc movehead {id name} {
455 global headids idheads
457 removehead $headids($name) $name
458 set headids($name) $id
459 lappend idheads($id) $name
462 # update things when a head has been removed
463 proc removehead {id name} {
464 global headids idheads
466 if {$idheads($id) eq $name} {
467 unset idheads($id)
468 } else {
469 set i [lsearch -exact $idheads($id) $name]
470 if {$i >= 0} {
471 set idheads($id) [lreplace $idheads($id) $i $i]
474 unset headids($name)
477 proc show_error {w top msg} {
478 message $w.m -text $msg -justify center -aspect 400
479 pack $w.m -side top -fill x -padx 20 -pady 20
480 button $w.ok -text OK -command "destroy $top"
481 pack $w.ok -side bottom -fill x
482 bind $top <Visibility> "grab $top; focus $top"
483 bind $top <Key-Return> "destroy $top"
484 tkwait window $top
487 proc error_popup msg {
488 set w .error
489 toplevel $w
490 wm transient $w .
491 show_error $w $w $msg
494 proc confirm_popup msg {
495 global confirm_ok
496 set confirm_ok 0
497 set w .confirm
498 toplevel $w
499 wm transient $w .
500 message $w.m -text $msg -justify center -aspect 400
501 pack $w.m -side top -fill x -padx 20 -pady 20
502 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
503 pack $w.ok -side left -fill x
504 button $w.cancel -text Cancel -command "destroy $w"
505 pack $w.cancel -side right -fill x
506 bind $w <Visibility> "grab $w; focus $w"
507 tkwait window $w
508 return $confirm_ok
511 proc makewindow {} {
512 global canv canv2 canv3 linespc charspc ctext cflist
513 global textfont mainfont uifont tabstop
514 global findtype findtypemenu findloc findstring fstring geometry
515 global entries sha1entry sha1string sha1but
516 global maincursor textcursor curtextcursor
517 global rowctxmenu fakerowmenu mergemax wrapcomment
518 global highlight_files gdttype
519 global searchstring sstring
520 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
521 global headctxmenu
523 menu .bar
524 .bar add cascade -label "File" -menu .bar.file
525 .bar configure -font $uifont
526 menu .bar.file
527 .bar.file add command -label "Update" -command updatecommits
528 .bar.file add command -label "Reread references" -command rereadrefs
529 .bar.file add command -label "Quit" -command doquit
530 .bar.file configure -font $uifont
531 menu .bar.edit
532 .bar add cascade -label "Edit" -menu .bar.edit
533 .bar.edit add command -label "Preferences" -command doprefs
534 .bar.edit configure -font $uifont
536 menu .bar.view -font $uifont
537 .bar add cascade -label "View" -menu .bar.view
538 .bar.view add command -label "New view..." -command {newview 0}
539 .bar.view add command -label "Edit view..." -command editview \
540 -state disabled
541 .bar.view add command -label "Delete view" -command delview -state disabled
542 .bar.view add separator
543 .bar.view add radiobutton -label "All files" -command {showview 0} \
544 -variable selectedview -value 0
546 menu .bar.help
547 .bar add cascade -label "Help" -menu .bar.help
548 .bar.help add command -label "About gitk" -command about
549 .bar.help add command -label "Key bindings" -command keys
550 .bar.help configure -font $uifont
551 . configure -menu .bar
553 # the gui has upper and lower half, parts of a paned window.
554 panedwindow .ctop -orient vertical
556 # possibly use assumed geometry
557 if {![info exists geometry(pwsash0)]} {
558 set geometry(topheight) [expr {15 * $linespc}]
559 set geometry(topwidth) [expr {80 * $charspc}]
560 set geometry(botheight) [expr {15 * $linespc}]
561 set geometry(botwidth) [expr {50 * $charspc}]
562 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
563 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
566 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
567 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
568 frame .tf.histframe
569 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
571 # create three canvases
572 set cscroll .tf.histframe.csb
573 set canv .tf.histframe.pwclist.canv
574 canvas $canv \
575 -selectbackground $selectbgcolor \
576 -background $bgcolor -bd 0 \
577 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
578 .tf.histframe.pwclist add $canv
579 set canv2 .tf.histframe.pwclist.canv2
580 canvas $canv2 \
581 -selectbackground $selectbgcolor \
582 -background $bgcolor -bd 0 -yscrollincr $linespc
583 .tf.histframe.pwclist add $canv2
584 set canv3 .tf.histframe.pwclist.canv3
585 canvas $canv3 \
586 -selectbackground $selectbgcolor \
587 -background $bgcolor -bd 0 -yscrollincr $linespc
588 .tf.histframe.pwclist add $canv3
589 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
590 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
592 # a scroll bar to rule them
593 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
594 pack $cscroll -side right -fill y
595 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
596 lappend bglist $canv $canv2 $canv3
597 pack .tf.histframe.pwclist -fill both -expand 1 -side left
599 # we have two button bars at bottom of top frame. Bar 1
600 frame .tf.bar
601 frame .tf.lbar -height 15
603 set sha1entry .tf.bar.sha1
604 set entries $sha1entry
605 set sha1but .tf.bar.sha1label
606 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
607 -command gotocommit -width 8 -font $uifont
608 $sha1but conf -disabledforeground [$sha1but cget -foreground]
609 pack .tf.bar.sha1label -side left
610 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
611 trace add variable sha1string write sha1change
612 pack $sha1entry -side left -pady 2
614 image create bitmap bm-left -data {
615 #define left_width 16
616 #define left_height 16
617 static unsigned char left_bits[] = {
618 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
619 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
620 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
622 image create bitmap bm-right -data {
623 #define right_width 16
624 #define right_height 16
625 static unsigned char right_bits[] = {
626 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
627 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
628 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
630 button .tf.bar.leftbut -image bm-left -command goback \
631 -state disabled -width 26
632 pack .tf.bar.leftbut -side left -fill y
633 button .tf.bar.rightbut -image bm-right -command goforw \
634 -state disabled -width 26
635 pack .tf.bar.rightbut -side left -fill y
637 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
638 pack .tf.bar.findbut -side left
639 set findstring {}
640 set fstring .tf.bar.findstring
641 lappend entries $fstring
642 entry $fstring -width 30 -font $textfont -textvariable findstring
643 trace add variable findstring write find_change
644 pack $fstring -side left -expand 1 -fill x -in .tf.bar
645 set findtype Exact
646 set findtypemenu [tk_optionMenu .tf.bar.findtype \
647 findtype Exact IgnCase Regexp]
648 trace add variable findtype write find_change
649 .tf.bar.findtype configure -font $uifont
650 .tf.bar.findtype.menu configure -font $uifont
651 set findloc "All fields"
652 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
653 Comments Author Committer
654 trace add variable findloc write find_change
655 .tf.bar.findloc configure -font $uifont
656 .tf.bar.findloc.menu configure -font $uifont
657 pack .tf.bar.findloc -side right
658 pack .tf.bar.findtype -side right
660 # build up the bottom bar of upper window
661 label .tf.lbar.flabel -text "Highlight: Commits " \
662 -font $uifont
663 pack .tf.lbar.flabel -side left -fill y
664 set gdttype "touching paths:"
665 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
666 "adding/removing string:"]
667 trace add variable gdttype write hfiles_change
668 $gm conf -font $uifont
669 .tf.lbar.gdttype conf -font $uifont
670 pack .tf.lbar.gdttype -side left -fill y
671 entry .tf.lbar.fent -width 25 -font $textfont \
672 -textvariable highlight_files
673 trace add variable highlight_files write hfiles_change
674 lappend entries .tf.lbar.fent
675 pack .tf.lbar.fent -side left -fill x -expand 1
676 label .tf.lbar.vlabel -text " OR in view" -font $uifont
677 pack .tf.lbar.vlabel -side left -fill y
678 global viewhlmenu selectedhlview
679 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
680 $viewhlmenu entryconf None -command delvhighlight
681 $viewhlmenu conf -font $uifont
682 .tf.lbar.vhl conf -font $uifont
683 pack .tf.lbar.vhl -side left -fill y
684 label .tf.lbar.rlabel -text " OR " -font $uifont
685 pack .tf.lbar.rlabel -side left -fill y
686 global highlight_related
687 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
688 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
689 $m conf -font $uifont
690 .tf.lbar.relm conf -font $uifont
691 trace add variable highlight_related write vrel_change
692 pack .tf.lbar.relm -side left -fill y
694 # Finish putting the upper half of the viewer together
695 pack .tf.lbar -in .tf -side bottom -fill x
696 pack .tf.bar -in .tf -side bottom -fill x
697 pack .tf.histframe -fill both -side top -expand 1
698 .ctop add .tf
699 .ctop paneconfigure .tf -height $geometry(topheight)
700 .ctop paneconfigure .tf -width $geometry(topwidth)
702 # now build up the bottom
703 panedwindow .pwbottom -orient horizontal
705 # lower left, a text box over search bar, scroll bar to the right
706 # if we know window height, then that will set the lower text height, otherwise
707 # we set lower text height which will drive window height
708 if {[info exists geometry(main)]} {
709 frame .bleft -width $geometry(botwidth)
710 } else {
711 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
713 frame .bleft.top
714 frame .bleft.mid
716 button .bleft.top.search -text "Search" -command dosearch \
717 -font $uifont
718 pack .bleft.top.search -side left -padx 5
719 set sstring .bleft.top.sstring
720 entry $sstring -width 20 -font $textfont -textvariable searchstring
721 lappend entries $sstring
722 trace add variable searchstring write incrsearch
723 pack $sstring -side left -expand 1 -fill x
724 radiobutton .bleft.mid.diff -text "Diff" \
725 -command changediffdisp -variable diffelide -value {0 0}
726 radiobutton .bleft.mid.old -text "Old version" \
727 -command changediffdisp -variable diffelide -value {0 1}
728 radiobutton .bleft.mid.new -text "New version" \
729 -command changediffdisp -variable diffelide -value {1 0}
730 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
731 set ctext .bleft.ctext
732 text $ctext -background $bgcolor -foreground $fgcolor \
733 -tabs "[expr {$tabstop * $charspc}]" \
734 -state disabled -font $textfont \
735 -yscrollcommand scrolltext -wrap none
736 scrollbar .bleft.sb -command "$ctext yview"
737 pack .bleft.top -side top -fill x
738 pack .bleft.mid -side top -fill x
739 pack .bleft.sb -side right -fill y
740 pack $ctext -side left -fill both -expand 1
741 lappend bglist $ctext
742 lappend fglist $ctext
744 $ctext tag conf comment -wrap $wrapcomment
745 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
746 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
747 $ctext tag conf d0 -fore [lindex $diffcolors 0]
748 $ctext tag conf d1 -fore [lindex $diffcolors 1]
749 $ctext tag conf m0 -fore red
750 $ctext tag conf m1 -fore blue
751 $ctext tag conf m2 -fore green
752 $ctext tag conf m3 -fore purple
753 $ctext tag conf m4 -fore brown
754 $ctext tag conf m5 -fore "#009090"
755 $ctext tag conf m6 -fore magenta
756 $ctext tag conf m7 -fore "#808000"
757 $ctext tag conf m8 -fore "#009000"
758 $ctext tag conf m9 -fore "#ff0080"
759 $ctext tag conf m10 -fore cyan
760 $ctext tag conf m11 -fore "#b07070"
761 $ctext tag conf m12 -fore "#70b0f0"
762 $ctext tag conf m13 -fore "#70f0b0"
763 $ctext tag conf m14 -fore "#f0b070"
764 $ctext tag conf m15 -fore "#ff70b0"
765 $ctext tag conf mmax -fore darkgrey
766 set mergemax 16
767 $ctext tag conf mresult -font [concat $textfont bold]
768 $ctext tag conf msep -font [concat $textfont bold]
769 $ctext tag conf found -back yellow
771 .pwbottom add .bleft
772 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
774 # lower right
775 frame .bright
776 frame .bright.mode
777 radiobutton .bright.mode.patch -text "Patch" \
778 -command reselectline -variable cmitmode -value "patch"
779 .bright.mode.patch configure -font $uifont
780 radiobutton .bright.mode.tree -text "Tree" \
781 -command reselectline -variable cmitmode -value "tree"
782 .bright.mode.tree configure -font $uifont
783 grid .bright.mode.patch .bright.mode.tree -sticky ew
784 pack .bright.mode -side top -fill x
785 set cflist .bright.cfiles
786 set indent [font measure $mainfont "nn"]
787 text $cflist \
788 -selectbackground $selectbgcolor \
789 -background $bgcolor -foreground $fgcolor \
790 -font $mainfont \
791 -tabs [list $indent [expr {2 * $indent}]] \
792 -yscrollcommand ".bright.sb set" \
793 -cursor [. cget -cursor] \
794 -spacing1 1 -spacing3 1
795 lappend bglist $cflist
796 lappend fglist $cflist
797 scrollbar .bright.sb -command "$cflist yview"
798 pack .bright.sb -side right -fill y
799 pack $cflist -side left -fill both -expand 1
800 $cflist tag configure highlight \
801 -background [$cflist cget -selectbackground]
802 $cflist tag configure bold -font [concat $mainfont bold]
804 .pwbottom add .bright
805 .ctop add .pwbottom
807 # restore window position if known
808 if {[info exists geometry(main)]} {
809 wm geometry . "$geometry(main)"
812 bind .pwbottom <Configure> {resizecdetpanes %W %w}
813 pack .ctop -fill both -expand 1
814 bindall <1> {selcanvline %W %x %y}
815 #bindall <B1-Motion> {selcanvline %W %x %y}
816 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
817 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
818 bindall <2> "canvscan mark %W %x %y"
819 bindall <B2-Motion> "canvscan dragto %W %x %y"
820 bindkey <Home> selfirstline
821 bindkey <End> sellastline
822 bind . <Key-Up> "selnextline -1"
823 bind . <Key-Down> "selnextline 1"
824 bind . <Shift-Key-Up> "next_highlight -1"
825 bind . <Shift-Key-Down> "next_highlight 1"
826 bindkey <Key-Right> "goforw"
827 bindkey <Key-Left> "goback"
828 bind . <Key-Prior> "selnextpage -1"
829 bind . <Key-Next> "selnextpage 1"
830 bind . <Control-Home> "allcanvs yview moveto 0.0"
831 bind . <Control-End> "allcanvs yview moveto 1.0"
832 bind . <Control-Key-Up> "allcanvs yview scroll -1 units"
833 bind . <Control-Key-Down> "allcanvs yview scroll 1 units"
834 bind . <Control-Key-Prior> "allcanvs yview scroll -1 pages"
835 bind . <Control-Key-Next> "allcanvs yview scroll 1 pages"
836 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
837 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
838 bindkey <Key-space> "$ctext yview scroll 1 pages"
839 bindkey p "selnextline -1"
840 bindkey n "selnextline 1"
841 bindkey z "goback"
842 bindkey x "goforw"
843 bindkey i "selnextline -1"
844 bindkey k "selnextline 1"
845 bindkey j "goback"
846 bindkey l "goforw"
847 bindkey b "$ctext yview scroll -1 pages"
848 bindkey d "$ctext yview scroll 18 units"
849 bindkey u "$ctext yview scroll -18 units"
850 bindkey / {findnext 1}
851 bindkey <Key-Return> {findnext 0}
852 bindkey ? findprev
853 bindkey f nextfile
854 bindkey <F5> updatecommits
855 bind . <Control-q> doquit
856 bind . <Control-f> dofind
857 bind . <Control-g> {findnext 0}
858 bind . <Control-r> dosearchback
859 bind . <Control-s> dosearch
860 bind . <Control-equal> {incrfont 1}
861 bind . <Control-KP_Add> {incrfont 1}
862 bind . <Control-minus> {incrfont -1}
863 bind . <Control-KP_Subtract> {incrfont -1}
864 wm protocol . WM_DELETE_WINDOW doquit
865 bind . <Button-1> "click %W"
866 bind $fstring <Key-Return> dofind
867 bind $sha1entry <Key-Return> gotocommit
868 bind $sha1entry <<PasteSelection>> clearsha1
869 bind $cflist <1> {sel_flist %W %x %y; break}
870 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
871 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
873 set maincursor [. cget -cursor]
874 set textcursor [$ctext cget -cursor]
875 set curtextcursor $textcursor
877 set rowctxmenu .rowctxmenu
878 menu $rowctxmenu -tearoff 0
879 $rowctxmenu add command -label "Diff this -> selected" \
880 -command {diffvssel 0}
881 $rowctxmenu add command -label "Diff selected -> this" \
882 -command {diffvssel 1}
883 $rowctxmenu add command -label "Make patch" -command mkpatch
884 $rowctxmenu add command -label "Create tag" -command mktag
885 $rowctxmenu add command -label "Write commit to file" -command writecommit
886 $rowctxmenu add command -label "Create new branch" -command mkbranch
887 $rowctxmenu add command -label "Cherry-pick this commit" \
888 -command cherrypick
889 $rowctxmenu add command -label "Reset HEAD branch to here" \
890 -command resethead
892 set fakerowmenu .fakerowmenu
893 menu $fakerowmenu -tearoff 0
894 $fakerowmenu add command -label "Diff this -> selected" \
895 -command {diffvssel 0}
896 $fakerowmenu add command -label "Diff selected -> this" \
897 -command {diffvssel 1}
898 $fakerowmenu add command -label "Make patch" -command mkpatch
899 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
900 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
901 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
903 set headctxmenu .headctxmenu
904 menu $headctxmenu -tearoff 0
905 $headctxmenu add command -label "Check out this branch" \
906 -command cobranch
907 $headctxmenu add command -label "Remove this branch" \
908 -command rmbranch
911 # mouse-2 makes all windows scan vertically, but only the one
912 # the cursor is in scans horizontally
913 proc canvscan {op w x y} {
914 global canv canv2 canv3
915 foreach c [list $canv $canv2 $canv3] {
916 if {$c == $w} {
917 $c scan $op $x $y
918 } else {
919 $c scan $op 0 $y
924 proc scrollcanv {cscroll f0 f1} {
925 $cscroll set $f0 $f1
926 drawfrac $f0 $f1
927 flushhighlights
930 # when we make a key binding for the toplevel, make sure
931 # it doesn't get triggered when that key is pressed in the
932 # find string entry widget.
933 proc bindkey {ev script} {
934 global entries
935 bind . $ev $script
936 set escript [bind Entry $ev]
937 if {$escript == {}} {
938 set escript [bind Entry <Key>]
940 foreach e $entries {
941 bind $e $ev "$escript; break"
945 # set the focus back to the toplevel for any click outside
946 # the entry widgets
947 proc click {w} {
948 global entries
949 foreach e $entries {
950 if {$w == $e} return
952 focus .
955 proc savestuff {w} {
956 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
957 global stuffsaved findmergefiles maxgraphpct
958 global maxwidth showneartags showlocalchanges
959 global viewname viewfiles viewargs viewperm nextviewnum
960 global cmitmode wrapcomment
961 global colors bgcolor fgcolor diffcolors selectbgcolor
963 if {$stuffsaved} return
964 if {![winfo viewable .]} return
965 catch {
966 set f [open "~/.gitk-new" w]
967 puts $f [list set mainfont $mainfont]
968 puts $f [list set textfont $textfont]
969 puts $f [list set uifont $uifont]
970 puts $f [list set tabstop $tabstop]
971 puts $f [list set findmergefiles $findmergefiles]
972 puts $f [list set maxgraphpct $maxgraphpct]
973 puts $f [list set maxwidth $maxwidth]
974 puts $f [list set cmitmode $cmitmode]
975 puts $f [list set wrapcomment $wrapcomment]
976 puts $f [list set showneartags $showneartags]
977 puts $f [list set showlocalchanges $showlocalchanges]
978 puts $f [list set bgcolor $bgcolor]
979 puts $f [list set fgcolor $fgcolor]
980 puts $f [list set colors $colors]
981 puts $f [list set diffcolors $diffcolors]
982 puts $f [list set selectbgcolor $selectbgcolor]
984 puts $f "set geometry(main) [wm geometry .]"
985 puts $f "set geometry(topwidth) [winfo width .tf]"
986 puts $f "set geometry(topheight) [winfo height .tf]"
987 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
988 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
989 puts $f "set geometry(botwidth) [winfo width .bleft]"
990 puts $f "set geometry(botheight) [winfo height .bleft]"
992 puts -nonewline $f "set permviews {"
993 for {set v 0} {$v < $nextviewnum} {incr v} {
994 if {$viewperm($v)} {
995 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
998 puts $f "}"
999 close $f
1000 file rename -force "~/.gitk-new" "~/.gitk"
1002 set stuffsaved 1
1005 proc resizeclistpanes {win w} {
1006 global oldwidth
1007 if {[info exists oldwidth($win)]} {
1008 set s0 [$win sash coord 0]
1009 set s1 [$win sash coord 1]
1010 if {$w < 60} {
1011 set sash0 [expr {int($w/2 - 2)}]
1012 set sash1 [expr {int($w*5/6 - 2)}]
1013 } else {
1014 set factor [expr {1.0 * $w / $oldwidth($win)}]
1015 set sash0 [expr {int($factor * [lindex $s0 0])}]
1016 set sash1 [expr {int($factor * [lindex $s1 0])}]
1017 if {$sash0 < 30} {
1018 set sash0 30
1020 if {$sash1 < $sash0 + 20} {
1021 set sash1 [expr {$sash0 + 20}]
1023 if {$sash1 > $w - 10} {
1024 set sash1 [expr {$w - 10}]
1025 if {$sash0 > $sash1 - 20} {
1026 set sash0 [expr {$sash1 - 20}]
1030 $win sash place 0 $sash0 [lindex $s0 1]
1031 $win sash place 1 $sash1 [lindex $s1 1]
1033 set oldwidth($win) $w
1036 proc resizecdetpanes {win w} {
1037 global oldwidth
1038 if {[info exists oldwidth($win)]} {
1039 set s0 [$win sash coord 0]
1040 if {$w < 60} {
1041 set sash0 [expr {int($w*3/4 - 2)}]
1042 } else {
1043 set factor [expr {1.0 * $w / $oldwidth($win)}]
1044 set sash0 [expr {int($factor * [lindex $s0 0])}]
1045 if {$sash0 < 45} {
1046 set sash0 45
1048 if {$sash0 > $w - 15} {
1049 set sash0 [expr {$w - 15}]
1052 $win sash place 0 $sash0 [lindex $s0 1]
1054 set oldwidth($win) $w
1057 proc allcanvs args {
1058 global canv canv2 canv3
1059 eval $canv $args
1060 eval $canv2 $args
1061 eval $canv3 $args
1064 proc bindall {event action} {
1065 global canv canv2 canv3
1066 bind $canv $event $action
1067 bind $canv2 $event $action
1068 bind $canv3 $event $action
1071 proc about {} {
1072 global uifont
1073 set w .about
1074 if {[winfo exists $w]} {
1075 raise $w
1076 return
1078 toplevel $w
1079 wm title $w "About gitk"
1080 message $w.m -text {
1081 Gitk - a commit viewer for git
1083 Copyright © 2005-2006 Paul Mackerras
1085 Use and redistribute under the terms of the GNU General Public License} \
1086 -justify center -aspect 400 -border 2 -bg white -relief groove
1087 pack $w.m -side top -fill x -padx 2 -pady 2
1088 $w.m configure -font $uifont
1089 button $w.ok -text Close -command "destroy $w" -default active
1090 pack $w.ok -side bottom
1091 $w.ok configure -font $uifont
1092 bind $w <Visibility> "focus $w.ok"
1093 bind $w <Key-Escape> "destroy $w"
1094 bind $w <Key-Return> "destroy $w"
1097 proc keys {} {
1098 global uifont
1099 set w .keys
1100 if {[winfo exists $w]} {
1101 raise $w
1102 return
1104 toplevel $w
1105 wm title $w "Gitk key bindings"
1106 message $w.m -text {
1107 Gitk key bindings:
1109 <Ctrl-Q> Quit
1110 <Home> Move to first commit
1111 <End> Move to last commit
1112 <Up>, p, i Move up one commit
1113 <Down>, n, k Move down one commit
1114 <Left>, z, j Go back in history list
1115 <Right>, x, l Go forward in history list
1116 <PageUp> Move up one page in commit list
1117 <PageDown> Move down one page in commit list
1118 <Ctrl-Home> Scroll to top of commit list
1119 <Ctrl-End> Scroll to bottom of commit list
1120 <Ctrl-Up> Scroll commit list up one line
1121 <Ctrl-Down> Scroll commit list down one line
1122 <Ctrl-PageUp> Scroll commit list up one page
1123 <Ctrl-PageDown> Scroll commit list down one page
1124 <Shift-Up> Move to previous highlighted line
1125 <Shift-Down> Move to next highlighted line
1126 <Delete>, b Scroll diff view up one page
1127 <Backspace> Scroll diff view up one page
1128 <Space> Scroll diff view down one page
1129 u Scroll diff view up 18 lines
1130 d Scroll diff view down 18 lines
1131 <Ctrl-F> Find
1132 <Ctrl-G> Move to next find hit
1133 <Return> Move to next find hit
1134 / Move to next find hit, or redo find
1135 ? Move to previous find hit
1136 f Scroll diff view to next file
1137 <Ctrl-S> Search for next hit in diff view
1138 <Ctrl-R> Search for previous hit in diff view
1139 <Ctrl-KP+> Increase font size
1140 <Ctrl-plus> Increase font size
1141 <Ctrl-KP-> Decrease font size
1142 <Ctrl-minus> Decrease font size
1143 <F5> Update
1145 -justify left -bg white -border 2 -relief groove
1146 pack $w.m -side top -fill both -padx 2 -pady 2
1147 $w.m configure -font $uifont
1148 button $w.ok -text Close -command "destroy $w" -default active
1149 pack $w.ok -side bottom
1150 $w.ok configure -font $uifont
1151 bind $w <Visibility> "focus $w.ok"
1152 bind $w <Key-Escape> "destroy $w"
1153 bind $w <Key-Return> "destroy $w"
1156 # Procedures for manipulating the file list window at the
1157 # bottom right of the overall window.
1159 proc treeview {w l openlevs} {
1160 global treecontents treediropen treeheight treeparent treeindex
1162 set ix 0
1163 set treeindex() 0
1164 set lev 0
1165 set prefix {}
1166 set prefixend -1
1167 set prefendstack {}
1168 set htstack {}
1169 set ht 0
1170 set treecontents() {}
1171 $w conf -state normal
1172 foreach f $l {
1173 while {[string range $f 0 $prefixend] ne $prefix} {
1174 if {$lev <= $openlevs} {
1175 $w mark set e:$treeindex($prefix) "end -1c"
1176 $w mark gravity e:$treeindex($prefix) left
1178 set treeheight($prefix) $ht
1179 incr ht [lindex $htstack end]
1180 set htstack [lreplace $htstack end end]
1181 set prefixend [lindex $prefendstack end]
1182 set prefendstack [lreplace $prefendstack end end]
1183 set prefix [string range $prefix 0 $prefixend]
1184 incr lev -1
1186 set tail [string range $f [expr {$prefixend+1}] end]
1187 while {[set slash [string first "/" $tail]] >= 0} {
1188 lappend htstack $ht
1189 set ht 0
1190 lappend prefendstack $prefixend
1191 incr prefixend [expr {$slash + 1}]
1192 set d [string range $tail 0 $slash]
1193 lappend treecontents($prefix) $d
1194 set oldprefix $prefix
1195 append prefix $d
1196 set treecontents($prefix) {}
1197 set treeindex($prefix) [incr ix]
1198 set treeparent($prefix) $oldprefix
1199 set tail [string range $tail [expr {$slash+1}] end]
1200 if {$lev <= $openlevs} {
1201 set ht 1
1202 set treediropen($prefix) [expr {$lev < $openlevs}]
1203 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1204 $w mark set d:$ix "end -1c"
1205 $w mark gravity d:$ix left
1206 set str "\n"
1207 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1208 $w insert end $str
1209 $w image create end -align center -image $bm -padx 1 \
1210 -name a:$ix
1211 $w insert end $d [highlight_tag $prefix]
1212 $w mark set s:$ix "end -1c"
1213 $w mark gravity s:$ix left
1215 incr lev
1217 if {$tail ne {}} {
1218 if {$lev <= $openlevs} {
1219 incr ht
1220 set str "\n"
1221 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1222 $w insert end $str
1223 $w insert end $tail [highlight_tag $f]
1225 lappend treecontents($prefix) $tail
1228 while {$htstack ne {}} {
1229 set treeheight($prefix) $ht
1230 incr ht [lindex $htstack end]
1231 set htstack [lreplace $htstack end end]
1232 set prefixend [lindex $prefendstack end]
1233 set prefendstack [lreplace $prefendstack end end]
1234 set prefix [string range $prefix 0 $prefixend]
1236 $w conf -state disabled
1239 proc linetoelt {l} {
1240 global treeheight treecontents
1242 set y 2
1243 set prefix {}
1244 while {1} {
1245 foreach e $treecontents($prefix) {
1246 if {$y == $l} {
1247 return "$prefix$e"
1249 set n 1
1250 if {[string index $e end] eq "/"} {
1251 set n $treeheight($prefix$e)
1252 if {$y + $n > $l} {
1253 append prefix $e
1254 incr y
1255 break
1258 incr y $n
1263 proc highlight_tree {y prefix} {
1264 global treeheight treecontents cflist
1266 foreach e $treecontents($prefix) {
1267 set path $prefix$e
1268 if {[highlight_tag $path] ne {}} {
1269 $cflist tag add bold $y.0 "$y.0 lineend"
1271 incr y
1272 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1273 set y [highlight_tree $y $path]
1276 return $y
1279 proc treeclosedir {w dir} {
1280 global treediropen treeheight treeparent treeindex
1282 set ix $treeindex($dir)
1283 $w conf -state normal
1284 $w delete s:$ix e:$ix
1285 set treediropen($dir) 0
1286 $w image configure a:$ix -image tri-rt
1287 $w conf -state disabled
1288 set n [expr {1 - $treeheight($dir)}]
1289 while {$dir ne {}} {
1290 incr treeheight($dir) $n
1291 set dir $treeparent($dir)
1295 proc treeopendir {w dir} {
1296 global treediropen treeheight treeparent treecontents treeindex
1298 set ix $treeindex($dir)
1299 $w conf -state normal
1300 $w image configure a:$ix -image tri-dn
1301 $w mark set e:$ix s:$ix
1302 $w mark gravity e:$ix right
1303 set lev 0
1304 set str "\n"
1305 set n [llength $treecontents($dir)]
1306 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1307 incr lev
1308 append str "\t"
1309 incr treeheight($x) $n
1311 foreach e $treecontents($dir) {
1312 set de $dir$e
1313 if {[string index $e end] eq "/"} {
1314 set iy $treeindex($de)
1315 $w mark set d:$iy e:$ix
1316 $w mark gravity d:$iy left
1317 $w insert e:$ix $str
1318 set treediropen($de) 0
1319 $w image create e:$ix -align center -image tri-rt -padx 1 \
1320 -name a:$iy
1321 $w insert e:$ix $e [highlight_tag $de]
1322 $w mark set s:$iy e:$ix
1323 $w mark gravity s:$iy left
1324 set treeheight($de) 1
1325 } else {
1326 $w insert e:$ix $str
1327 $w insert e:$ix $e [highlight_tag $de]
1330 $w mark gravity e:$ix left
1331 $w conf -state disabled
1332 set treediropen($dir) 1
1333 set top [lindex [split [$w index @0,0] .] 0]
1334 set ht [$w cget -height]
1335 set l [lindex [split [$w index s:$ix] .] 0]
1336 if {$l < $top} {
1337 $w yview $l.0
1338 } elseif {$l + $n + 1 > $top + $ht} {
1339 set top [expr {$l + $n + 2 - $ht}]
1340 if {$l < $top} {
1341 set top $l
1343 $w yview $top.0
1347 proc treeclick {w x y} {
1348 global treediropen cmitmode ctext cflist cflist_top
1350 if {$cmitmode ne "tree"} return
1351 if {![info exists cflist_top]} return
1352 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1353 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1354 $cflist tag add highlight $l.0 "$l.0 lineend"
1355 set cflist_top $l
1356 if {$l == 1} {
1357 $ctext yview 1.0
1358 return
1360 set e [linetoelt $l]
1361 if {[string index $e end] ne "/"} {
1362 showfile $e
1363 } elseif {$treediropen($e)} {
1364 treeclosedir $w $e
1365 } else {
1366 treeopendir $w $e
1370 proc setfilelist {id} {
1371 global treefilelist cflist
1373 treeview $cflist $treefilelist($id) 0
1376 image create bitmap tri-rt -background black -foreground blue -data {
1377 #define tri-rt_width 13
1378 #define tri-rt_height 13
1379 static unsigned char tri-rt_bits[] = {
1380 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1381 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1382 0x00, 0x00};
1383 } -maskdata {
1384 #define tri-rt-mask_width 13
1385 #define tri-rt-mask_height 13
1386 static unsigned char tri-rt-mask_bits[] = {
1387 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1388 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1389 0x08, 0x00};
1391 image create bitmap tri-dn -background black -foreground blue -data {
1392 #define tri-dn_width 13
1393 #define tri-dn_height 13
1394 static unsigned char tri-dn_bits[] = {
1395 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1396 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1397 0x00, 0x00};
1398 } -maskdata {
1399 #define tri-dn-mask_width 13
1400 #define tri-dn-mask_height 13
1401 static unsigned char tri-dn-mask_bits[] = {
1402 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1403 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1404 0x00, 0x00};
1407 proc init_flist {first} {
1408 global cflist cflist_top selectedline difffilestart
1410 $cflist conf -state normal
1411 $cflist delete 0.0 end
1412 if {$first ne {}} {
1413 $cflist insert end $first
1414 set cflist_top 1
1415 $cflist tag add highlight 1.0 "1.0 lineend"
1416 } else {
1417 catch {unset cflist_top}
1419 $cflist conf -state disabled
1420 set difffilestart {}
1423 proc highlight_tag {f} {
1424 global highlight_paths
1426 foreach p $highlight_paths {
1427 if {[string match $p $f]} {
1428 return "bold"
1431 return {}
1434 proc highlight_filelist {} {
1435 global cmitmode cflist
1437 $cflist conf -state normal
1438 if {$cmitmode ne "tree"} {
1439 set end [lindex [split [$cflist index end] .] 0]
1440 for {set l 2} {$l < $end} {incr l} {
1441 set line [$cflist get $l.0 "$l.0 lineend"]
1442 if {[highlight_tag $line] ne {}} {
1443 $cflist tag add bold $l.0 "$l.0 lineend"
1446 } else {
1447 highlight_tree 2 {}
1449 $cflist conf -state disabled
1452 proc unhighlight_filelist {} {
1453 global cflist
1455 $cflist conf -state normal
1456 $cflist tag remove bold 1.0 end
1457 $cflist conf -state disabled
1460 proc add_flist {fl} {
1461 global cflist
1463 $cflist conf -state normal
1464 foreach f $fl {
1465 $cflist insert end "\n"
1466 $cflist insert end $f [highlight_tag $f]
1468 $cflist conf -state disabled
1471 proc sel_flist {w x y} {
1472 global ctext difffilestart cflist cflist_top cmitmode
1474 if {$cmitmode eq "tree"} return
1475 if {![info exists cflist_top]} return
1476 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1477 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1478 $cflist tag add highlight $l.0 "$l.0 lineend"
1479 set cflist_top $l
1480 if {$l == 1} {
1481 $ctext yview 1.0
1482 } else {
1483 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1487 # Functions for adding and removing shell-type quoting
1489 proc shellquote {str} {
1490 if {![string match "*\['\"\\ \t]*" $str]} {
1491 return $str
1493 if {![string match "*\['\"\\]*" $str]} {
1494 return "\"$str\""
1496 if {![string match "*'*" $str]} {
1497 return "'$str'"
1499 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1502 proc shellarglist {l} {
1503 set str {}
1504 foreach a $l {
1505 if {$str ne {}} {
1506 append str " "
1508 append str [shellquote $a]
1510 return $str
1513 proc shelldequote {str} {
1514 set ret {}
1515 set used -1
1516 while {1} {
1517 incr used
1518 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1519 append ret [string range $str $used end]
1520 set used [string length $str]
1521 break
1523 set first [lindex $first 0]
1524 set ch [string index $str $first]
1525 if {$first > $used} {
1526 append ret [string range $str $used [expr {$first - 1}]]
1527 set used $first
1529 if {$ch eq " " || $ch eq "\t"} break
1530 incr used
1531 if {$ch eq "'"} {
1532 set first [string first "'" $str $used]
1533 if {$first < 0} {
1534 error "unmatched single-quote"
1536 append ret [string range $str $used [expr {$first - 1}]]
1537 set used $first
1538 continue
1540 if {$ch eq "\\"} {
1541 if {$used >= [string length $str]} {
1542 error "trailing backslash"
1544 append ret [string index $str $used]
1545 continue
1547 # here ch == "\""
1548 while {1} {
1549 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1550 error "unmatched double-quote"
1552 set first [lindex $first 0]
1553 set ch [string index $str $first]
1554 if {$first > $used} {
1555 append ret [string range $str $used [expr {$first - 1}]]
1556 set used $first
1558 if {$ch eq "\""} break
1559 incr used
1560 append ret [string index $str $used]
1561 incr used
1564 return [list $used $ret]
1567 proc shellsplit {str} {
1568 set l {}
1569 while {1} {
1570 set str [string trimleft $str]
1571 if {$str eq {}} break
1572 set dq [shelldequote $str]
1573 set n [lindex $dq 0]
1574 set word [lindex $dq 1]
1575 set str [string range $str $n end]
1576 lappend l $word
1578 return $l
1581 # Code to implement multiple views
1583 proc newview {ishighlight} {
1584 global nextviewnum newviewname newviewperm uifont newishighlight
1585 global newviewargs revtreeargs
1587 set newishighlight $ishighlight
1588 set top .gitkview
1589 if {[winfo exists $top]} {
1590 raise $top
1591 return
1593 set newviewname($nextviewnum) "View $nextviewnum"
1594 set newviewperm($nextviewnum) 0
1595 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1596 vieweditor $top $nextviewnum "Gitk view definition"
1599 proc editview {} {
1600 global curview
1601 global viewname viewperm newviewname newviewperm
1602 global viewargs newviewargs
1604 set top .gitkvedit-$curview
1605 if {[winfo exists $top]} {
1606 raise $top
1607 return
1609 set newviewname($curview) $viewname($curview)
1610 set newviewperm($curview) $viewperm($curview)
1611 set newviewargs($curview) [shellarglist $viewargs($curview)]
1612 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1615 proc vieweditor {top n title} {
1616 global newviewname newviewperm viewfiles
1617 global uifont
1619 toplevel $top
1620 wm title $top $title
1621 label $top.nl -text "Name" -font $uifont
1622 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1623 grid $top.nl $top.name -sticky w -pady 5
1624 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1625 -font $uifont
1626 grid $top.perm - -pady 5 -sticky w
1627 message $top.al -aspect 1000 -font $uifont \
1628 -text "Commits to include (arguments to git rev-list):"
1629 grid $top.al - -sticky w -pady 5
1630 entry $top.args -width 50 -textvariable newviewargs($n) \
1631 -background white -font $uifont
1632 grid $top.args - -sticky ew -padx 5
1633 message $top.l -aspect 1000 -font $uifont \
1634 -text "Enter files and directories to include, one per line:"
1635 grid $top.l - -sticky w
1636 text $top.t -width 40 -height 10 -background white -font $uifont
1637 if {[info exists viewfiles($n)]} {
1638 foreach f $viewfiles($n) {
1639 $top.t insert end $f
1640 $top.t insert end "\n"
1642 $top.t delete {end - 1c} end
1643 $top.t mark set insert 0.0
1645 grid $top.t - -sticky ew -padx 5
1646 frame $top.buts
1647 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1648 -font $uifont
1649 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1650 -font $uifont
1651 grid $top.buts.ok $top.buts.can
1652 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1653 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1654 grid $top.buts - -pady 10 -sticky ew
1655 focus $top.t
1658 proc doviewmenu {m first cmd op argv} {
1659 set nmenu [$m index end]
1660 for {set i $first} {$i <= $nmenu} {incr i} {
1661 if {[$m entrycget $i -command] eq $cmd} {
1662 eval $m $op $i $argv
1663 break
1668 proc allviewmenus {n op args} {
1669 global viewhlmenu
1671 doviewmenu .bar.view 5 [list showview $n] $op $args
1672 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1675 proc newviewok {top n} {
1676 global nextviewnum newviewperm newviewname newishighlight
1677 global viewname viewfiles viewperm selectedview curview
1678 global viewargs newviewargs viewhlmenu
1680 if {[catch {
1681 set newargs [shellsplit $newviewargs($n)]
1682 } err]} {
1683 error_popup "Error in commit selection arguments: $err"
1684 wm raise $top
1685 focus $top
1686 return
1688 set files {}
1689 foreach f [split [$top.t get 0.0 end] "\n"] {
1690 set ft [string trim $f]
1691 if {$ft ne {}} {
1692 lappend files $ft
1695 if {![info exists viewfiles($n)]} {
1696 # creating a new view
1697 incr nextviewnum
1698 set viewname($n) $newviewname($n)
1699 set viewperm($n) $newviewperm($n)
1700 set viewfiles($n) $files
1701 set viewargs($n) $newargs
1702 addviewmenu $n
1703 if {!$newishighlight} {
1704 run showview $n
1705 } else {
1706 run addvhighlight $n
1708 } else {
1709 # editing an existing view
1710 set viewperm($n) $newviewperm($n)
1711 if {$newviewname($n) ne $viewname($n)} {
1712 set viewname($n) $newviewname($n)
1713 doviewmenu .bar.view 5 [list showview $n] \
1714 entryconf [list -label $viewname($n)]
1715 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1716 entryconf [list -label $viewname($n) -value $viewname($n)]
1718 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1719 set viewfiles($n) $files
1720 set viewargs($n) $newargs
1721 if {$curview == $n} {
1722 run updatecommits
1726 catch {destroy $top}
1729 proc delview {} {
1730 global curview viewdata viewperm hlview selectedhlview
1732 if {$curview == 0} return
1733 if {[info exists hlview] && $hlview == $curview} {
1734 set selectedhlview None
1735 unset hlview
1737 allviewmenus $curview delete
1738 set viewdata($curview) {}
1739 set viewperm($curview) 0
1740 showview 0
1743 proc addviewmenu {n} {
1744 global viewname viewhlmenu
1746 .bar.view add radiobutton -label $viewname($n) \
1747 -command [list showview $n] -variable selectedview -value $n
1748 $viewhlmenu add radiobutton -label $viewname($n) \
1749 -command [list addvhighlight $n] -variable selectedhlview
1752 proc flatten {var} {
1753 global $var
1755 set ret {}
1756 foreach i [array names $var] {
1757 lappend ret $i [set $var\($i\)]
1759 return $ret
1762 proc unflatten {var l} {
1763 global $var
1765 catch {unset $var}
1766 foreach {i v} $l {
1767 set $var\($i\) $v
1771 proc showview {n} {
1772 global curview viewdata viewfiles
1773 global displayorder parentlist rowidlist rowoffsets
1774 global colormap rowtextx commitrow nextcolor canvxmax
1775 global numcommits rowrangelist commitlisted idrowranges rowchk
1776 global selectedline currentid canv canvy0
1777 global treediffs
1778 global pending_select phase
1779 global commitidx rowlaidout rowoptim
1780 global commfd
1781 global selectedview selectfirst
1782 global vparentlist vdisporder vcmitlisted
1783 global hlview selectedhlview
1785 if {$n == $curview} return
1786 set selid {}
1787 if {[info exists selectedline]} {
1788 set selid $currentid
1789 set y [yc $selectedline]
1790 set ymax [lindex [$canv cget -scrollregion] 3]
1791 set span [$canv yview]
1792 set ytop [expr {[lindex $span 0] * $ymax}]
1793 set ybot [expr {[lindex $span 1] * $ymax}]
1794 if {$ytop < $y && $y < $ybot} {
1795 set yscreen [expr {$y - $ytop}]
1796 } else {
1797 set yscreen [expr {($ybot - $ytop) / 2}]
1799 } elseif {[info exists pending_select]} {
1800 set selid $pending_select
1801 unset pending_select
1803 unselectline
1804 normalline
1805 if {$curview >= 0} {
1806 set vparentlist($curview) $parentlist
1807 set vdisporder($curview) $displayorder
1808 set vcmitlisted($curview) $commitlisted
1809 if {$phase ne {}} {
1810 set viewdata($curview) \
1811 [list $phase $rowidlist $rowoffsets $rowrangelist \
1812 [flatten idrowranges] [flatten idinlist] \
1813 $rowlaidout $rowoptim $numcommits]
1814 } elseif {![info exists viewdata($curview)]
1815 || [lindex $viewdata($curview) 0] ne {}} {
1816 set viewdata($curview) \
1817 [list {} $rowidlist $rowoffsets $rowrangelist]
1820 catch {unset treediffs}
1821 clear_display
1822 if {[info exists hlview] && $hlview == $n} {
1823 unset hlview
1824 set selectedhlview None
1827 set curview $n
1828 set selectedview $n
1829 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1830 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1832 if {![info exists viewdata($n)]} {
1833 if {$selid ne {}} {
1834 set pending_select $selid
1836 getcommits
1837 return
1840 set v $viewdata($n)
1841 set phase [lindex $v 0]
1842 set displayorder $vdisporder($n)
1843 set parentlist $vparentlist($n)
1844 set commitlisted $vcmitlisted($n)
1845 set rowidlist [lindex $v 1]
1846 set rowoffsets [lindex $v 2]
1847 set rowrangelist [lindex $v 3]
1848 if {$phase eq {}} {
1849 set numcommits [llength $displayorder]
1850 catch {unset idrowranges}
1851 } else {
1852 unflatten idrowranges [lindex $v 4]
1853 unflatten idinlist [lindex $v 5]
1854 set rowlaidout [lindex $v 6]
1855 set rowoptim [lindex $v 7]
1856 set numcommits [lindex $v 8]
1857 catch {unset rowchk}
1860 catch {unset colormap}
1861 catch {unset rowtextx}
1862 set nextcolor 0
1863 set canvxmax [$canv cget -width]
1864 set curview $n
1865 set row 0
1866 setcanvscroll
1867 set yf 0
1868 set row {}
1869 set selectfirst 0
1870 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1871 set row $commitrow($n,$selid)
1872 # try to get the selected row in the same position on the screen
1873 set ymax [lindex [$canv cget -scrollregion] 3]
1874 set ytop [expr {[yc $row] - $yscreen}]
1875 if {$ytop < 0} {
1876 set ytop 0
1878 set yf [expr {$ytop * 1.0 / $ymax}]
1880 allcanvs yview moveto $yf
1881 drawvisible
1882 if {$row ne {}} {
1883 selectline $row 0
1884 } elseif {$selid ne {}} {
1885 set pending_select $selid
1886 } else {
1887 set row [first_real_row]
1888 if {$row < $numcommits} {
1889 selectline $row 0
1890 } else {
1891 set selectfirst 1
1894 if {$phase ne {}} {
1895 if {$phase eq "getcommits"} {
1896 show_status "Reading commits..."
1898 run chewcommits $n
1899 } elseif {$numcommits == 0} {
1900 show_status "No commits selected"
1904 # Stuff relating to the highlighting facility
1906 proc ishighlighted {row} {
1907 global vhighlights fhighlights nhighlights rhighlights
1909 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1910 return $nhighlights($row)
1912 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1913 return $vhighlights($row)
1915 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1916 return $fhighlights($row)
1918 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1919 return $rhighlights($row)
1921 return 0
1924 proc bolden {row font} {
1925 global canv linehtag selectedline boldrows
1927 lappend boldrows $row
1928 $canv itemconf $linehtag($row) -font $font
1929 if {[info exists selectedline] && $row == $selectedline} {
1930 $canv delete secsel
1931 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1932 -outline {{}} -tags secsel \
1933 -fill [$canv cget -selectbackground]]
1934 $canv lower $t
1938 proc bolden_name {row font} {
1939 global canv2 linentag selectedline boldnamerows
1941 lappend boldnamerows $row
1942 $canv2 itemconf $linentag($row) -font $font
1943 if {[info exists selectedline] && $row == $selectedline} {
1944 $canv2 delete secsel
1945 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1946 -outline {{}} -tags secsel \
1947 -fill [$canv2 cget -selectbackground]]
1948 $canv2 lower $t
1952 proc unbolden {} {
1953 global mainfont boldrows
1955 set stillbold {}
1956 foreach row $boldrows {
1957 if {![ishighlighted $row]} {
1958 bolden $row $mainfont
1959 } else {
1960 lappend stillbold $row
1963 set boldrows $stillbold
1966 proc addvhighlight {n} {
1967 global hlview curview viewdata vhl_done vhighlights commitidx
1969 if {[info exists hlview]} {
1970 delvhighlight
1972 set hlview $n
1973 if {$n != $curview && ![info exists viewdata($n)]} {
1974 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1975 set vparentlist($n) {}
1976 set vdisporder($n) {}
1977 set vcmitlisted($n) {}
1978 start_rev_list $n
1980 set vhl_done $commitidx($hlview)
1981 if {$vhl_done > 0} {
1982 drawvisible
1986 proc delvhighlight {} {
1987 global hlview vhighlights
1989 if {![info exists hlview]} return
1990 unset hlview
1991 catch {unset vhighlights}
1992 unbolden
1995 proc vhighlightmore {} {
1996 global hlview vhl_done commitidx vhighlights
1997 global displayorder vdisporder curview mainfont
1999 set font [concat $mainfont bold]
2000 set max $commitidx($hlview)
2001 if {$hlview == $curview} {
2002 set disp $displayorder
2003 } else {
2004 set disp $vdisporder($hlview)
2006 set vr [visiblerows]
2007 set r0 [lindex $vr 0]
2008 set r1 [lindex $vr 1]
2009 for {set i $vhl_done} {$i < $max} {incr i} {
2010 set id [lindex $disp $i]
2011 if {[info exists commitrow($curview,$id)]} {
2012 set row $commitrow($curview,$id)
2013 if {$r0 <= $row && $row <= $r1} {
2014 if {![highlighted $row]} {
2015 bolden $row $font
2017 set vhighlights($row) 1
2021 set vhl_done $max
2024 proc askvhighlight {row id} {
2025 global hlview vhighlights commitrow iddrawn mainfont
2027 if {[info exists commitrow($hlview,$id)]} {
2028 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2029 bolden $row [concat $mainfont bold]
2031 set vhighlights($row) 1
2032 } else {
2033 set vhighlights($row) 0
2037 proc hfiles_change {name ix op} {
2038 global highlight_files filehighlight fhighlights fh_serial
2039 global mainfont highlight_paths
2041 if {[info exists filehighlight]} {
2042 # delete previous highlights
2043 catch {close $filehighlight}
2044 unset filehighlight
2045 catch {unset fhighlights}
2046 unbolden
2047 unhighlight_filelist
2049 set highlight_paths {}
2050 after cancel do_file_hl $fh_serial
2051 incr fh_serial
2052 if {$highlight_files ne {}} {
2053 after 300 do_file_hl $fh_serial
2057 proc makepatterns {l} {
2058 set ret {}
2059 foreach e $l {
2060 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2061 if {[string index $ee end] eq "/"} {
2062 lappend ret "$ee*"
2063 } else {
2064 lappend ret $ee
2065 lappend ret "$ee/*"
2068 return $ret
2071 proc do_file_hl {serial} {
2072 global highlight_files filehighlight highlight_paths gdttype fhl_list
2074 if {$gdttype eq "touching paths:"} {
2075 if {[catch {set paths [shellsplit $highlight_files]}]} return
2076 set highlight_paths [makepatterns $paths]
2077 highlight_filelist
2078 set gdtargs [concat -- $paths]
2079 } else {
2080 set gdtargs [list "-S$highlight_files"]
2082 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2083 set filehighlight [open $cmd r+]
2084 fconfigure $filehighlight -blocking 0
2085 filerun $filehighlight readfhighlight
2086 set fhl_list {}
2087 drawvisible
2088 flushhighlights
2091 proc flushhighlights {} {
2092 global filehighlight fhl_list
2094 if {[info exists filehighlight]} {
2095 lappend fhl_list {}
2096 puts $filehighlight ""
2097 flush $filehighlight
2101 proc askfilehighlight {row id} {
2102 global filehighlight fhighlights fhl_list
2104 lappend fhl_list $id
2105 set fhighlights($row) -1
2106 puts $filehighlight $id
2109 proc readfhighlight {} {
2110 global filehighlight fhighlights commitrow curview mainfont iddrawn
2111 global fhl_list
2113 if {![info exists filehighlight]} {
2114 return 0
2116 set nr 0
2117 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2118 set line [string trim $line]
2119 set i [lsearch -exact $fhl_list $line]
2120 if {$i < 0} continue
2121 for {set j 0} {$j < $i} {incr j} {
2122 set id [lindex $fhl_list $j]
2123 if {[info exists commitrow($curview,$id)]} {
2124 set fhighlights($commitrow($curview,$id)) 0
2127 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2128 if {$line eq {}} continue
2129 if {![info exists commitrow($curview,$line)]} continue
2130 set row $commitrow($curview,$line)
2131 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2132 bolden $row [concat $mainfont bold]
2134 set fhighlights($row) 1
2136 if {[eof $filehighlight]} {
2137 # strange...
2138 puts "oops, git diff-tree died"
2139 catch {close $filehighlight}
2140 unset filehighlight
2141 return 0
2143 next_hlcont
2144 return 1
2147 proc find_change {name ix op} {
2148 global nhighlights mainfont boldnamerows
2149 global findstring findpattern findtype markingmatches
2151 # delete previous highlights, if any
2152 foreach row $boldnamerows {
2153 bolden_name $row $mainfont
2155 set boldnamerows {}
2156 catch {unset nhighlights}
2157 unbolden
2158 unmarkmatches
2159 if {$findtype ne "Regexp"} {
2160 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2161 $findstring]
2162 set findpattern "*$e*"
2164 set markingmatches [expr {$findstring ne {}}]
2165 drawvisible
2168 proc doesmatch {f} {
2169 global findtype findstring findpattern
2171 if {$findtype eq "Regexp"} {
2172 return [regexp $findstring $f]
2173 } elseif {$findtype eq "IgnCase"} {
2174 return [string match -nocase $findpattern $f]
2175 } else {
2176 return [string match $findpattern $f]
2180 proc askfindhighlight {row id} {
2181 global nhighlights commitinfo iddrawn mainfont
2182 global findloc
2183 global markingmatches
2185 if {![info exists commitinfo($id)]} {
2186 getcommit $id
2188 set info $commitinfo($id)
2189 set isbold 0
2190 set fldtypes {Headline Author Date Committer CDate Comments}
2191 foreach f $info ty $fldtypes {
2192 if {($findloc eq "All fields" || $findloc eq $ty) &&
2193 [doesmatch $f]} {
2194 if {$ty eq "Author"} {
2195 set isbold 2
2196 break
2198 set isbold 1
2201 if {$isbold && [info exists iddrawn($id)]} {
2202 set f [concat $mainfont bold]
2203 if {![ishighlighted $row]} {
2204 bolden $row $f
2205 if {$isbold > 1} {
2206 bolden_name $row $f
2209 if {$markingmatches} {
2210 markrowmatches $row [lindex $info 0] [lindex $info 1]
2213 set nhighlights($row) $isbold
2216 proc markrowmatches {row headline author} {
2217 global canv canv2 linehtag linentag
2219 $canv delete match$row
2220 $canv2 delete match$row
2221 set m [findmatches $headline]
2222 if {$m ne {}} {
2223 markmatches $canv $row $headline $linehtag($row) $m \
2224 [$canv itemcget $linehtag($row) -font]
2226 set m [findmatches $author]
2227 if {$m ne {}} {
2228 markmatches $canv2 $row $author $linentag($row) $m \
2229 [$canv2 itemcget $linentag($row) -font]
2233 proc vrel_change {name ix op} {
2234 global highlight_related
2236 rhighlight_none
2237 if {$highlight_related ne "None"} {
2238 run drawvisible
2242 # prepare for testing whether commits are descendents or ancestors of a
2243 proc rhighlight_sel {a} {
2244 global descendent desc_todo ancestor anc_todo
2245 global highlight_related rhighlights
2247 catch {unset descendent}
2248 set desc_todo [list $a]
2249 catch {unset ancestor}
2250 set anc_todo [list $a]
2251 if {$highlight_related ne "None"} {
2252 rhighlight_none
2253 run drawvisible
2257 proc rhighlight_none {} {
2258 global rhighlights
2260 catch {unset rhighlights}
2261 unbolden
2264 proc is_descendent {a} {
2265 global curview children commitrow descendent desc_todo
2267 set v $curview
2268 set la $commitrow($v,$a)
2269 set todo $desc_todo
2270 set leftover {}
2271 set done 0
2272 for {set i 0} {$i < [llength $todo]} {incr i} {
2273 set do [lindex $todo $i]
2274 if {$commitrow($v,$do) < $la} {
2275 lappend leftover $do
2276 continue
2278 foreach nk $children($v,$do) {
2279 if {![info exists descendent($nk)]} {
2280 set descendent($nk) 1
2281 lappend todo $nk
2282 if {$nk eq $a} {
2283 set done 1
2287 if {$done} {
2288 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2289 return
2292 set descendent($a) 0
2293 set desc_todo $leftover
2296 proc is_ancestor {a} {
2297 global curview parentlist commitrow ancestor anc_todo
2299 set v $curview
2300 set la $commitrow($v,$a)
2301 set todo $anc_todo
2302 set leftover {}
2303 set done 0
2304 for {set i 0} {$i < [llength $todo]} {incr i} {
2305 set do [lindex $todo $i]
2306 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2307 lappend leftover $do
2308 continue
2310 foreach np [lindex $parentlist $commitrow($v,$do)] {
2311 if {![info exists ancestor($np)]} {
2312 set ancestor($np) 1
2313 lappend todo $np
2314 if {$np eq $a} {
2315 set done 1
2319 if {$done} {
2320 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2321 return
2324 set ancestor($a) 0
2325 set anc_todo $leftover
2328 proc askrelhighlight {row id} {
2329 global descendent highlight_related iddrawn mainfont rhighlights
2330 global selectedline ancestor
2332 if {![info exists selectedline]} return
2333 set isbold 0
2334 if {$highlight_related eq "Descendent" ||
2335 $highlight_related eq "Not descendent"} {
2336 if {![info exists descendent($id)]} {
2337 is_descendent $id
2339 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2340 set isbold 1
2342 } elseif {$highlight_related eq "Ancestor" ||
2343 $highlight_related eq "Not ancestor"} {
2344 if {![info exists ancestor($id)]} {
2345 is_ancestor $id
2347 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2348 set isbold 1
2351 if {[info exists iddrawn($id)]} {
2352 if {$isbold && ![ishighlighted $row]} {
2353 bolden $row [concat $mainfont bold]
2356 set rhighlights($row) $isbold
2359 proc next_hlcont {} {
2360 global fhl_row fhl_dirn displayorder numcommits
2361 global vhighlights fhighlights nhighlights rhighlights
2362 global hlview filehighlight findstring highlight_related
2364 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2365 set row $fhl_row
2366 while {1} {
2367 if {$row < 0 || $row >= $numcommits} {
2368 bell
2369 set fhl_dirn 0
2370 return
2372 set id [lindex $displayorder $row]
2373 if {[info exists hlview]} {
2374 if {![info exists vhighlights($row)]} {
2375 askvhighlight $row $id
2377 if {$vhighlights($row) > 0} break
2379 if {$findstring ne {}} {
2380 if {![info exists nhighlights($row)]} {
2381 askfindhighlight $row $id
2383 if {$nhighlights($row) > 0} break
2385 if {$highlight_related ne "None"} {
2386 if {![info exists rhighlights($row)]} {
2387 askrelhighlight $row $id
2389 if {$rhighlights($row) > 0} break
2391 if {[info exists filehighlight]} {
2392 if {![info exists fhighlights($row)]} {
2393 # ask for a few more while we're at it...
2394 set r $row
2395 for {set n 0} {$n < 100} {incr n} {
2396 if {![info exists fhighlights($r)]} {
2397 askfilehighlight $r [lindex $displayorder $r]
2399 incr r $fhl_dirn
2400 if {$r < 0 || $r >= $numcommits} break
2402 flushhighlights
2404 if {$fhighlights($row) < 0} {
2405 set fhl_row $row
2406 return
2408 if {$fhighlights($row) > 0} break
2410 incr row $fhl_dirn
2412 set fhl_dirn 0
2413 selectline $row 1
2416 proc next_highlight {dirn} {
2417 global selectedline fhl_row fhl_dirn
2418 global hlview filehighlight findstring highlight_related
2420 if {![info exists selectedline]} return
2421 if {!([info exists hlview] || $findstring ne {} ||
2422 $highlight_related ne "None" || [info exists filehighlight])} return
2423 set fhl_row [expr {$selectedline + $dirn}]
2424 set fhl_dirn $dirn
2425 next_hlcont
2428 proc cancel_next_highlight {} {
2429 global fhl_dirn
2431 set fhl_dirn 0
2434 # Graph layout functions
2436 proc shortids {ids} {
2437 set res {}
2438 foreach id $ids {
2439 if {[llength $id] > 1} {
2440 lappend res [shortids $id]
2441 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2442 lappend res [string range $id 0 7]
2443 } else {
2444 lappend res $id
2447 return $res
2450 proc incrange {l x o} {
2451 set n [llength $l]
2452 while {$x < $n} {
2453 set e [lindex $l $x]
2454 if {$e ne {}} {
2455 lset l $x [expr {$e + $o}]
2457 incr x
2459 return $l
2462 proc ntimes {n o} {
2463 set ret {}
2464 for {} {$n > 0} {incr n -1} {
2465 lappend ret $o
2467 return $ret
2470 proc usedinrange {id l1 l2} {
2471 global children commitrow curview
2473 if {[info exists commitrow($curview,$id)]} {
2474 set r $commitrow($curview,$id)
2475 if {$l1 <= $r && $r <= $l2} {
2476 return [expr {$r - $l1 + 1}]
2479 set kids $children($curview,$id)
2480 foreach c $kids {
2481 set r $commitrow($curview,$c)
2482 if {$l1 <= $r && $r <= $l2} {
2483 return [expr {$r - $l1 + 1}]
2486 return 0
2489 proc sanity {row {full 0}} {
2490 global rowidlist rowoffsets
2492 set col -1
2493 set ids [lindex $rowidlist $row]
2494 foreach id $ids {
2495 incr col
2496 if {$id eq {}} continue
2497 if {$col < [llength $ids] - 1 &&
2498 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2499 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2501 set o [lindex $rowoffsets $row $col]
2502 set y $row
2503 set x $col
2504 while {$o ne {}} {
2505 incr y -1
2506 incr x $o
2507 if {[lindex $rowidlist $y $x] != $id} {
2508 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2509 puts " id=[shortids $id] check started at row $row"
2510 for {set i $row} {$i >= $y} {incr i -1} {
2511 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2513 break
2515 if {!$full} break
2516 set o [lindex $rowoffsets $y $x]
2521 proc makeuparrow {oid x y z} {
2522 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2524 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2525 incr y -1
2526 incr x $z
2527 set off0 [lindex $rowoffsets $y]
2528 for {set x0 $x} {1} {incr x0} {
2529 if {$x0 >= [llength $off0]} {
2530 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2531 break
2533 set z [lindex $off0 $x0]
2534 if {$z ne {}} {
2535 incr x0 $z
2536 break
2539 set z [expr {$x0 - $x}]
2540 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2541 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2543 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2544 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2545 lappend idrowranges($oid) [lindex $displayorder $y]
2548 proc initlayout {} {
2549 global rowidlist rowoffsets displayorder commitlisted
2550 global rowlaidout rowoptim
2551 global idinlist rowchk rowrangelist idrowranges
2552 global numcommits canvxmax canv
2553 global nextcolor
2554 global parentlist
2555 global colormap rowtextx
2556 global selectfirst
2558 set numcommits 0
2559 set displayorder {}
2560 set commitlisted {}
2561 set parentlist {}
2562 set rowrangelist {}
2563 set nextcolor 0
2564 set rowidlist {{}}
2565 set rowoffsets {{}}
2566 catch {unset idinlist}
2567 catch {unset rowchk}
2568 set rowlaidout 0
2569 set rowoptim 0
2570 set canvxmax [$canv cget -width]
2571 catch {unset colormap}
2572 catch {unset rowtextx}
2573 catch {unset idrowranges}
2574 set selectfirst 1
2577 proc setcanvscroll {} {
2578 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2580 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2581 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2582 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2583 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2586 proc visiblerows {} {
2587 global canv numcommits linespc
2589 set ymax [lindex [$canv cget -scrollregion] 3]
2590 if {$ymax eq {} || $ymax == 0} return
2591 set f [$canv yview]
2592 set y0 [expr {int([lindex $f 0] * $ymax)}]
2593 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2594 if {$r0 < 0} {
2595 set r0 0
2597 set y1 [expr {int([lindex $f 1] * $ymax)}]
2598 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2599 if {$r1 >= $numcommits} {
2600 set r1 [expr {$numcommits - 1}]
2602 return [list $r0 $r1]
2605 proc layoutmore {tmax allread} {
2606 global rowlaidout rowoptim commitidx numcommits optim_delay
2607 global uparrowlen curview rowidlist idinlist
2609 set showlast 0
2610 set showdelay $optim_delay
2611 set optdelay [expr {$uparrowlen + 1}]
2612 while {1} {
2613 if {$rowoptim - $showdelay > $numcommits} {
2614 showstuff [expr {$rowoptim - $showdelay}] $showlast
2615 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2616 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2617 if {$nr > 100} {
2618 set nr 100
2620 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2621 incr rowoptim $nr
2622 } elseif {$commitidx($curview) > $rowlaidout} {
2623 set nr [expr {$commitidx($curview) - $rowlaidout}]
2624 # may need to increase this threshold if uparrowlen or
2625 # mingaplen are increased...
2626 if {$nr > 150} {
2627 set nr 150
2629 set row $rowlaidout
2630 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2631 if {$rowlaidout == $row} {
2632 return 0
2634 } elseif {$allread} {
2635 set optdelay 0
2636 set nrows $commitidx($curview)
2637 if {[lindex $rowidlist $nrows] ne {} ||
2638 [array names idinlist] ne {}} {
2639 layouttail
2640 set rowlaidout $commitidx($curview)
2641 } elseif {$rowoptim == $nrows} {
2642 set showdelay 0
2643 set showlast 1
2644 if {$numcommits == $nrows} {
2645 return 0
2648 } else {
2649 return 0
2651 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2652 return 1
2657 proc showstuff {canshow last} {
2658 global numcommits commitrow pending_select selectedline curview
2659 global lookingforhead mainheadid displayorder selectfirst
2660 global lastscrollset
2662 if {$numcommits == 0} {
2663 global phase
2664 set phase "incrdraw"
2665 allcanvs delete all
2667 set r0 $numcommits
2668 set prev $numcommits
2669 set numcommits $canshow
2670 set t [clock clicks -milliseconds]
2671 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2672 set lastscrollset $t
2673 setcanvscroll
2675 set rows [visiblerows]
2676 set r1 [lindex $rows 1]
2677 if {$r1 >= $canshow} {
2678 set r1 [expr {$canshow - 1}]
2680 if {$r0 <= $r1} {
2681 drawcommits $r0 $r1
2683 if {[info exists pending_select] &&
2684 [info exists commitrow($curview,$pending_select)] &&
2685 $commitrow($curview,$pending_select) < $numcommits} {
2686 selectline $commitrow($curview,$pending_select) 1
2688 if {$selectfirst} {
2689 if {[info exists selectedline] || [info exists pending_select]} {
2690 set selectfirst 0
2691 } else {
2692 set l [first_real_row]
2693 selectline $l 1
2694 set selectfirst 0
2697 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2698 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2699 set lookingforhead 0
2700 dodiffindex
2704 proc doshowlocalchanges {} {
2705 global lookingforhead curview mainheadid phase commitrow
2707 if {[info exists commitrow($curview,$mainheadid)] &&
2708 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2709 dodiffindex
2710 } elseif {$phase ne {}} {
2711 set lookingforhead 1
2715 proc dohidelocalchanges {} {
2716 global lookingforhead localfrow localirow lserial
2718 set lookingforhead 0
2719 if {$localfrow >= 0} {
2720 removerow $localfrow
2721 set localfrow -1
2722 if {$localirow > 0} {
2723 incr localirow -1
2726 if {$localirow >= 0} {
2727 removerow $localirow
2728 set localirow -1
2730 incr lserial
2733 # spawn off a process to do git diff-index --cached HEAD
2734 proc dodiffindex {} {
2735 global localirow localfrow lserial
2737 incr lserial
2738 set localfrow -1
2739 set localirow -1
2740 set fd [open "|git diff-index --cached HEAD" r]
2741 fconfigure $fd -blocking 0
2742 filerun $fd [list readdiffindex $fd $lserial]
2745 proc readdiffindex {fd serial} {
2746 global localirow commitrow mainheadid nullid2 curview
2747 global commitinfo commitdata lserial
2749 set isdiff 1
2750 if {[gets $fd line] < 0} {
2751 if {![eof $fd]} {
2752 return 1
2754 set isdiff 0
2756 # we only need to see one line and we don't really care what it says...
2757 close $fd
2759 # now see if there are any local changes not checked in to the index
2760 if {$serial == $lserial} {
2761 set fd [open "|git diff-files" r]
2762 fconfigure $fd -blocking 0
2763 filerun $fd [list readdifffiles $fd $serial]
2766 if {$isdiff && $serial == $lserial && $localirow == -1} {
2767 # add the line for the changes in the index to the graph
2768 set localirow $commitrow($curview,$mainheadid)
2769 set hl "Local changes checked in to index but not committed"
2770 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2771 set commitdata($nullid2) "\n $hl\n"
2772 insertrow $localirow $nullid2
2774 return 0
2777 proc readdifffiles {fd serial} {
2778 global localirow localfrow commitrow mainheadid nullid curview
2779 global commitinfo commitdata lserial
2781 set isdiff 1
2782 if {[gets $fd line] < 0} {
2783 if {![eof $fd]} {
2784 return 1
2786 set isdiff 0
2788 # we only need to see one line and we don't really care what it says...
2789 close $fd
2791 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2792 # add the line for the local diff to the graph
2793 if {$localirow >= 0} {
2794 set localfrow $localirow
2795 incr localirow
2796 } else {
2797 set localfrow $commitrow($curview,$mainheadid)
2799 set hl "Local uncommitted changes, not checked in to index"
2800 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2801 set commitdata($nullid) "\n $hl\n"
2802 insertrow $localfrow $nullid
2804 return 0
2807 proc layoutrows {row endrow last} {
2808 global rowidlist rowoffsets displayorder
2809 global uparrowlen downarrowlen maxwidth mingaplen
2810 global children parentlist
2811 global idrowranges
2812 global commitidx curview
2813 global idinlist rowchk rowrangelist
2815 set idlist [lindex $rowidlist $row]
2816 set offs [lindex $rowoffsets $row]
2817 while {$row < $endrow} {
2818 set id [lindex $displayorder $row]
2819 set oldolds {}
2820 set newolds {}
2821 foreach p [lindex $parentlist $row] {
2822 if {![info exists idinlist($p)]} {
2823 lappend newolds $p
2824 } elseif {!$idinlist($p)} {
2825 lappend oldolds $p
2828 set nev [expr {[llength $idlist] + [llength $newolds]
2829 + [llength $oldolds] - $maxwidth + 1}]
2830 if {$nev > 0} {
2831 if {!$last &&
2832 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2833 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2834 set i [lindex $idlist $x]
2835 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2836 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2837 [expr {$row + $uparrowlen + $mingaplen}]]
2838 if {$r == 0} {
2839 set idlist [lreplace $idlist $x $x]
2840 set offs [lreplace $offs $x $x]
2841 set offs [incrange $offs $x 1]
2842 set idinlist($i) 0
2843 set rm1 [expr {$row - 1}]
2844 lappend idrowranges($i) [lindex $displayorder $rm1]
2845 if {[incr nev -1] <= 0} break
2846 continue
2848 set rowchk($id) [expr {$row + $r}]
2851 lset rowidlist $row $idlist
2852 lset rowoffsets $row $offs
2854 set col [lsearch -exact $idlist $id]
2855 if {$col < 0} {
2856 set col [llength $idlist]
2857 lappend idlist $id
2858 lset rowidlist $row $idlist
2859 set z {}
2860 if {$children($curview,$id) ne {}} {
2861 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2862 unset idinlist($id)
2864 lappend offs $z
2865 lset rowoffsets $row $offs
2866 if {$z ne {}} {
2867 makeuparrow $id $col $row $z
2869 } else {
2870 unset idinlist($id)
2872 set ranges {}
2873 if {[info exists idrowranges($id)]} {
2874 set ranges $idrowranges($id)
2875 lappend ranges $id
2876 unset idrowranges($id)
2878 lappend rowrangelist $ranges
2879 incr row
2880 set offs [ntimes [llength $idlist] 0]
2881 set l [llength $newolds]
2882 set idlist [eval lreplace \$idlist $col $col $newolds]
2883 set o 0
2884 if {$l != 1} {
2885 set offs [lrange $offs 0 [expr {$col - 1}]]
2886 foreach x $newolds {
2887 lappend offs {}
2888 incr o -1
2890 incr o
2891 set tmp [expr {[llength $idlist] - [llength $offs]}]
2892 if {$tmp > 0} {
2893 set offs [concat $offs [ntimes $tmp $o]]
2895 } else {
2896 lset offs $col {}
2898 foreach i $newolds {
2899 set idinlist($i) 1
2900 set idrowranges($i) $id
2902 incr col $l
2903 foreach oid $oldolds {
2904 set idinlist($oid) 1
2905 set idlist [linsert $idlist $col $oid]
2906 set offs [linsert $offs $col $o]
2907 makeuparrow $oid $col $row $o
2908 incr col
2910 lappend rowidlist $idlist
2911 lappend rowoffsets $offs
2913 return $row
2916 proc addextraid {id row} {
2917 global displayorder commitrow commitinfo
2918 global commitidx commitlisted
2919 global parentlist children curview
2921 incr commitidx($curview)
2922 lappend displayorder $id
2923 lappend commitlisted 0
2924 lappend parentlist {}
2925 set commitrow($curview,$id) $row
2926 readcommit $id
2927 if {![info exists commitinfo($id)]} {
2928 set commitinfo($id) {"No commit information available"}
2930 if {![info exists children($curview,$id)]} {
2931 set children($curview,$id) {}
2935 proc layouttail {} {
2936 global rowidlist rowoffsets idinlist commitidx curview
2937 global idrowranges rowrangelist
2939 set row $commitidx($curview)
2940 set idlist [lindex $rowidlist $row]
2941 while {$idlist ne {}} {
2942 set col [expr {[llength $idlist] - 1}]
2943 set id [lindex $idlist $col]
2944 addextraid $id $row
2945 unset idinlist($id)
2946 lappend idrowranges($id) $id
2947 lappend rowrangelist $idrowranges($id)
2948 unset idrowranges($id)
2949 incr row
2950 set offs [ntimes $col 0]
2951 set idlist [lreplace $idlist $col $col]
2952 lappend rowidlist $idlist
2953 lappend rowoffsets $offs
2956 foreach id [array names idinlist] {
2957 unset idinlist($id)
2958 addextraid $id $row
2959 lset rowidlist $row [list $id]
2960 lset rowoffsets $row 0
2961 makeuparrow $id 0 $row 0
2962 lappend idrowranges($id) $id
2963 lappend rowrangelist $idrowranges($id)
2964 unset idrowranges($id)
2965 incr row
2966 lappend rowidlist {}
2967 lappend rowoffsets {}
2971 proc insert_pad {row col npad} {
2972 global rowidlist rowoffsets
2974 set pad [ntimes $npad {}]
2975 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2976 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2977 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2980 proc optimize_rows {row col endrow} {
2981 global rowidlist rowoffsets displayorder
2983 for {} {$row < $endrow} {incr row} {
2984 set idlist [lindex $rowidlist $row]
2985 set offs [lindex $rowoffsets $row]
2986 set haspad 0
2987 for {} {$col < [llength $offs]} {incr col} {
2988 if {[lindex $idlist $col] eq {}} {
2989 set haspad 1
2990 continue
2992 set z [lindex $offs $col]
2993 if {$z eq {}} continue
2994 set isarrow 0
2995 set x0 [expr {$col + $z}]
2996 set y0 [expr {$row - 1}]
2997 set z0 [lindex $rowoffsets $y0 $x0]
2998 if {$z0 eq {}} {
2999 set id [lindex $idlist $col]
3000 set ranges [rowranges $id]
3001 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3002 set isarrow 1
3005 # Looking at lines from this row to the previous row,
3006 # make them go straight up if they end in an arrow on
3007 # the previous row; otherwise make them go straight up
3008 # or at 45 degrees.
3009 if {$z < -1 || ($z < 0 && $isarrow)} {
3010 # Line currently goes left too much;
3011 # insert pads in the previous row, then optimize it
3012 set npad [expr {-1 - $z + $isarrow}]
3013 set offs [incrange $offs $col $npad]
3014 insert_pad $y0 $x0 $npad
3015 if {$y0 > 0} {
3016 optimize_rows $y0 $x0 $row
3018 set z [lindex $offs $col]
3019 set x0 [expr {$col + $z}]
3020 set z0 [lindex $rowoffsets $y0 $x0]
3021 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3022 # Line currently goes right too much;
3023 # insert pads in this line and adjust the next's rowoffsets
3024 set npad [expr {$z - 1 + $isarrow}]
3025 set y1 [expr {$row + 1}]
3026 set offs2 [lindex $rowoffsets $y1]
3027 set x1 -1
3028 foreach z $offs2 {
3029 incr x1
3030 if {$z eq {} || $x1 + $z < $col} continue
3031 if {$x1 + $z > $col} {
3032 incr npad
3034 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3035 break
3037 set pad [ntimes $npad {}]
3038 set idlist [eval linsert \$idlist $col $pad]
3039 set tmp [eval linsert \$offs $col $pad]
3040 incr col $npad
3041 set offs [incrange $tmp $col [expr {-$npad}]]
3042 set z [lindex $offs $col]
3043 set haspad 1
3045 if {$z0 eq {} && !$isarrow} {
3046 # this line links to its first child on row $row-2
3047 set rm2 [expr {$row - 2}]
3048 set id [lindex $displayorder $rm2]
3049 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3050 if {$xc >= 0} {
3051 set z0 [expr {$xc - $x0}]
3054 # avoid lines jigging left then immediately right
3055 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3056 insert_pad $y0 $x0 1
3057 set offs [incrange $offs $col 1]
3058 optimize_rows $y0 [expr {$x0 + 1}] $row
3061 if {!$haspad} {
3062 set o {}
3063 # Find the first column that doesn't have a line going right
3064 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3065 set o [lindex $offs $col]
3066 if {$o eq {}} {
3067 # check if this is the link to the first child
3068 set id [lindex $idlist $col]
3069 set ranges [rowranges $id]
3070 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3071 # it is, work out offset to child
3072 set y0 [expr {$row - 1}]
3073 set id [lindex $displayorder $y0]
3074 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3075 if {$x0 >= 0} {
3076 set o [expr {$x0 - $col}]
3080 if {$o eq {} || $o <= 0} break
3082 # Insert a pad at that column as long as it has a line and
3083 # isn't the last column, and adjust the next row' offsets
3084 if {$o ne {} && [incr col] < [llength $idlist]} {
3085 set y1 [expr {$row + 1}]
3086 set offs2 [lindex $rowoffsets $y1]
3087 set x1 -1
3088 foreach z $offs2 {
3089 incr x1
3090 if {$z eq {} || $x1 + $z < $col} continue
3091 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3092 break
3094 set idlist [linsert $idlist $col {}]
3095 set tmp [linsert $offs $col {}]
3096 incr col
3097 set offs [incrange $tmp $col -1]
3100 lset rowidlist $row $idlist
3101 lset rowoffsets $row $offs
3102 set col 0
3106 proc xc {row col} {
3107 global canvx0 linespc
3108 return [expr {$canvx0 + $col * $linespc}]
3111 proc yc {row} {
3112 global canvy0 linespc
3113 return [expr {$canvy0 + $row * $linespc}]
3116 proc linewidth {id} {
3117 global thickerline lthickness
3119 set wid $lthickness
3120 if {[info exists thickerline] && $id eq $thickerline} {
3121 set wid [expr {2 * $lthickness}]
3123 return $wid
3126 proc rowranges {id} {
3127 global phase idrowranges commitrow rowlaidout rowrangelist curview
3129 set ranges {}
3130 if {$phase eq {} ||
3131 ([info exists commitrow($curview,$id)]
3132 && $commitrow($curview,$id) < $rowlaidout)} {
3133 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3134 } elseif {[info exists idrowranges($id)]} {
3135 set ranges $idrowranges($id)
3137 set linenos {}
3138 foreach rid $ranges {
3139 lappend linenos $commitrow($curview,$rid)
3141 if {$linenos ne {}} {
3142 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3144 return $linenos
3147 # work around tk8.4 refusal to draw arrows on diagonal segments
3148 proc adjarrowhigh {coords} {
3149 global linespc
3151 set x0 [lindex $coords 0]
3152 set x1 [lindex $coords 2]
3153 if {$x0 != $x1} {
3154 set y0 [lindex $coords 1]
3155 set y1 [lindex $coords 3]
3156 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3157 # we have a nearby vertical segment, just trim off the diag bit
3158 set coords [lrange $coords 2 end]
3159 } else {
3160 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3161 set xi [expr {$x0 - $slope * $linespc / 2}]
3162 set yi [expr {$y0 - $linespc / 2}]
3163 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3166 return $coords
3169 proc drawlineseg {id row endrow arrowlow} {
3170 global rowidlist displayorder iddrawn linesegs
3171 global canv colormap linespc curview maxlinelen
3173 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3174 set le [expr {$row + 1}]
3175 set arrowhigh 1
3176 while {1} {
3177 set c [lsearch -exact [lindex $rowidlist $le] $id]
3178 if {$c < 0} {
3179 incr le -1
3180 break
3182 lappend cols $c
3183 set x [lindex $displayorder $le]
3184 if {$x eq $id} {
3185 set arrowhigh 0
3186 break
3188 if {[info exists iddrawn($x)] || $le == $endrow} {
3189 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3190 if {$c >= 0} {
3191 lappend cols $c
3192 set arrowhigh 0
3194 break
3196 incr le
3198 if {$le <= $row} {
3199 return $row
3202 set lines {}
3203 set i 0
3204 set joinhigh 0
3205 if {[info exists linesegs($id)]} {
3206 set lines $linesegs($id)
3207 foreach li $lines {
3208 set r0 [lindex $li 0]
3209 if {$r0 > $row} {
3210 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3211 set joinhigh 1
3213 break
3215 incr i
3218 set joinlow 0
3219 if {$i > 0} {
3220 set li [lindex $lines [expr {$i-1}]]
3221 set r1 [lindex $li 1]
3222 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3223 set joinlow 1
3227 set x [lindex $cols [expr {$le - $row}]]
3228 set xp [lindex $cols [expr {$le - 1 - $row}]]
3229 set dir [expr {$xp - $x}]
3230 if {$joinhigh} {
3231 set ith [lindex $lines $i 2]
3232 set coords [$canv coords $ith]
3233 set ah [$canv itemcget $ith -arrow]
3234 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3235 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3236 if {$x2 ne {} && $x - $x2 == $dir} {
3237 set coords [lrange $coords 0 end-2]
3239 } else {
3240 set coords [list [xc $le $x] [yc $le]]
3242 if {$joinlow} {
3243 set itl [lindex $lines [expr {$i-1}] 2]
3244 set al [$canv itemcget $itl -arrow]
3245 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3246 } elseif {$arrowlow &&
3247 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3248 set arrowlow 0
3250 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3251 for {set y $le} {[incr y -1] > $row} {} {
3252 set x $xp
3253 set xp [lindex $cols [expr {$y - 1 - $row}]]
3254 set ndir [expr {$xp - $x}]
3255 if {$dir != $ndir || $xp < 0} {
3256 lappend coords [xc $y $x] [yc $y]
3258 set dir $ndir
3260 if {!$joinlow} {
3261 if {$xp < 0} {
3262 # join parent line to first child
3263 set ch [lindex $displayorder $row]
3264 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3265 if {$xc < 0} {
3266 puts "oops: drawlineseg: child $ch not on row $row"
3267 } else {
3268 if {$xc < $x - 1} {
3269 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3270 } elseif {$xc > $x + 1} {
3271 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3273 set x $xc
3275 lappend coords [xc $row $x] [yc $row]
3276 } else {
3277 set xn [xc $row $xp]
3278 set yn [yc $row]
3279 # work around tk8.4 refusal to draw arrows on diagonal segments
3280 if {$arrowlow && $xn != [lindex $coords end-1]} {
3281 if {[llength $coords] < 4 ||
3282 [lindex $coords end-3] != [lindex $coords end-1] ||
3283 [lindex $coords end] - $yn > 2 * $linespc} {
3284 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3285 set yo [yc [expr {$row + 0.5}]]
3286 lappend coords $xn $yo $xn $yn
3288 } else {
3289 lappend coords $xn $yn
3292 if {!$joinhigh} {
3293 if {$arrowhigh} {
3294 set coords [adjarrowhigh $coords]
3296 assigncolor $id
3297 set t [$canv create line $coords -width [linewidth $id] \
3298 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3299 $canv lower $t
3300 bindline $t $id
3301 set lines [linsert $lines $i [list $row $le $t]]
3302 } else {
3303 $canv coords $ith $coords
3304 if {$arrow ne $ah} {
3305 $canv itemconf $ith -arrow $arrow
3307 lset lines $i 0 $row
3309 } else {
3310 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3311 set ndir [expr {$xo - $xp}]
3312 set clow [$canv coords $itl]
3313 if {$dir == $ndir} {
3314 set clow [lrange $clow 2 end]
3316 set coords [concat $coords $clow]
3317 if {!$joinhigh} {
3318 lset lines [expr {$i-1}] 1 $le
3319 if {$arrowhigh} {
3320 set coords [adjarrowhigh $coords]
3322 } else {
3323 # coalesce two pieces
3324 $canv delete $ith
3325 set b [lindex $lines [expr {$i-1}] 0]
3326 set e [lindex $lines $i 1]
3327 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3329 $canv coords $itl $coords
3330 if {$arrow ne $al} {
3331 $canv itemconf $itl -arrow $arrow
3335 set linesegs($id) $lines
3336 return $le
3339 proc drawparentlinks {id row} {
3340 global rowidlist canv colormap curview parentlist
3341 global idpos
3343 set rowids [lindex $rowidlist $row]
3344 set col [lsearch -exact $rowids $id]
3345 if {$col < 0} return
3346 set olds [lindex $parentlist $row]
3347 set row2 [expr {$row + 1}]
3348 set x [xc $row $col]
3349 set y [yc $row]
3350 set y2 [yc $row2]
3351 set ids [lindex $rowidlist $row2]
3352 # rmx = right-most X coord used
3353 set rmx 0
3354 foreach p $olds {
3355 set i [lsearch -exact $ids $p]
3356 if {$i < 0} {
3357 puts "oops, parent $p of $id not in list"
3358 continue
3360 set x2 [xc $row2 $i]
3361 if {$x2 > $rmx} {
3362 set rmx $x2
3364 if {[lsearch -exact $rowids $p] < 0} {
3365 # drawlineseg will do this one for us
3366 continue
3368 assigncolor $p
3369 # should handle duplicated parents here...
3370 set coords [list $x $y]
3371 if {$i < $col - 1} {
3372 lappend coords [xc $row [expr {$i + 1}]] $y
3373 } elseif {$i > $col + 1} {
3374 lappend coords [xc $row [expr {$i - 1}]] $y
3376 lappend coords $x2 $y2
3377 set t [$canv create line $coords -width [linewidth $p] \
3378 -fill $colormap($p) -tags lines.$p]
3379 $canv lower $t
3380 bindline $t $p
3382 if {$rmx > [lindex $idpos($id) 1]} {
3383 lset idpos($id) 1 $rmx
3384 redrawtags $id
3388 proc drawlines {id} {
3389 global canv
3391 $canv itemconf lines.$id -width [linewidth $id]
3394 proc drawcmittext {id row col} {
3395 global linespc canv canv2 canv3 canvy0 fgcolor curview
3396 global commitlisted commitinfo rowidlist parentlist
3397 global rowtextx idpos idtags idheads idotherrefs
3398 global linehtag linentag linedtag markingmatches
3399 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3401 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3402 set listed [lindex $commitlisted $row]
3403 if {$id eq $nullid} {
3404 set ofill red
3405 } elseif {$id eq $nullid2} {
3406 set ofill green
3407 } else {
3408 set ofill [expr {$listed != 0? "blue": "white"}]
3410 set x [xc $row $col]
3411 set y [yc $row]
3412 set orad [expr {$linespc / 3}]
3413 if {$listed <= 1} {
3414 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3415 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3416 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3417 } elseif {$listed == 2} {
3418 # triangle pointing left for left-side commits
3419 set t [$canv create polygon \
3420 [expr {$x - $orad}] $y \
3421 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3422 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3423 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3424 } else {
3425 # triangle pointing right for right-side commits
3426 set t [$canv create polygon \
3427 [expr {$x + $orad - 1}] $y \
3428 [expr {$x - $orad}] [expr {$y - $orad}] \
3429 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3430 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3432 $canv raise $t
3433 $canv bind $t <1> {selcanvline {} %x %y}
3434 set rmx [llength [lindex $rowidlist $row]]
3435 set olds [lindex $parentlist $row]
3436 if {$olds ne {}} {
3437 set nextids [lindex $rowidlist [expr {$row + 1}]]
3438 foreach p $olds {
3439 set i [lsearch -exact $nextids $p]
3440 if {$i > $rmx} {
3441 set rmx $i
3445 set xt [xc $row $rmx]
3446 set rowtextx($row) $xt
3447 set idpos($id) [list $x $xt $y]
3448 if {[info exists idtags($id)] || [info exists idheads($id)]
3449 || [info exists idotherrefs($id)]} {
3450 set xt [drawtags $id $x $xt $y]
3452 set headline [lindex $commitinfo($id) 0]
3453 set name [lindex $commitinfo($id) 1]
3454 set date [lindex $commitinfo($id) 2]
3455 set date [formatdate $date]
3456 set font $mainfont
3457 set nfont $mainfont
3458 set isbold [ishighlighted $row]
3459 if {$isbold > 0} {
3460 lappend boldrows $row
3461 lappend font bold
3462 if {$isbold > 1} {
3463 lappend boldnamerows $row
3464 lappend nfont bold
3467 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3468 -text $headline -font $font -tags text]
3469 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3470 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3471 -text $name -font $nfont -tags text]
3472 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3473 -text $date -font $mainfont -tags text]
3474 set xr [expr {$xt + [font measure $mainfont $headline]}]
3475 if {$markingmatches} {
3476 markrowmatches $row $headline $name
3478 if {$xr > $canvxmax} {
3479 set canvxmax $xr
3480 setcanvscroll
3484 proc drawcmitrow {row} {
3485 global displayorder rowidlist
3486 global iddrawn
3487 global commitinfo parentlist numcommits
3488 global filehighlight fhighlights findstring nhighlights
3489 global hlview vhighlights
3490 global highlight_related rhighlights
3492 if {$row >= $numcommits} return
3494 set id [lindex $displayorder $row]
3495 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3496 askvhighlight $row $id
3498 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3499 askfilehighlight $row $id
3501 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3502 askfindhighlight $row $id
3504 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3505 askrelhighlight $row $id
3507 if {[info exists iddrawn($id)]} return
3508 set col [lsearch -exact [lindex $rowidlist $row] $id]
3509 if {$col < 0} {
3510 puts "oops, row $row id $id not in list"
3511 return
3513 if {![info exists commitinfo($id)]} {
3514 getcommit $id
3516 assigncolor $id
3517 drawcmittext $id $row $col
3518 set iddrawn($id) 1
3521 proc drawcommits {row {endrow {}}} {
3522 global numcommits iddrawn displayorder curview
3523 global parentlist rowidlist
3525 if {$row < 0} {
3526 set row 0
3528 if {$endrow eq {}} {
3529 set endrow $row
3531 if {$endrow >= $numcommits} {
3532 set endrow [expr {$numcommits - 1}]
3535 # make the lines join to already-drawn rows either side
3536 set r [expr {$row - 1}]
3537 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3538 set r $row
3540 set er [expr {$endrow + 1}]
3541 if {$er >= $numcommits ||
3542 ![info exists iddrawn([lindex $displayorder $er])]} {
3543 set er $endrow
3545 for {} {$r <= $er} {incr r} {
3546 set id [lindex $displayorder $r]
3547 set wasdrawn [info exists iddrawn($id)]
3548 drawcmitrow $r
3549 if {$r == $er} break
3550 set nextid [lindex $displayorder [expr {$r + 1}]]
3551 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3552 catch {unset prevlines}
3553 continue
3555 drawparentlinks $id $r
3557 if {[info exists lineends($r)]} {
3558 foreach lid $lineends($r) {
3559 unset prevlines($lid)
3562 set rowids [lindex $rowidlist $r]
3563 foreach lid $rowids {
3564 if {$lid eq {}} continue
3565 if {$lid eq $id} {
3566 # see if this is the first child of any of its parents
3567 foreach p [lindex $parentlist $r] {
3568 if {[lsearch -exact $rowids $p] < 0} {
3569 # make this line extend up to the child
3570 set le [drawlineseg $p $r $er 0]
3571 lappend lineends($le) $p
3572 set prevlines($p) 1
3575 } elseif {![info exists prevlines($lid)]} {
3576 set le [drawlineseg $lid $r $er 1]
3577 lappend lineends($le) $lid
3578 set prevlines($lid) 1
3584 proc drawfrac {f0 f1} {
3585 global canv linespc
3587 set ymax [lindex [$canv cget -scrollregion] 3]
3588 if {$ymax eq {} || $ymax == 0} return
3589 set y0 [expr {int($f0 * $ymax)}]
3590 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3591 set y1 [expr {int($f1 * $ymax)}]
3592 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3593 drawcommits $row $endrow
3596 proc drawvisible {} {
3597 global canv
3598 eval drawfrac [$canv yview]
3601 proc clear_display {} {
3602 global iddrawn linesegs
3603 global vhighlights fhighlights nhighlights rhighlights
3605 allcanvs delete all
3606 catch {unset iddrawn}
3607 catch {unset linesegs}
3608 catch {unset vhighlights}
3609 catch {unset fhighlights}
3610 catch {unset nhighlights}
3611 catch {unset rhighlights}
3614 proc findcrossings {id} {
3615 global rowidlist parentlist numcommits rowoffsets displayorder
3617 set cross {}
3618 set ccross {}
3619 foreach {s e} [rowranges $id] {
3620 if {$e >= $numcommits} {
3621 set e [expr {$numcommits - 1}]
3623 if {$e <= $s} continue
3624 set x [lsearch -exact [lindex $rowidlist $e] $id]
3625 if {$x < 0} {
3626 puts "findcrossings: oops, no [shortids $id] in row $e"
3627 continue
3629 for {set row $e} {[incr row -1] >= $s} {} {
3630 set olds [lindex $parentlist $row]
3631 set kid [lindex $displayorder $row]
3632 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3633 if {$kidx < 0} continue
3634 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3635 foreach p $olds {
3636 set px [lsearch -exact $nextrow $p]
3637 if {$px < 0} continue
3638 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3639 if {[lsearch -exact $ccross $p] >= 0} continue
3640 if {$x == $px + ($kidx < $px? -1: 1)} {
3641 lappend ccross $p
3642 } elseif {[lsearch -exact $cross $p] < 0} {
3643 lappend cross $p
3647 set inc [lindex $rowoffsets $row $x]
3648 if {$inc eq {}} break
3649 incr x $inc
3652 return [concat $ccross {{}} $cross]
3655 proc assigncolor {id} {
3656 global colormap colors nextcolor
3657 global commitrow parentlist children children curview
3659 if {[info exists colormap($id)]} return
3660 set ncolors [llength $colors]
3661 if {[info exists children($curview,$id)]} {
3662 set kids $children($curview,$id)
3663 } else {
3664 set kids {}
3666 if {[llength $kids] == 1} {
3667 set child [lindex $kids 0]
3668 if {[info exists colormap($child)]
3669 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3670 set colormap($id) $colormap($child)
3671 return
3674 set badcolors {}
3675 set origbad {}
3676 foreach x [findcrossings $id] {
3677 if {$x eq {}} {
3678 # delimiter between corner crossings and other crossings
3679 if {[llength $badcolors] >= $ncolors - 1} break
3680 set origbad $badcolors
3682 if {[info exists colormap($x)]
3683 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3684 lappend badcolors $colormap($x)
3687 if {[llength $badcolors] >= $ncolors} {
3688 set badcolors $origbad
3690 set origbad $badcolors
3691 if {[llength $badcolors] < $ncolors - 1} {
3692 foreach child $kids {
3693 if {[info exists colormap($child)]
3694 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3695 lappend badcolors $colormap($child)
3697 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3698 if {[info exists colormap($p)]
3699 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3700 lappend badcolors $colormap($p)
3704 if {[llength $badcolors] >= $ncolors} {
3705 set badcolors $origbad
3708 for {set i 0} {$i <= $ncolors} {incr i} {
3709 set c [lindex $colors $nextcolor]
3710 if {[incr nextcolor] >= $ncolors} {
3711 set nextcolor 0
3713 if {[lsearch -exact $badcolors $c]} break
3715 set colormap($id) $c
3718 proc bindline {t id} {
3719 global canv
3721 $canv bind $t <Enter> "lineenter %x %y $id"
3722 $canv bind $t <Motion> "linemotion %x %y $id"
3723 $canv bind $t <Leave> "lineleave $id"
3724 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3727 proc drawtags {id x xt y1} {
3728 global idtags idheads idotherrefs mainhead
3729 global linespc lthickness
3730 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3732 set marks {}
3733 set ntags 0
3734 set nheads 0
3735 if {[info exists idtags($id)]} {
3736 set marks $idtags($id)
3737 set ntags [llength $marks]
3739 if {[info exists idheads($id)]} {
3740 set marks [concat $marks $idheads($id)]
3741 set nheads [llength $idheads($id)]
3743 if {[info exists idotherrefs($id)]} {
3744 set marks [concat $marks $idotherrefs($id)]
3746 if {$marks eq {}} {
3747 return $xt
3750 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3751 set yt [expr {$y1 - 0.5 * $linespc}]
3752 set yb [expr {$yt + $linespc - 1}]
3753 set xvals {}
3754 set wvals {}
3755 set i -1
3756 foreach tag $marks {
3757 incr i
3758 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3759 set wid [font measure [concat $mainfont bold] $tag]
3760 } else {
3761 set wid [font measure $mainfont $tag]
3763 lappend xvals $xt
3764 lappend wvals $wid
3765 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3767 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3768 -width $lthickness -fill black -tags tag.$id]
3769 $canv lower $t
3770 foreach tag $marks x $xvals wid $wvals {
3771 set xl [expr {$x + $delta}]
3772 set xr [expr {$x + $delta + $wid + $lthickness}]
3773 set font $mainfont
3774 if {[incr ntags -1] >= 0} {
3775 # draw a tag
3776 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3777 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3778 -width 1 -outline black -fill yellow -tags tag.$id]
3779 $canv bind $t <1> [list showtag $tag 1]
3780 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3781 } else {
3782 # draw a head or other ref
3783 if {[incr nheads -1] >= 0} {
3784 set col green
3785 if {$tag eq $mainhead} {
3786 lappend font bold
3788 } else {
3789 set col "#ddddff"
3791 set xl [expr {$xl - $delta/2}]
3792 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3793 -width 1 -outline black -fill $col -tags tag.$id
3794 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3795 set rwid [font measure $mainfont $remoteprefix]
3796 set xi [expr {$x + 1}]
3797 set yti [expr {$yt + 1}]
3798 set xri [expr {$x + $rwid}]
3799 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3800 -width 0 -fill "#ffddaa" -tags tag.$id
3803 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3804 -font $font -tags [list tag.$id text]]
3805 if {$ntags >= 0} {
3806 $canv bind $t <1> [list showtag $tag 1]
3807 } elseif {$nheads >= 0} {
3808 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3811 return $xt
3814 proc xcoord {i level ln} {
3815 global canvx0 xspc1 xspc2
3817 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3818 if {$i > 0 && $i == $level} {
3819 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3820 } elseif {$i > $level} {
3821 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3823 return $x
3826 proc show_status {msg} {
3827 global canv mainfont fgcolor
3829 clear_display
3830 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3831 -tags text -fill $fgcolor
3834 # Insert a new commit as the child of the commit on row $row.
3835 # The new commit will be displayed on row $row and the commits
3836 # on that row and below will move down one row.
3837 proc insertrow {row newcmit} {
3838 global displayorder parentlist commitlisted children
3839 global commitrow curview rowidlist rowoffsets numcommits
3840 global rowrangelist rowlaidout rowoptim numcommits
3841 global selectedline rowchk commitidx
3843 if {$row >= $numcommits} {
3844 puts "oops, inserting new row $row but only have $numcommits rows"
3845 return
3847 set p [lindex $displayorder $row]
3848 set displayorder [linsert $displayorder $row $newcmit]
3849 set parentlist [linsert $parentlist $row $p]
3850 set kids $children($curview,$p)
3851 lappend kids $newcmit
3852 set children($curview,$p) $kids
3853 set children($curview,$newcmit) {}
3854 set commitlisted [linsert $commitlisted $row 1]
3855 set l [llength $displayorder]
3856 for {set r $row} {$r < $l} {incr r} {
3857 set id [lindex $displayorder $r]
3858 set commitrow($curview,$id) $r
3860 incr commitidx($curview)
3862 set idlist [lindex $rowidlist $row]
3863 set offs [lindex $rowoffsets $row]
3864 set newoffs {}
3865 foreach x $idlist {
3866 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3867 lappend newoffs {}
3868 } else {
3869 lappend newoffs 0
3872 if {[llength $kids] == 1} {
3873 set col [lsearch -exact $idlist $p]
3874 lset idlist $col $newcmit
3875 } else {
3876 set col [llength $idlist]
3877 lappend idlist $newcmit
3878 lappend offs {}
3879 lset rowoffsets $row $offs
3881 set rowidlist [linsert $rowidlist $row $idlist]
3882 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3884 set rowrangelist [linsert $rowrangelist $row {}]
3885 if {[llength $kids] > 1} {
3886 set rp1 [expr {$row + 1}]
3887 set ranges [lindex $rowrangelist $rp1]
3888 if {$ranges eq {}} {
3889 set ranges [list $newcmit $p]
3890 } elseif {[lindex $ranges end-1] eq $p} {
3891 lset ranges end-1 $newcmit
3893 lset rowrangelist $rp1 $ranges
3896 catch {unset rowchk}
3898 incr rowlaidout
3899 incr rowoptim
3900 incr numcommits
3902 if {[info exists selectedline] && $selectedline >= $row} {
3903 incr selectedline
3905 redisplay
3908 # Remove a commit that was inserted with insertrow on row $row.
3909 proc removerow {row} {
3910 global displayorder parentlist commitlisted children
3911 global commitrow curview rowidlist rowoffsets numcommits
3912 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3913 global linesegends selectedline rowchk commitidx
3915 if {$row >= $numcommits} {
3916 puts "oops, removing row $row but only have $numcommits rows"
3917 return
3919 set rp1 [expr {$row + 1}]
3920 set id [lindex $displayorder $row]
3921 set p [lindex $parentlist $row]
3922 set displayorder [lreplace $displayorder $row $row]
3923 set parentlist [lreplace $parentlist $row $row]
3924 set commitlisted [lreplace $commitlisted $row $row]
3925 set kids $children($curview,$p)
3926 set i [lsearch -exact $kids $id]
3927 if {$i >= 0} {
3928 set kids [lreplace $kids $i $i]
3929 set children($curview,$p) $kids
3931 set l [llength $displayorder]
3932 for {set r $row} {$r < $l} {incr r} {
3933 set id [lindex $displayorder $r]
3934 set commitrow($curview,$id) $r
3936 incr commitidx($curview) -1
3938 set rowidlist [lreplace $rowidlist $row $row]
3939 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
3940 if {$kids ne {}} {
3941 set offs [lindex $rowoffsets $row]
3942 set offs [lreplace $offs end end]
3943 lset rowoffsets $row $offs
3946 set rowrangelist [lreplace $rowrangelist $row $row]
3947 if {[llength $kids] > 0} {
3948 set ranges [lindex $rowrangelist $row]
3949 if {[lindex $ranges end-1] eq $id} {
3950 set ranges [lreplace $ranges end-1 end]
3951 lset rowrangelist $row $ranges
3955 catch {unset rowchk}
3957 incr rowlaidout -1
3958 incr rowoptim -1
3959 incr numcommits -1
3961 if {[info exists selectedline] && $selectedline > $row} {
3962 incr selectedline -1
3964 redisplay
3967 # Don't change the text pane cursor if it is currently the hand cursor,
3968 # showing that we are over a sha1 ID link.
3969 proc settextcursor {c} {
3970 global ctext curtextcursor
3972 if {[$ctext cget -cursor] == $curtextcursor} {
3973 $ctext config -cursor $c
3975 set curtextcursor $c
3978 proc nowbusy {what} {
3979 global isbusy
3981 if {[array names isbusy] eq {}} {
3982 . config -cursor watch
3983 settextcursor watch
3985 set isbusy($what) 1
3988 proc notbusy {what} {
3989 global isbusy maincursor textcursor
3991 catch {unset isbusy($what)}
3992 if {[array names isbusy] eq {}} {
3993 . config -cursor $maincursor
3994 settextcursor $textcursor
3998 proc findmatches {f} {
3999 global findtype findstring
4000 if {$findtype == "Regexp"} {
4001 set matches [regexp -indices -all -inline $findstring $f]
4002 } else {
4003 set fs $findstring
4004 if {$findtype == "IgnCase"} {
4005 set f [string tolower $f]
4006 set fs [string tolower $fs]
4008 set matches {}
4009 set i 0
4010 set l [string length $fs]
4011 while {[set j [string first $fs $f $i]] >= 0} {
4012 lappend matches [list $j [expr {$j+$l-1}]]
4013 set i [expr {$j + $l}]
4016 return $matches
4019 proc dofind {{rev 0}} {
4020 global findstring findstartline findcurline selectedline numcommits
4022 unmarkmatches
4023 cancel_next_highlight
4024 focus .
4025 if {$findstring eq {} || $numcommits == 0} return
4026 if {![info exists selectedline]} {
4027 set findstartline [lindex [visiblerows] $rev]
4028 } else {
4029 set findstartline $selectedline
4031 set findcurline $findstartline
4032 nowbusy finding
4033 if {!$rev} {
4034 run findmore
4035 } else {
4036 set findcurline $findstartline
4037 if {$findcurline == 0} {
4038 set findcurline $numcommits
4040 incr findcurline -1
4041 run findmorerev
4045 proc findnext {restart} {
4046 global findcurline
4047 if {![info exists findcurline]} {
4048 if {$restart} {
4049 dofind
4050 } else {
4051 bell
4053 } else {
4054 run findmore
4055 nowbusy finding
4059 proc findprev {} {
4060 global findcurline
4061 if {![info exists findcurline]} {
4062 dofind 1
4063 } else {
4064 run findmorerev
4065 nowbusy finding
4069 proc findmore {} {
4070 global commitdata commitinfo numcommits findstring findpattern findloc
4071 global findstartline findcurline markingmatches displayorder
4073 set fldtypes {Headline Author Date Committer CDate Comments}
4074 set l [expr {$findcurline + 1}]
4075 if {$l >= $numcommits} {
4076 set l 0
4078 if {$l <= $findstartline} {
4079 set lim [expr {$findstartline + 1}]
4080 } else {
4081 set lim $numcommits
4083 if {$lim - $l > 500} {
4084 set lim [expr {$l + 500}]
4086 set last 0
4087 for {} {$l < $lim} {incr l} {
4088 set id [lindex $displayorder $l]
4089 if {![doesmatch $commitdata($id)]} continue
4090 if {![info exists commitinfo($id)]} {
4091 getcommit $id
4093 set info $commitinfo($id)
4094 foreach f $info ty $fldtypes {
4095 if {($findloc eq "All fields" || $findloc eq $ty) &&
4096 [doesmatch $f]} {
4097 set markingmatches 1
4098 findselectline $l
4099 notbusy finding
4100 return 0
4104 if {$l == $findstartline + 1} {
4105 bell
4106 unset findcurline
4107 notbusy finding
4108 return 0
4110 set findcurline [expr {$l - 1}]
4111 return 1
4114 proc findmorerev {} {
4115 global commitdata commitinfo numcommits findstring findpattern findloc
4116 global findstartline findcurline markingmatches displayorder
4118 set fldtypes {Headline Author Date Committer CDate Comments}
4119 set l $findcurline
4120 if {$l == 0} {
4121 set l $numcommits
4123 incr l -1
4124 if {$l >= $findstartline} {
4125 set lim [expr {$findstartline - 1}]
4126 } else {
4127 set lim -1
4129 if {$l - $lim > 500} {
4130 set lim [expr {$l - 500}]
4132 set last 0
4133 for {} {$l > $lim} {incr l -1} {
4134 set id [lindex $displayorder $l]
4135 if {![doesmatch $commitdata($id)]} continue
4136 if {![info exists commitinfo($id)]} {
4137 getcommit $id
4139 set info $commitinfo($id)
4140 foreach f $info ty $fldtypes {
4141 if {($findloc eq "All fields" || $findloc eq $ty) &&
4142 [doesmatch $f]} {
4143 set markingmatches 1
4144 findselectline $l
4145 notbusy finding
4146 return 0
4150 if {$l == -1} {
4151 bell
4152 unset findcurline
4153 notbusy finding
4154 return 0
4156 set findcurline [expr {$l + 1}]
4157 return 1
4160 proc findselectline {l} {
4161 global findloc commentend ctext
4162 selectline $l 1
4163 if {$findloc == "All fields" || $findloc == "Comments"} {
4164 # highlight the matches in the comments
4165 set f [$ctext get 1.0 $commentend]
4166 set matches [findmatches $f]
4167 foreach match $matches {
4168 set start [lindex $match 0]
4169 set end [expr {[lindex $match 1] + 1}]
4170 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4175 # mark the bits of a headline or author that match a find string
4176 proc markmatches {canv l str tag matches font} {
4177 set bbox [$canv bbox $tag]
4178 set x0 [lindex $bbox 0]
4179 set y0 [lindex $bbox 1]
4180 set y1 [lindex $bbox 3]
4181 foreach match $matches {
4182 set start [lindex $match 0]
4183 set end [lindex $match 1]
4184 if {$start > $end} continue
4185 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4186 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4187 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4188 [expr {$x0+$xlen+2}] $y1 \
4189 -outline {} -tags [list match$l matches] -fill yellow]
4190 $canv lower $t
4194 proc unmarkmatches {} {
4195 global findids markingmatches findcurline
4197 allcanvs delete matches
4198 catch {unset findids}
4199 set markingmatches 0
4200 catch {unset findcurline}
4203 proc selcanvline {w x y} {
4204 global canv canvy0 ctext linespc
4205 global rowtextx
4206 set ymax [lindex [$canv cget -scrollregion] 3]
4207 if {$ymax == {}} return
4208 set yfrac [lindex [$canv yview] 0]
4209 set y [expr {$y + $yfrac * $ymax}]
4210 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4211 if {$l < 0} {
4212 set l 0
4214 if {$w eq $canv} {
4215 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4217 unmarkmatches
4218 selectline $l 1
4221 proc commit_descriptor {p} {
4222 global commitinfo
4223 if {![info exists commitinfo($p)]} {
4224 getcommit $p
4226 set l "..."
4227 if {[llength $commitinfo($p)] > 1} {
4228 set l [lindex $commitinfo($p) 0]
4230 return "$p ($l)\n"
4233 # append some text to the ctext widget, and make any SHA1 ID
4234 # that we know about be a clickable link.
4235 proc appendwithlinks {text tags} {
4236 global ctext commitrow linknum curview
4238 set start [$ctext index "end - 1c"]
4239 $ctext insert end $text $tags
4240 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4241 foreach l $links {
4242 set s [lindex $l 0]
4243 set e [lindex $l 1]
4244 set linkid [string range $text $s $e]
4245 if {![info exists commitrow($curview,$linkid)]} continue
4246 incr e
4247 $ctext tag add link "$start + $s c" "$start + $e c"
4248 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4249 $ctext tag bind link$linknum <1> \
4250 [list selectline $commitrow($curview,$linkid) 1]
4251 incr linknum
4253 $ctext tag conf link -foreground blue -underline 1
4254 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4255 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4258 proc viewnextline {dir} {
4259 global canv linespc
4261 $canv delete hover
4262 set ymax [lindex [$canv cget -scrollregion] 3]
4263 set wnow [$canv yview]
4264 set wtop [expr {[lindex $wnow 0] * $ymax}]
4265 set newtop [expr {$wtop + $dir * $linespc}]
4266 if {$newtop < 0} {
4267 set newtop 0
4268 } elseif {$newtop > $ymax} {
4269 set newtop $ymax
4271 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4274 # add a list of tag or branch names at position pos
4275 # returns the number of names inserted
4276 proc appendrefs {pos ids var} {
4277 global ctext commitrow linknum curview $var maxrefs
4279 if {[catch {$ctext index $pos}]} {
4280 return 0
4282 $ctext conf -state normal
4283 $ctext delete $pos "$pos lineend"
4284 set tags {}
4285 foreach id $ids {
4286 foreach tag [set $var\($id\)] {
4287 lappend tags [list $tag $id]
4290 if {[llength $tags] > $maxrefs} {
4291 $ctext insert $pos "many ([llength $tags])"
4292 } else {
4293 set tags [lsort -index 0 -decreasing $tags]
4294 set sep {}
4295 foreach ti $tags {
4296 set id [lindex $ti 1]
4297 set lk link$linknum
4298 incr linknum
4299 $ctext tag delete $lk
4300 $ctext insert $pos $sep
4301 $ctext insert $pos [lindex $ti 0] $lk
4302 if {[info exists commitrow($curview,$id)]} {
4303 $ctext tag conf $lk -foreground blue
4304 $ctext tag bind $lk <1> \
4305 [list selectline $commitrow($curview,$id) 1]
4306 $ctext tag conf $lk -underline 1
4307 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4308 $ctext tag bind $lk <Leave> \
4309 { %W configure -cursor $curtextcursor }
4311 set sep ", "
4314 $ctext conf -state disabled
4315 return [llength $tags]
4318 # called when we have finished computing the nearby tags
4319 proc dispneartags {delay} {
4320 global selectedline currentid showneartags tagphase
4322 if {![info exists selectedline] || !$showneartags} return
4323 after cancel dispnexttag
4324 if {$delay} {
4325 after 200 dispnexttag
4326 set tagphase -1
4327 } else {
4328 after idle dispnexttag
4329 set tagphase 0
4333 proc dispnexttag {} {
4334 global selectedline currentid showneartags tagphase ctext
4336 if {![info exists selectedline] || !$showneartags} return
4337 switch -- $tagphase {
4339 set dtags [desctags $currentid]
4340 if {$dtags ne {}} {
4341 appendrefs precedes $dtags idtags
4345 set atags [anctags $currentid]
4346 if {$atags ne {}} {
4347 appendrefs follows $atags idtags
4351 set dheads [descheads $currentid]
4352 if {$dheads ne {}} {
4353 if {[appendrefs branch $dheads idheads] > 1
4354 && [$ctext get "branch -3c"] eq "h"} {
4355 # turn "Branch" into "Branches"
4356 $ctext conf -state normal
4357 $ctext insert "branch -2c" "es"
4358 $ctext conf -state disabled
4363 if {[incr tagphase] <= 2} {
4364 after idle dispnexttag
4368 proc selectline {l isnew} {
4369 global canv canv2 canv3 ctext commitinfo selectedline
4370 global displayorder linehtag linentag linedtag
4371 global canvy0 linespc parentlist children curview
4372 global currentid sha1entry
4373 global commentend idtags linknum
4374 global mergemax numcommits pending_select
4375 global cmitmode showneartags allcommits
4377 catch {unset pending_select}
4378 $canv delete hover
4379 normalline
4380 cancel_next_highlight
4381 if {$l < 0 || $l >= $numcommits} return
4382 set y [expr {$canvy0 + $l * $linespc}]
4383 set ymax [lindex [$canv cget -scrollregion] 3]
4384 set ytop [expr {$y - $linespc - 1}]
4385 set ybot [expr {$y + $linespc + 1}]
4386 set wnow [$canv yview]
4387 set wtop [expr {[lindex $wnow 0] * $ymax}]
4388 set wbot [expr {[lindex $wnow 1] * $ymax}]
4389 set wh [expr {$wbot - $wtop}]
4390 set newtop $wtop
4391 if {$ytop < $wtop} {
4392 if {$ybot < $wtop} {
4393 set newtop [expr {$y - $wh / 2.0}]
4394 } else {
4395 set newtop $ytop
4396 if {$newtop > $wtop - $linespc} {
4397 set newtop [expr {$wtop - $linespc}]
4400 } elseif {$ybot > $wbot} {
4401 if {$ytop > $wbot} {
4402 set newtop [expr {$y - $wh / 2.0}]
4403 } else {
4404 set newtop [expr {$ybot - $wh}]
4405 if {$newtop < $wtop + $linespc} {
4406 set newtop [expr {$wtop + $linespc}]
4410 if {$newtop != $wtop} {
4411 if {$newtop < 0} {
4412 set newtop 0
4414 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4415 drawvisible
4418 if {![info exists linehtag($l)]} return
4419 $canv delete secsel
4420 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4421 -tags secsel -fill [$canv cget -selectbackground]]
4422 $canv lower $t
4423 $canv2 delete secsel
4424 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4425 -tags secsel -fill [$canv2 cget -selectbackground]]
4426 $canv2 lower $t
4427 $canv3 delete secsel
4428 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4429 -tags secsel -fill [$canv3 cget -selectbackground]]
4430 $canv3 lower $t
4432 if {$isnew} {
4433 addtohistory [list selectline $l 0]
4436 set selectedline $l
4438 set id [lindex $displayorder $l]
4439 set currentid $id
4440 $sha1entry delete 0 end
4441 $sha1entry insert 0 $id
4442 $sha1entry selection from 0
4443 $sha1entry selection to end
4444 rhighlight_sel $id
4446 $ctext conf -state normal
4447 clear_ctext
4448 set linknum 0
4449 set info $commitinfo($id)
4450 set date [formatdate [lindex $info 2]]
4451 $ctext insert end "Author: [lindex $info 1] $date\n"
4452 set date [formatdate [lindex $info 4]]
4453 $ctext insert end "Committer: [lindex $info 3] $date\n"
4454 if {[info exists idtags($id)]} {
4455 $ctext insert end "Tags:"
4456 foreach tag $idtags($id) {
4457 $ctext insert end " $tag"
4459 $ctext insert end "\n"
4462 set headers {}
4463 set olds [lindex $parentlist $l]
4464 if {[llength $olds] > 1} {
4465 set np 0
4466 foreach p $olds {
4467 if {$np >= $mergemax} {
4468 set tag mmax
4469 } else {
4470 set tag m$np
4472 $ctext insert end "Parent: " $tag
4473 appendwithlinks [commit_descriptor $p] {}
4474 incr np
4476 } else {
4477 foreach p $olds {
4478 append headers "Parent: [commit_descriptor $p]"
4482 foreach c $children($curview,$id) {
4483 append headers "Child: [commit_descriptor $c]"
4486 # make anything that looks like a SHA1 ID be a clickable link
4487 appendwithlinks $headers {}
4488 if {$showneartags} {
4489 if {![info exists allcommits]} {
4490 getallcommits
4492 $ctext insert end "Branch: "
4493 $ctext mark set branch "end -1c"
4494 $ctext mark gravity branch left
4495 $ctext insert end "\nFollows: "
4496 $ctext mark set follows "end -1c"
4497 $ctext mark gravity follows left
4498 $ctext insert end "\nPrecedes: "
4499 $ctext mark set precedes "end -1c"
4500 $ctext mark gravity precedes left
4501 $ctext insert end "\n"
4502 dispneartags 1
4504 $ctext insert end "\n"
4505 set comment [lindex $info 5]
4506 if {[string first "\r" $comment] >= 0} {
4507 set comment [string map {"\r" "\n "} $comment]
4509 appendwithlinks $comment {comment}
4511 $ctext tag remove found 1.0 end
4512 $ctext conf -state disabled
4513 set commentend [$ctext index "end - 1c"]
4515 init_flist "Comments"
4516 if {$cmitmode eq "tree"} {
4517 gettree $id
4518 } elseif {[llength $olds] <= 1} {
4519 startdiff $id
4520 } else {
4521 mergediff $id $l
4525 proc selfirstline {} {
4526 unmarkmatches
4527 selectline 0 1
4530 proc sellastline {} {
4531 global numcommits
4532 unmarkmatches
4533 set l [expr {$numcommits - 1}]
4534 selectline $l 1
4537 proc selnextline {dir} {
4538 global selectedline
4539 if {![info exists selectedline]} return
4540 set l [expr {$selectedline + $dir}]
4541 unmarkmatches
4542 selectline $l 1
4545 proc selnextpage {dir} {
4546 global canv linespc selectedline numcommits
4548 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4549 if {$lpp < 1} {
4550 set lpp 1
4552 allcanvs yview scroll [expr {$dir * $lpp}] units
4553 drawvisible
4554 if {![info exists selectedline]} return
4555 set l [expr {$selectedline + $dir * $lpp}]
4556 if {$l < 0} {
4557 set l 0
4558 } elseif {$l >= $numcommits} {
4559 set l [expr $numcommits - 1]
4561 unmarkmatches
4562 selectline $l 1
4565 proc unselectline {} {
4566 global selectedline currentid
4568 catch {unset selectedline}
4569 catch {unset currentid}
4570 allcanvs delete secsel
4571 rhighlight_none
4572 cancel_next_highlight
4575 proc reselectline {} {
4576 global selectedline
4578 if {[info exists selectedline]} {
4579 selectline $selectedline 0
4583 proc addtohistory {cmd} {
4584 global history historyindex curview
4586 set elt [list $curview $cmd]
4587 if {$historyindex > 0
4588 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4589 return
4592 if {$historyindex < [llength $history]} {
4593 set history [lreplace $history $historyindex end $elt]
4594 } else {
4595 lappend history $elt
4597 incr historyindex
4598 if {$historyindex > 1} {
4599 .tf.bar.leftbut conf -state normal
4600 } else {
4601 .tf.bar.leftbut conf -state disabled
4603 .tf.bar.rightbut conf -state disabled
4606 proc godo {elt} {
4607 global curview
4609 set view [lindex $elt 0]
4610 set cmd [lindex $elt 1]
4611 if {$curview != $view} {
4612 showview $view
4614 eval $cmd
4617 proc goback {} {
4618 global history historyindex
4620 if {$historyindex > 1} {
4621 incr historyindex -1
4622 godo [lindex $history [expr {$historyindex - 1}]]
4623 .tf.bar.rightbut conf -state normal
4625 if {$historyindex <= 1} {
4626 .tf.bar.leftbut conf -state disabled
4630 proc goforw {} {
4631 global history historyindex
4633 if {$historyindex < [llength $history]} {
4634 set cmd [lindex $history $historyindex]
4635 incr historyindex
4636 godo $cmd
4637 .tf.bar.leftbut conf -state normal
4639 if {$historyindex >= [llength $history]} {
4640 .tf.bar.rightbut conf -state disabled
4644 proc gettree {id} {
4645 global treefilelist treeidlist diffids diffmergeid treepending
4646 global nullid nullid2
4648 set diffids $id
4649 catch {unset diffmergeid}
4650 if {![info exists treefilelist($id)]} {
4651 if {![info exists treepending]} {
4652 if {$id eq $nullid} {
4653 set cmd [list | git ls-files]
4654 } elseif {$id eq $nullid2} {
4655 set cmd [list | git ls-files --stage -t]
4656 } else {
4657 set cmd [list | git ls-tree -r $id]
4659 if {[catch {set gtf [open $cmd r]}]} {
4660 return
4662 set treepending $id
4663 set treefilelist($id) {}
4664 set treeidlist($id) {}
4665 fconfigure $gtf -blocking 0
4666 filerun $gtf [list gettreeline $gtf $id]
4668 } else {
4669 setfilelist $id
4673 proc gettreeline {gtf id} {
4674 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4676 set nl 0
4677 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4678 if {$diffids eq $nullid} {
4679 set fname $line
4680 } else {
4681 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4682 set i [string first "\t" $line]
4683 if {$i < 0} continue
4684 set sha1 [lindex $line 2]
4685 set fname [string range $line [expr {$i+1}] end]
4686 if {[string index $fname 0] eq "\""} {
4687 set fname [lindex $fname 0]
4689 lappend treeidlist($id) $sha1
4691 lappend treefilelist($id) $fname
4693 if {![eof $gtf]} {
4694 return [expr {$nl >= 1000? 2: 1}]
4696 close $gtf
4697 unset treepending
4698 if {$cmitmode ne "tree"} {
4699 if {![info exists diffmergeid]} {
4700 gettreediffs $diffids
4702 } elseif {$id ne $diffids} {
4703 gettree $diffids
4704 } else {
4705 setfilelist $id
4707 return 0
4710 proc showfile {f} {
4711 global treefilelist treeidlist diffids nullid nullid2
4712 global ctext commentend
4714 set i [lsearch -exact $treefilelist($diffids) $f]
4715 if {$i < 0} {
4716 puts "oops, $f not in list for id $diffids"
4717 return
4719 if {$diffids eq $nullid} {
4720 if {[catch {set bf [open $f r]} err]} {
4721 puts "oops, can't read $f: $err"
4722 return
4724 } else {
4725 set blob [lindex $treeidlist($diffids) $i]
4726 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4727 puts "oops, error reading blob $blob: $err"
4728 return
4731 fconfigure $bf -blocking 0
4732 filerun $bf [list getblobline $bf $diffids]
4733 $ctext config -state normal
4734 clear_ctext $commentend
4735 $ctext insert end "\n"
4736 $ctext insert end "$f\n" filesep
4737 $ctext config -state disabled
4738 $ctext yview $commentend
4741 proc getblobline {bf id} {
4742 global diffids cmitmode ctext
4744 if {$id ne $diffids || $cmitmode ne "tree"} {
4745 catch {close $bf}
4746 return 0
4748 $ctext config -state normal
4749 set nl 0
4750 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4751 $ctext insert end "$line\n"
4753 if {[eof $bf]} {
4754 # delete last newline
4755 $ctext delete "end - 2c" "end - 1c"
4756 close $bf
4757 return 0
4759 $ctext config -state disabled
4760 return [expr {$nl >= 1000? 2: 1}]
4763 proc mergediff {id l} {
4764 global diffmergeid diffopts mdifffd
4765 global diffids
4766 global parentlist
4768 set diffmergeid $id
4769 set diffids $id
4770 # this doesn't seem to actually affect anything...
4771 set env(GIT_DIFF_OPTS) $diffopts
4772 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4773 if {[catch {set mdf [open $cmd r]} err]} {
4774 error_popup "Error getting merge diffs: $err"
4775 return
4777 fconfigure $mdf -blocking 0
4778 set mdifffd($id) $mdf
4779 set np [llength [lindex $parentlist $l]]
4780 filerun $mdf [list getmergediffline $mdf $id $np]
4783 proc getmergediffline {mdf id np} {
4784 global diffmergeid ctext cflist mergemax
4785 global difffilestart mdifffd
4787 $ctext conf -state normal
4788 set nr 0
4789 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4790 if {![info exists diffmergeid] || $id != $diffmergeid
4791 || $mdf != $mdifffd($id)} {
4792 close $mdf
4793 return 0
4795 if {[regexp {^diff --cc (.*)} $line match fname]} {
4796 # start of a new file
4797 $ctext insert end "\n"
4798 set here [$ctext index "end - 1c"]
4799 lappend difffilestart $here
4800 add_flist [list $fname]
4801 set l [expr {(78 - [string length $fname]) / 2}]
4802 set pad [string range "----------------------------------------" 1 $l]
4803 $ctext insert end "$pad $fname $pad\n" filesep
4804 } elseif {[regexp {^@@} $line]} {
4805 $ctext insert end "$line\n" hunksep
4806 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4807 # do nothing
4808 } else {
4809 # parse the prefix - one ' ', '-' or '+' for each parent
4810 set spaces {}
4811 set minuses {}
4812 set pluses {}
4813 set isbad 0
4814 for {set j 0} {$j < $np} {incr j} {
4815 set c [string range $line $j $j]
4816 if {$c == " "} {
4817 lappend spaces $j
4818 } elseif {$c == "-"} {
4819 lappend minuses $j
4820 } elseif {$c == "+"} {
4821 lappend pluses $j
4822 } else {
4823 set isbad 1
4824 break
4827 set tags {}
4828 set num {}
4829 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4830 # line doesn't appear in result, parents in $minuses have the line
4831 set num [lindex $minuses 0]
4832 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4833 # line appears in result, parents in $pluses don't have the line
4834 lappend tags mresult
4835 set num [lindex $spaces 0]
4837 if {$num ne {}} {
4838 if {$num >= $mergemax} {
4839 set num "max"
4841 lappend tags m$num
4843 $ctext insert end "$line\n" $tags
4846 $ctext conf -state disabled
4847 if {[eof $mdf]} {
4848 close $mdf
4849 return 0
4851 return [expr {$nr >= 1000? 2: 1}]
4854 proc startdiff {ids} {
4855 global treediffs diffids treepending diffmergeid nullid nullid2
4857 set diffids $ids
4858 catch {unset diffmergeid}
4859 if {![info exists treediffs($ids)] ||
4860 [lsearch -exact $ids $nullid] >= 0 ||
4861 [lsearch -exact $ids $nullid2] >= 0} {
4862 if {![info exists treepending]} {
4863 gettreediffs $ids
4865 } else {
4866 addtocflist $ids
4870 proc addtocflist {ids} {
4871 global treediffs cflist
4872 add_flist $treediffs($ids)
4873 getblobdiffs $ids
4876 proc diffcmd {ids flags} {
4877 global nullid nullid2
4879 set i [lsearch -exact $ids $nullid]
4880 set j [lsearch -exact $ids $nullid2]
4881 if {$i >= 0} {
4882 if {[llength $ids] > 1 && $j < 0} {
4883 # comparing working directory with some specific revision
4884 set cmd [concat | git diff-index $flags]
4885 if {$i == 0} {
4886 lappend cmd -R [lindex $ids 1]
4887 } else {
4888 lappend cmd [lindex $ids 0]
4890 } else {
4891 # comparing working directory with index
4892 set cmd [concat | git diff-files $flags]
4893 if {$j == 1} {
4894 lappend cmd -R
4897 } elseif {$j >= 0} {
4898 set cmd [concat | git diff-index --cached $flags]
4899 if {[llength $ids] > 1} {
4900 # comparing index with specific revision
4901 if {$i == 0} {
4902 lappend cmd -R [lindex $ids 1]
4903 } else {
4904 lappend cmd [lindex $ids 0]
4906 } else {
4907 # comparing index with HEAD
4908 lappend cmd HEAD
4910 } else {
4911 set cmd [concat | git diff-tree -r $flags $ids]
4913 return $cmd
4916 proc gettreediffs {ids} {
4917 global treediff treepending
4919 set treepending $ids
4920 set treediff {}
4921 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
4922 fconfigure $gdtf -blocking 0
4923 filerun $gdtf [list gettreediffline $gdtf $ids]
4926 proc gettreediffline {gdtf ids} {
4927 global treediff treediffs treepending diffids diffmergeid
4928 global cmitmode
4930 set nr 0
4931 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4932 set i [string first "\t" $line]
4933 if {$i >= 0} {
4934 set file [string range $line [expr {$i+1}] end]
4935 if {[string index $file 0] eq "\""} {
4936 set file [lindex $file 0]
4938 lappend treediff $file
4941 if {![eof $gdtf]} {
4942 return [expr {$nr >= 1000? 2: 1}]
4944 close $gdtf
4945 set treediffs($ids) $treediff
4946 unset treepending
4947 if {$cmitmode eq "tree"} {
4948 gettree $diffids
4949 } elseif {$ids != $diffids} {
4950 if {![info exists diffmergeid]} {
4951 gettreediffs $diffids
4953 } else {
4954 addtocflist $ids
4956 return 0
4959 proc getblobdiffs {ids} {
4960 global diffopts blobdifffd diffids env
4961 global diffinhdr treediffs
4963 set env(GIT_DIFF_OPTS) $diffopts
4964 if {[catch {set bdf [open [diffcmd $ids {-p -C --no-commit-id}] r]} err]} {
4965 puts "error getting diffs: $err"
4966 return
4968 set diffinhdr 0
4969 fconfigure $bdf -blocking 0
4970 set blobdifffd($ids) $bdf
4971 filerun $bdf [list getblobdiffline $bdf $diffids]
4974 proc setinlist {var i val} {
4975 global $var
4977 while {[llength [set $var]] < $i} {
4978 lappend $var {}
4980 if {[llength [set $var]] == $i} {
4981 lappend $var $val
4982 } else {
4983 lset $var $i $val
4987 proc makediffhdr {fname ids} {
4988 global ctext curdiffstart treediffs
4990 set i [lsearch -exact $treediffs($ids) $fname]
4991 if {$i >= 0} {
4992 setinlist difffilestart $i $curdiffstart
4994 set l [expr {(78 - [string length $fname]) / 2}]
4995 set pad [string range "----------------------------------------" 1 $l]
4996 $ctext insert $curdiffstart "$pad $fname $pad" filesep
4999 proc getblobdiffline {bdf ids} {
5000 global diffids blobdifffd ctext curdiffstart
5001 global diffnexthead diffnextnote difffilestart
5002 global diffinhdr treediffs
5004 set nr 0
5005 $ctext conf -state normal
5006 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5007 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5008 close $bdf
5009 return 0
5011 if {![string compare -length 11 "diff --git " $line]} {
5012 # trim off "diff --git "
5013 set line [string range $line 11 end]
5014 set diffinhdr 1
5015 # start of a new file
5016 $ctext insert end "\n"
5017 set curdiffstart [$ctext index "end - 1c"]
5018 $ctext insert end "\n" filesep
5019 # If the name hasn't changed the length will be odd,
5020 # the middle char will be a space, and the two bits either
5021 # side will be a/name and b/name, or "a/name" and "b/name".
5022 # If the name has changed we'll get "rename from" and
5023 # "rename to" lines following this, and we'll use them
5024 # to get the filenames.
5025 # This complexity is necessary because spaces in the filename(s)
5026 # don't get escaped.
5027 set l [string length $line]
5028 set i [expr {$l / 2}]
5029 if {!(($l & 1) && [string index $line $i] eq " " &&
5030 [string range $line 2 [expr {$i - 1}]] eq \
5031 [string range $line [expr {$i + 3}] end])} {
5032 continue
5034 # unescape if quoted and chop off the a/ from the front
5035 if {[string index $line 0] eq "\""} {
5036 set fname [string range [lindex $line 0] 2 end]
5037 } else {
5038 set fname [string range $line 2 [expr {$i - 1}]]
5040 makediffhdr $fname $ids
5042 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5043 $line match f1l f1c f2l f2c rest]} {
5044 $ctext insert end "$line\n" hunksep
5045 set diffinhdr 0
5047 } elseif {$diffinhdr} {
5048 if {![string compare -length 12 "rename from " $line]} {
5049 set fname [string range $line 12 end]
5050 if {[string index $fname 0] eq "\""} {
5051 set fname [lindex $fname 0]
5053 set i [lsearch -exact $treediffs($ids) $fname]
5054 if {$i >= 0} {
5055 setinlist difffilestart $i $curdiffstart
5057 } elseif {![string compare -length 10 $line "rename to "]} {
5058 set fname [string range $line 10 end]
5059 if {[string index $fname 0] eq "\""} {
5060 set fname [lindex $fname 0]
5062 makediffhdr $fname $ids
5063 } elseif {[string compare -length 3 $line "---"] == 0} {
5064 # do nothing
5065 continue
5066 } elseif {[string compare -length 3 $line "+++"] == 0} {
5067 set diffinhdr 0
5068 continue
5070 $ctext insert end "$line\n" filesep
5072 } else {
5073 set x [string range $line 0 0]
5074 if {$x == "-" || $x == "+"} {
5075 set tag [expr {$x == "+"}]
5076 $ctext insert end "$line\n" d$tag
5077 } elseif {$x == " "} {
5078 $ctext insert end "$line\n"
5079 } else {
5080 # "\ No newline at end of file",
5081 # or something else we don't recognize
5082 $ctext insert end "$line\n" hunksep
5086 $ctext conf -state disabled
5087 if {[eof $bdf]} {
5088 close $bdf
5089 return 0
5091 return [expr {$nr >= 1000? 2: 1}]
5094 proc changediffdisp {} {
5095 global ctext diffelide
5097 $ctext tag conf d0 -elide [lindex $diffelide 0]
5098 $ctext tag conf d1 -elide [lindex $diffelide 1]
5101 proc prevfile {} {
5102 global difffilestart ctext
5103 set prev [lindex $difffilestart 0]
5104 set here [$ctext index @0,0]
5105 foreach loc $difffilestart {
5106 if {[$ctext compare $loc >= $here]} {
5107 $ctext yview $prev
5108 return
5110 set prev $loc
5112 $ctext yview $prev
5115 proc nextfile {} {
5116 global difffilestart ctext
5117 set here [$ctext index @0,0]
5118 foreach loc $difffilestart {
5119 if {[$ctext compare $loc > $here]} {
5120 $ctext yview $loc
5121 return
5126 proc clear_ctext {{first 1.0}} {
5127 global ctext smarktop smarkbot
5129 set l [lindex [split $first .] 0]
5130 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5131 set smarktop $l
5133 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5134 set smarkbot $l
5136 $ctext delete $first end
5139 proc incrsearch {name ix op} {
5140 global ctext searchstring searchdirn
5142 $ctext tag remove found 1.0 end
5143 if {[catch {$ctext index anchor}]} {
5144 # no anchor set, use start of selection, or of visible area
5145 set sel [$ctext tag ranges sel]
5146 if {$sel ne {}} {
5147 $ctext mark set anchor [lindex $sel 0]
5148 } elseif {$searchdirn eq "-forwards"} {
5149 $ctext mark set anchor @0,0
5150 } else {
5151 $ctext mark set anchor @0,[winfo height $ctext]
5154 if {$searchstring ne {}} {
5155 set here [$ctext search $searchdirn -- $searchstring anchor]
5156 if {$here ne {}} {
5157 $ctext see $here
5159 searchmarkvisible 1
5163 proc dosearch {} {
5164 global sstring ctext searchstring searchdirn
5166 focus $sstring
5167 $sstring icursor end
5168 set searchdirn -forwards
5169 if {$searchstring ne {}} {
5170 set sel [$ctext tag ranges sel]
5171 if {$sel ne {}} {
5172 set start "[lindex $sel 0] + 1c"
5173 } elseif {[catch {set start [$ctext index anchor]}]} {
5174 set start "@0,0"
5176 set match [$ctext search -count mlen -- $searchstring $start]
5177 $ctext tag remove sel 1.0 end
5178 if {$match eq {}} {
5179 bell
5180 return
5182 $ctext see $match
5183 set mend "$match + $mlen c"
5184 $ctext tag add sel $match $mend
5185 $ctext mark unset anchor
5189 proc dosearchback {} {
5190 global sstring ctext searchstring searchdirn
5192 focus $sstring
5193 $sstring icursor end
5194 set searchdirn -backwards
5195 if {$searchstring ne {}} {
5196 set sel [$ctext tag ranges sel]
5197 if {$sel ne {}} {
5198 set start [lindex $sel 0]
5199 } elseif {[catch {set start [$ctext index anchor]}]} {
5200 set start @0,[winfo height $ctext]
5202 set match [$ctext search -backwards -count ml -- $searchstring $start]
5203 $ctext tag remove sel 1.0 end
5204 if {$match eq {}} {
5205 bell
5206 return
5208 $ctext see $match
5209 set mend "$match + $ml c"
5210 $ctext tag add sel $match $mend
5211 $ctext mark unset anchor
5215 proc searchmark {first last} {
5216 global ctext searchstring
5218 set mend $first.0
5219 while {1} {
5220 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5221 if {$match eq {}} break
5222 set mend "$match + $mlen c"
5223 $ctext tag add found $match $mend
5227 proc searchmarkvisible {doall} {
5228 global ctext smarktop smarkbot
5230 set topline [lindex [split [$ctext index @0,0] .] 0]
5231 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5232 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5233 # no overlap with previous
5234 searchmark $topline $botline
5235 set smarktop $topline
5236 set smarkbot $botline
5237 } else {
5238 if {$topline < $smarktop} {
5239 searchmark $topline [expr {$smarktop-1}]
5240 set smarktop $topline
5242 if {$botline > $smarkbot} {
5243 searchmark [expr {$smarkbot+1}] $botline
5244 set smarkbot $botline
5249 proc scrolltext {f0 f1} {
5250 global searchstring
5252 .bleft.sb set $f0 $f1
5253 if {$searchstring ne {}} {
5254 searchmarkvisible 0
5258 proc setcoords {} {
5259 global linespc charspc canvx0 canvy0 mainfont
5260 global xspc1 xspc2 lthickness
5262 set linespc [font metrics $mainfont -linespace]
5263 set charspc [font measure $mainfont "m"]
5264 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5265 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5266 set lthickness [expr {int($linespc / 9) + 1}]
5267 set xspc1(0) $linespc
5268 set xspc2 $linespc
5271 proc redisplay {} {
5272 global canv
5273 global selectedline
5275 set ymax [lindex [$canv cget -scrollregion] 3]
5276 if {$ymax eq {} || $ymax == 0} return
5277 set span [$canv yview]
5278 clear_display
5279 setcanvscroll
5280 allcanvs yview moveto [lindex $span 0]
5281 drawvisible
5282 if {[info exists selectedline]} {
5283 selectline $selectedline 0
5284 allcanvs yview moveto [lindex $span 0]
5288 proc incrfont {inc} {
5289 global mainfont textfont ctext canv phase cflist
5290 global charspc tabstop
5291 global stopped entries
5292 unmarkmatches
5293 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5294 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5295 setcoords
5296 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5297 $cflist conf -font $textfont
5298 $ctext tag conf filesep -font [concat $textfont bold]
5299 foreach e $entries {
5300 $e conf -font $mainfont
5302 if {$phase eq "getcommits"} {
5303 $canv itemconf textitems -font $mainfont
5305 redisplay
5308 proc clearsha1 {} {
5309 global sha1entry sha1string
5310 if {[string length $sha1string] == 40} {
5311 $sha1entry delete 0 end
5315 proc sha1change {n1 n2 op} {
5316 global sha1string currentid sha1but
5317 if {$sha1string == {}
5318 || ([info exists currentid] && $sha1string == $currentid)} {
5319 set state disabled
5320 } else {
5321 set state normal
5323 if {[$sha1but cget -state] == $state} return
5324 if {$state == "normal"} {
5325 $sha1but conf -state normal -relief raised -text "Goto: "
5326 } else {
5327 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5331 proc gotocommit {} {
5332 global sha1string currentid commitrow tagids headids
5333 global displayorder numcommits curview
5335 if {$sha1string == {}
5336 || ([info exists currentid] && $sha1string == $currentid)} return
5337 if {[info exists tagids($sha1string)]} {
5338 set id $tagids($sha1string)
5339 } elseif {[info exists headids($sha1string)]} {
5340 set id $headids($sha1string)
5341 } else {
5342 set id [string tolower $sha1string]
5343 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5344 set matches {}
5345 foreach i $displayorder {
5346 if {[string match $id* $i]} {
5347 lappend matches $i
5350 if {$matches ne {}} {
5351 if {[llength $matches] > 1} {
5352 error_popup "Short SHA1 id $id is ambiguous"
5353 return
5355 set id [lindex $matches 0]
5359 if {[info exists commitrow($curview,$id)]} {
5360 selectline $commitrow($curview,$id) 1
5361 return
5363 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5364 set type "SHA1 id"
5365 } else {
5366 set type "Tag/Head"
5368 error_popup "$type $sha1string is not known"
5371 proc lineenter {x y id} {
5372 global hoverx hovery hoverid hovertimer
5373 global commitinfo canv
5375 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5376 set hoverx $x
5377 set hovery $y
5378 set hoverid $id
5379 if {[info exists hovertimer]} {
5380 after cancel $hovertimer
5382 set hovertimer [after 500 linehover]
5383 $canv delete hover
5386 proc linemotion {x y id} {
5387 global hoverx hovery hoverid hovertimer
5389 if {[info exists hoverid] && $id == $hoverid} {
5390 set hoverx $x
5391 set hovery $y
5392 if {[info exists hovertimer]} {
5393 after cancel $hovertimer
5395 set hovertimer [after 500 linehover]
5399 proc lineleave {id} {
5400 global hoverid hovertimer canv
5402 if {[info exists hoverid] && $id == $hoverid} {
5403 $canv delete hover
5404 if {[info exists hovertimer]} {
5405 after cancel $hovertimer
5406 unset hovertimer
5408 unset hoverid
5412 proc linehover {} {
5413 global hoverx hovery hoverid hovertimer
5414 global canv linespc lthickness
5415 global commitinfo mainfont
5417 set text [lindex $commitinfo($hoverid) 0]
5418 set ymax [lindex [$canv cget -scrollregion] 3]
5419 if {$ymax == {}} return
5420 set yfrac [lindex [$canv yview] 0]
5421 set x [expr {$hoverx + 2 * $linespc}]
5422 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5423 set x0 [expr {$x - 2 * $lthickness}]
5424 set y0 [expr {$y - 2 * $lthickness}]
5425 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5426 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5427 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5428 -fill \#ffff80 -outline black -width 1 -tags hover]
5429 $canv raise $t
5430 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5431 -font $mainfont]
5432 $canv raise $t
5435 proc clickisonarrow {id y} {
5436 global lthickness
5438 set ranges [rowranges $id]
5439 set thresh [expr {2 * $lthickness + 6}]
5440 set n [expr {[llength $ranges] - 1}]
5441 for {set i 1} {$i < $n} {incr i} {
5442 set row [lindex $ranges $i]
5443 if {abs([yc $row] - $y) < $thresh} {
5444 return $i
5447 return {}
5450 proc arrowjump {id n y} {
5451 global canv
5453 # 1 <-> 2, 3 <-> 4, etc...
5454 set n [expr {(($n - 1) ^ 1) + 1}]
5455 set row [lindex [rowranges $id] $n]
5456 set yt [yc $row]
5457 set ymax [lindex [$canv cget -scrollregion] 3]
5458 if {$ymax eq {} || $ymax <= 0} return
5459 set view [$canv yview]
5460 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5461 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5462 if {$yfrac < 0} {
5463 set yfrac 0
5465 allcanvs yview moveto $yfrac
5468 proc lineclick {x y id isnew} {
5469 global ctext commitinfo children canv thickerline curview
5471 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5472 unmarkmatches
5473 unselectline
5474 normalline
5475 $canv delete hover
5476 # draw this line thicker than normal
5477 set thickerline $id
5478 drawlines $id
5479 if {$isnew} {
5480 set ymax [lindex [$canv cget -scrollregion] 3]
5481 if {$ymax eq {}} return
5482 set yfrac [lindex [$canv yview] 0]
5483 set y [expr {$y + $yfrac * $ymax}]
5485 set dirn [clickisonarrow $id $y]
5486 if {$dirn ne {}} {
5487 arrowjump $id $dirn $y
5488 return
5491 if {$isnew} {
5492 addtohistory [list lineclick $x $y $id 0]
5494 # fill the details pane with info about this line
5495 $ctext conf -state normal
5496 clear_ctext
5497 $ctext tag conf link -foreground blue -underline 1
5498 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5499 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5500 $ctext insert end "Parent:\t"
5501 $ctext insert end $id [list link link0]
5502 $ctext tag bind link0 <1> [list selbyid $id]
5503 set info $commitinfo($id)
5504 $ctext insert end "\n\t[lindex $info 0]\n"
5505 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5506 set date [formatdate [lindex $info 2]]
5507 $ctext insert end "\tDate:\t$date\n"
5508 set kids $children($curview,$id)
5509 if {$kids ne {}} {
5510 $ctext insert end "\nChildren:"
5511 set i 0
5512 foreach child $kids {
5513 incr i
5514 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5515 set info $commitinfo($child)
5516 $ctext insert end "\n\t"
5517 $ctext insert end $child [list link link$i]
5518 $ctext tag bind link$i <1> [list selbyid $child]
5519 $ctext insert end "\n\t[lindex $info 0]"
5520 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5521 set date [formatdate [lindex $info 2]]
5522 $ctext insert end "\n\tDate:\t$date\n"
5525 $ctext conf -state disabled
5526 init_flist {}
5529 proc normalline {} {
5530 global thickerline
5531 if {[info exists thickerline]} {
5532 set id $thickerline
5533 unset thickerline
5534 drawlines $id
5538 proc selbyid {id} {
5539 global commitrow curview
5540 if {[info exists commitrow($curview,$id)]} {
5541 selectline $commitrow($curview,$id) 1
5545 proc mstime {} {
5546 global startmstime
5547 if {![info exists startmstime]} {
5548 set startmstime [clock clicks -milliseconds]
5550 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5553 proc rowmenu {x y id} {
5554 global rowctxmenu commitrow selectedline rowmenuid curview
5555 global nullid nullid2 fakerowmenu mainhead
5557 set rowmenuid $id
5558 if {![info exists selectedline]
5559 || $commitrow($curview,$id) eq $selectedline} {
5560 set state disabled
5561 } else {
5562 set state normal
5564 if {$id ne $nullid && $id ne $nullid2} {
5565 set menu $rowctxmenu
5566 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5567 } else {
5568 set menu $fakerowmenu
5570 $menu entryconfigure "Diff this*" -state $state
5571 $menu entryconfigure "Diff selected*" -state $state
5572 $menu entryconfigure "Make patch" -state $state
5573 tk_popup $menu $x $y
5576 proc diffvssel {dirn} {
5577 global rowmenuid selectedline displayorder
5579 if {![info exists selectedline]} return
5580 if {$dirn} {
5581 set oldid [lindex $displayorder $selectedline]
5582 set newid $rowmenuid
5583 } else {
5584 set oldid $rowmenuid
5585 set newid [lindex $displayorder $selectedline]
5587 addtohistory [list doseldiff $oldid $newid]
5588 doseldiff $oldid $newid
5591 proc doseldiff {oldid newid} {
5592 global ctext
5593 global commitinfo
5595 $ctext conf -state normal
5596 clear_ctext
5597 init_flist "Top"
5598 $ctext insert end "From "
5599 $ctext tag conf link -foreground blue -underline 1
5600 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5601 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5602 $ctext tag bind link0 <1> [list selbyid $oldid]
5603 $ctext insert end $oldid [list link link0]
5604 $ctext insert end "\n "
5605 $ctext insert end [lindex $commitinfo($oldid) 0]
5606 $ctext insert end "\n\nTo "
5607 $ctext tag bind link1 <1> [list selbyid $newid]
5608 $ctext insert end $newid [list link link1]
5609 $ctext insert end "\n "
5610 $ctext insert end [lindex $commitinfo($newid) 0]
5611 $ctext insert end "\n"
5612 $ctext conf -state disabled
5613 $ctext tag remove found 1.0 end
5614 startdiff [list $oldid $newid]
5617 proc mkpatch {} {
5618 global rowmenuid currentid commitinfo patchtop patchnum
5620 if {![info exists currentid]} return
5621 set oldid $currentid
5622 set oldhead [lindex $commitinfo($oldid) 0]
5623 set newid $rowmenuid
5624 set newhead [lindex $commitinfo($newid) 0]
5625 set top .patch
5626 set patchtop $top
5627 catch {destroy $top}
5628 toplevel $top
5629 label $top.title -text "Generate patch"
5630 grid $top.title - -pady 10
5631 label $top.from -text "From:"
5632 entry $top.fromsha1 -width 40 -relief flat
5633 $top.fromsha1 insert 0 $oldid
5634 $top.fromsha1 conf -state readonly
5635 grid $top.from $top.fromsha1 -sticky w
5636 entry $top.fromhead -width 60 -relief flat
5637 $top.fromhead insert 0 $oldhead
5638 $top.fromhead conf -state readonly
5639 grid x $top.fromhead -sticky w
5640 label $top.to -text "To:"
5641 entry $top.tosha1 -width 40 -relief flat
5642 $top.tosha1 insert 0 $newid
5643 $top.tosha1 conf -state readonly
5644 grid $top.to $top.tosha1 -sticky w
5645 entry $top.tohead -width 60 -relief flat
5646 $top.tohead insert 0 $newhead
5647 $top.tohead conf -state readonly
5648 grid x $top.tohead -sticky w
5649 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5650 grid $top.rev x -pady 10
5651 label $top.flab -text "Output file:"
5652 entry $top.fname -width 60
5653 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5654 incr patchnum
5655 grid $top.flab $top.fname -sticky w
5656 frame $top.buts
5657 button $top.buts.gen -text "Generate" -command mkpatchgo
5658 button $top.buts.can -text "Cancel" -command mkpatchcan
5659 grid $top.buts.gen $top.buts.can
5660 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5661 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5662 grid $top.buts - -pady 10 -sticky ew
5663 focus $top.fname
5666 proc mkpatchrev {} {
5667 global patchtop
5669 set oldid [$patchtop.fromsha1 get]
5670 set oldhead [$patchtop.fromhead get]
5671 set newid [$patchtop.tosha1 get]
5672 set newhead [$patchtop.tohead get]
5673 foreach e [list fromsha1 fromhead tosha1 tohead] \
5674 v [list $newid $newhead $oldid $oldhead] {
5675 $patchtop.$e conf -state normal
5676 $patchtop.$e delete 0 end
5677 $patchtop.$e insert 0 $v
5678 $patchtop.$e conf -state readonly
5682 proc mkpatchgo {} {
5683 global patchtop nullid nullid2
5685 set oldid [$patchtop.fromsha1 get]
5686 set newid [$patchtop.tosha1 get]
5687 set fname [$patchtop.fname get]
5688 set cmd [diffcmd [list $oldid $newid] -p]
5689 lappend cmd >$fname &
5690 if {[catch {eval exec $cmd} err]} {
5691 error_popup "Error creating patch: $err"
5693 catch {destroy $patchtop}
5694 unset patchtop
5697 proc mkpatchcan {} {
5698 global patchtop
5700 catch {destroy $patchtop}
5701 unset patchtop
5704 proc mktag {} {
5705 global rowmenuid mktagtop commitinfo
5707 set top .maketag
5708 set mktagtop $top
5709 catch {destroy $top}
5710 toplevel $top
5711 label $top.title -text "Create tag"
5712 grid $top.title - -pady 10
5713 label $top.id -text "ID:"
5714 entry $top.sha1 -width 40 -relief flat
5715 $top.sha1 insert 0 $rowmenuid
5716 $top.sha1 conf -state readonly
5717 grid $top.id $top.sha1 -sticky w
5718 entry $top.head -width 60 -relief flat
5719 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5720 $top.head conf -state readonly
5721 grid x $top.head -sticky w
5722 label $top.tlab -text "Tag name:"
5723 entry $top.tag -width 60
5724 grid $top.tlab $top.tag -sticky w
5725 frame $top.buts
5726 button $top.buts.gen -text "Create" -command mktaggo
5727 button $top.buts.can -text "Cancel" -command mktagcan
5728 grid $top.buts.gen $top.buts.can
5729 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5730 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5731 grid $top.buts - -pady 10 -sticky ew
5732 focus $top.tag
5735 proc domktag {} {
5736 global mktagtop env tagids idtags
5738 set id [$mktagtop.sha1 get]
5739 set tag [$mktagtop.tag get]
5740 if {$tag == {}} {
5741 error_popup "No tag name specified"
5742 return
5744 if {[info exists tagids($tag)]} {
5745 error_popup "Tag \"$tag\" already exists"
5746 return
5748 if {[catch {
5749 set dir [gitdir]
5750 set fname [file join $dir "refs/tags" $tag]
5751 set f [open $fname w]
5752 puts $f $id
5753 close $f
5754 } err]} {
5755 error_popup "Error creating tag: $err"
5756 return
5759 set tagids($tag) $id
5760 lappend idtags($id) $tag
5761 redrawtags $id
5762 addedtag $id
5765 proc redrawtags {id} {
5766 global canv linehtag commitrow idpos selectedline curview
5767 global mainfont canvxmax iddrawn
5769 if {![info exists commitrow($curview,$id)]} return
5770 if {![info exists iddrawn($id)]} return
5771 drawcommits $commitrow($curview,$id)
5772 $canv delete tag.$id
5773 set xt [eval drawtags $id $idpos($id)]
5774 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5775 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5776 set xr [expr {$xt + [font measure $mainfont $text]}]
5777 if {$xr > $canvxmax} {
5778 set canvxmax $xr
5779 setcanvscroll
5781 if {[info exists selectedline]
5782 && $selectedline == $commitrow($curview,$id)} {
5783 selectline $selectedline 0
5787 proc mktagcan {} {
5788 global mktagtop
5790 catch {destroy $mktagtop}
5791 unset mktagtop
5794 proc mktaggo {} {
5795 domktag
5796 mktagcan
5799 proc writecommit {} {
5800 global rowmenuid wrcomtop commitinfo wrcomcmd
5802 set top .writecommit
5803 set wrcomtop $top
5804 catch {destroy $top}
5805 toplevel $top
5806 label $top.title -text "Write commit to file"
5807 grid $top.title - -pady 10
5808 label $top.id -text "ID:"
5809 entry $top.sha1 -width 40 -relief flat
5810 $top.sha1 insert 0 $rowmenuid
5811 $top.sha1 conf -state readonly
5812 grid $top.id $top.sha1 -sticky w
5813 entry $top.head -width 60 -relief flat
5814 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5815 $top.head conf -state readonly
5816 grid x $top.head -sticky w
5817 label $top.clab -text "Command:"
5818 entry $top.cmd -width 60 -textvariable wrcomcmd
5819 grid $top.clab $top.cmd -sticky w -pady 10
5820 label $top.flab -text "Output file:"
5821 entry $top.fname -width 60
5822 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5823 grid $top.flab $top.fname -sticky w
5824 frame $top.buts
5825 button $top.buts.gen -text "Write" -command wrcomgo
5826 button $top.buts.can -text "Cancel" -command wrcomcan
5827 grid $top.buts.gen $top.buts.can
5828 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5829 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5830 grid $top.buts - -pady 10 -sticky ew
5831 focus $top.fname
5834 proc wrcomgo {} {
5835 global wrcomtop
5837 set id [$wrcomtop.sha1 get]
5838 set cmd "echo $id | [$wrcomtop.cmd get]"
5839 set fname [$wrcomtop.fname get]
5840 if {[catch {exec sh -c $cmd >$fname &} err]} {
5841 error_popup "Error writing commit: $err"
5843 catch {destroy $wrcomtop}
5844 unset wrcomtop
5847 proc wrcomcan {} {
5848 global wrcomtop
5850 catch {destroy $wrcomtop}
5851 unset wrcomtop
5854 proc mkbranch {} {
5855 global rowmenuid mkbrtop
5857 set top .makebranch
5858 catch {destroy $top}
5859 toplevel $top
5860 label $top.title -text "Create new branch"
5861 grid $top.title - -pady 10
5862 label $top.id -text "ID:"
5863 entry $top.sha1 -width 40 -relief flat
5864 $top.sha1 insert 0 $rowmenuid
5865 $top.sha1 conf -state readonly
5866 grid $top.id $top.sha1 -sticky w
5867 label $top.nlab -text "Name:"
5868 entry $top.name -width 40
5869 grid $top.nlab $top.name -sticky w
5870 frame $top.buts
5871 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5872 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5873 grid $top.buts.go $top.buts.can
5874 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5875 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5876 grid $top.buts - -pady 10 -sticky ew
5877 focus $top.name
5880 proc mkbrgo {top} {
5881 global headids idheads
5883 set name [$top.name get]
5884 set id [$top.sha1 get]
5885 if {$name eq {}} {
5886 error_popup "Please specify a name for the new branch"
5887 return
5889 catch {destroy $top}
5890 nowbusy newbranch
5891 update
5892 if {[catch {
5893 exec git branch $name $id
5894 } err]} {
5895 notbusy newbranch
5896 error_popup $err
5897 } else {
5898 set headids($name) $id
5899 lappend idheads($id) $name
5900 addedhead $id $name
5901 notbusy newbranch
5902 redrawtags $id
5903 dispneartags 0
5907 proc cherrypick {} {
5908 global rowmenuid curview commitrow
5909 global mainhead
5911 set oldhead [exec git rev-parse HEAD]
5912 set dheads [descheads $rowmenuid]
5913 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5914 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5915 included in branch $mainhead -- really re-apply it?"]
5916 if {!$ok} return
5918 nowbusy cherrypick
5919 update
5920 # Unfortunately git-cherry-pick writes stuff to stderr even when
5921 # no error occurs, and exec takes that as an indication of error...
5922 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5923 notbusy cherrypick
5924 error_popup $err
5925 return
5927 set newhead [exec git rev-parse HEAD]
5928 if {$newhead eq $oldhead} {
5929 notbusy cherrypick
5930 error_popup "No changes committed"
5931 return
5933 addnewchild $newhead $oldhead
5934 if {[info exists commitrow($curview,$oldhead)]} {
5935 insertrow $commitrow($curview,$oldhead) $newhead
5936 if {$mainhead ne {}} {
5937 movehead $newhead $mainhead
5938 movedhead $newhead $mainhead
5940 redrawtags $oldhead
5941 redrawtags $newhead
5943 notbusy cherrypick
5946 proc resethead {} {
5947 global mainheadid mainhead rowmenuid confirm_ok resettype
5948 global showlocalchanges
5950 set confirm_ok 0
5951 set w ".confirmreset"
5952 toplevel $w
5953 wm transient $w .
5954 wm title $w "Confirm reset"
5955 message $w.m -text \
5956 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
5957 -justify center -aspect 1000
5958 pack $w.m -side top -fill x -padx 20 -pady 20
5959 frame $w.f -relief sunken -border 2
5960 message $w.f.rt -text "Reset type:" -aspect 1000
5961 grid $w.f.rt -sticky w
5962 set resettype mixed
5963 radiobutton $w.f.soft -value soft -variable resettype -justify left \
5964 -text "Soft: Leave working tree and index untouched"
5965 grid $w.f.soft -sticky w
5966 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
5967 -text "Mixed: Leave working tree untouched, reset index"
5968 grid $w.f.mixed -sticky w
5969 radiobutton $w.f.hard -value hard -variable resettype -justify left \
5970 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
5971 grid $w.f.hard -sticky w
5972 pack $w.f -side top -fill x
5973 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
5974 pack $w.ok -side left -fill x -padx 20 -pady 20
5975 button $w.cancel -text Cancel -command "destroy $w"
5976 pack $w.cancel -side right -fill x -padx 20 -pady 20
5977 bind $w <Visibility> "grab $w; focus $w"
5978 tkwait window $w
5979 if {!$confirm_ok} return
5980 if {[catch {set fd [open \
5981 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
5982 error_popup $err
5983 } else {
5984 dohidelocalchanges
5985 set w ".resetprogress"
5986 filerun $fd [list readresetstat $fd $w]
5987 toplevel $w
5988 wm transient $w
5989 wm title $w "Reset progress"
5990 message $w.m -text "Reset in progress, please wait..." \
5991 -justify center -aspect 1000
5992 pack $w.m -side top -fill x -padx 20 -pady 5
5993 canvas $w.c -width 150 -height 20 -bg white
5994 $w.c create rect 0 0 0 20 -fill green -tags rect
5995 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
5996 nowbusy reset
6000 proc readresetstat {fd w} {
6001 global mainhead mainheadid showlocalchanges
6003 if {[gets $fd line] >= 0} {
6004 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6005 set x [expr {($m * 150) / $n}]
6006 $w.c coords rect 0 0 $x 20
6008 return 1
6010 destroy $w
6011 notbusy reset
6012 if {[catch {close $fd} err]} {
6013 error_popup $err
6015 set oldhead $mainheadid
6016 set newhead [exec git rev-parse HEAD]
6017 if {$newhead ne $oldhead} {
6018 movehead $newhead $mainhead
6019 movedhead $newhead $mainhead
6020 set mainheadid $newhead
6021 redrawtags $oldhead
6022 redrawtags $newhead
6024 if {$showlocalchanges} {
6025 doshowlocalchanges
6027 return 0
6030 # context menu for a head
6031 proc headmenu {x y id head} {
6032 global headmenuid headmenuhead headctxmenu mainhead
6034 set headmenuid $id
6035 set headmenuhead $head
6036 set state normal
6037 if {$head eq $mainhead} {
6038 set state disabled
6040 $headctxmenu entryconfigure 0 -state $state
6041 $headctxmenu entryconfigure 1 -state $state
6042 tk_popup $headctxmenu $x $y
6045 proc cobranch {} {
6046 global headmenuid headmenuhead mainhead headids
6047 global showlocalchanges mainheadid
6049 # check the tree is clean first??
6050 set oldmainhead $mainhead
6051 nowbusy checkout
6052 update
6053 dohidelocalchanges
6054 if {[catch {
6055 exec git checkout -q $headmenuhead
6056 } err]} {
6057 notbusy checkout
6058 error_popup $err
6059 } else {
6060 notbusy checkout
6061 set mainhead $headmenuhead
6062 set mainheadid $headmenuid
6063 if {[info exists headids($oldmainhead)]} {
6064 redrawtags $headids($oldmainhead)
6066 redrawtags $headmenuid
6068 if {$showlocalchanges} {
6069 dodiffindex
6073 proc rmbranch {} {
6074 global headmenuid headmenuhead mainhead
6075 global headids idheads
6077 set head $headmenuhead
6078 set id $headmenuid
6079 # this check shouldn't be needed any more...
6080 if {$head eq $mainhead} {
6081 error_popup "Cannot delete the currently checked-out branch"
6082 return
6084 set dheads [descheads $id]
6085 if {$dheads eq $headids($head)} {
6086 # the stuff on this branch isn't on any other branch
6087 if {![confirm_popup "The commits on branch $head aren't on any other\
6088 branch.\nReally delete branch $head?"]} return
6090 nowbusy rmbranch
6091 update
6092 if {[catch {exec git branch -D $head} err]} {
6093 notbusy rmbranch
6094 error_popup $err
6095 return
6097 removehead $id $head
6098 removedhead $id $head
6099 redrawtags $id
6100 notbusy rmbranch
6101 dispneartags 0
6104 # Stuff for finding nearby tags
6105 proc getallcommits {} {
6106 global allcommits allids nbmp nextarc seeds
6108 set allids {}
6109 set nbmp 0
6110 set nextarc 0
6111 set allcommits 0
6112 set seeds {}
6113 regetallcommits
6116 # Called when the graph might have changed
6117 proc regetallcommits {} {
6118 global allcommits seeds
6120 set cmd [concat | git rev-list --all --parents]
6121 foreach id $seeds {
6122 lappend cmd "^$id"
6124 set fd [open $cmd r]
6125 fconfigure $fd -blocking 0
6126 incr allcommits
6127 nowbusy allcommits
6128 filerun $fd [list getallclines $fd]
6131 # Since most commits have 1 parent and 1 child, we group strings of
6132 # such commits into "arcs" joining branch/merge points (BMPs), which
6133 # are commits that either don't have 1 parent or don't have 1 child.
6135 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6136 # arcout(id) - outgoing arcs for BMP
6137 # arcids(a) - list of IDs on arc including end but not start
6138 # arcstart(a) - BMP ID at start of arc
6139 # arcend(a) - BMP ID at end of arc
6140 # growing(a) - arc a is still growing
6141 # arctags(a) - IDs out of arcids (excluding end) that have tags
6142 # archeads(a) - IDs out of arcids (excluding end) that have heads
6143 # The start of an arc is at the descendent end, so "incoming" means
6144 # coming from descendents, and "outgoing" means going towards ancestors.
6146 proc getallclines {fd} {
6147 global allids allparents allchildren idtags idheads nextarc nbmp
6148 global arcnos arcids arctags arcout arcend arcstart archeads growing
6149 global seeds allcommits
6151 set nid 0
6152 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6153 set id [lindex $line 0]
6154 if {[info exists allparents($id)]} {
6155 # seen it already
6156 continue
6158 lappend allids $id
6159 set olds [lrange $line 1 end]
6160 set allparents($id) $olds
6161 if {![info exists allchildren($id)]} {
6162 set allchildren($id) {}
6163 set arcnos($id) {}
6164 lappend seeds $id
6165 } else {
6166 set a $arcnos($id)
6167 if {[llength $olds] == 1 && [llength $a] == 1} {
6168 lappend arcids($a) $id
6169 if {[info exists idtags($id)]} {
6170 lappend arctags($a) $id
6172 if {[info exists idheads($id)]} {
6173 lappend archeads($a) $id
6175 if {[info exists allparents($olds)]} {
6176 # seen parent already
6177 if {![info exists arcout($olds)]} {
6178 splitarc $olds
6180 lappend arcids($a) $olds
6181 set arcend($a) $olds
6182 unset growing($a)
6184 lappend allchildren($olds) $id
6185 lappend arcnos($olds) $a
6186 continue
6189 incr nbmp
6190 foreach a $arcnos($id) {
6191 lappend arcids($a) $id
6192 set arcend($a) $id
6193 unset growing($a)
6196 set ao {}
6197 foreach p $olds {
6198 lappend allchildren($p) $id
6199 set a [incr nextarc]
6200 set arcstart($a) $id
6201 set archeads($a) {}
6202 set arctags($a) {}
6203 set archeads($a) {}
6204 set arcids($a) {}
6205 lappend ao $a
6206 set growing($a) 1
6207 if {[info exists allparents($p)]} {
6208 # seen it already, may need to make a new branch
6209 if {![info exists arcout($p)]} {
6210 splitarc $p
6212 lappend arcids($a) $p
6213 set arcend($a) $p
6214 unset growing($a)
6216 lappend arcnos($p) $a
6218 set arcout($id) $ao
6220 if {$nid > 0} {
6221 global cached_dheads cached_dtags cached_atags
6222 catch {unset cached_dheads}
6223 catch {unset cached_dtags}
6224 catch {unset cached_atags}
6226 if {![eof $fd]} {
6227 return [expr {$nid >= 1000? 2: 1}]
6229 close $fd
6230 if {[incr allcommits -1] == 0} {
6231 notbusy allcommits
6233 dispneartags 0
6234 return 0
6237 proc recalcarc {a} {
6238 global arctags archeads arcids idtags idheads
6240 set at {}
6241 set ah {}
6242 foreach id [lrange $arcids($a) 0 end-1] {
6243 if {[info exists idtags($id)]} {
6244 lappend at $id
6246 if {[info exists idheads($id)]} {
6247 lappend ah $id
6250 set arctags($a) $at
6251 set archeads($a) $ah
6254 proc splitarc {p} {
6255 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6256 global arcstart arcend arcout allparents growing
6258 set a $arcnos($p)
6259 if {[llength $a] != 1} {
6260 puts "oops splitarc called but [llength $a] arcs already"
6261 return
6263 set a [lindex $a 0]
6264 set i [lsearch -exact $arcids($a) $p]
6265 if {$i < 0} {
6266 puts "oops splitarc $p not in arc $a"
6267 return
6269 set na [incr nextarc]
6270 if {[info exists arcend($a)]} {
6271 set arcend($na) $arcend($a)
6272 } else {
6273 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6274 set j [lsearch -exact $arcnos($l) $a]
6275 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6277 set tail [lrange $arcids($a) [expr {$i+1}] end]
6278 set arcids($a) [lrange $arcids($a) 0 $i]
6279 set arcend($a) $p
6280 set arcstart($na) $p
6281 set arcout($p) $na
6282 set arcids($na) $tail
6283 if {[info exists growing($a)]} {
6284 set growing($na) 1
6285 unset growing($a)
6287 incr nbmp
6289 foreach id $tail {
6290 if {[llength $arcnos($id)] == 1} {
6291 set arcnos($id) $na
6292 } else {
6293 set j [lsearch -exact $arcnos($id) $a]
6294 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6298 # reconstruct tags and heads lists
6299 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6300 recalcarc $a
6301 recalcarc $na
6302 } else {
6303 set arctags($na) {}
6304 set archeads($na) {}
6308 # Update things for a new commit added that is a child of one
6309 # existing commit. Used when cherry-picking.
6310 proc addnewchild {id p} {
6311 global allids allparents allchildren idtags nextarc nbmp
6312 global arcnos arcids arctags arcout arcend arcstart archeads growing
6313 global seeds
6315 lappend allids $id
6316 set allparents($id) [list $p]
6317 set allchildren($id) {}
6318 set arcnos($id) {}
6319 lappend seeds $id
6320 incr nbmp
6321 lappend allchildren($p) $id
6322 set a [incr nextarc]
6323 set arcstart($a) $id
6324 set archeads($a) {}
6325 set arctags($a) {}
6326 set arcids($a) [list $p]
6327 set arcend($a) $p
6328 if {![info exists arcout($p)]} {
6329 splitarc $p
6331 lappend arcnos($p) $a
6332 set arcout($id) [list $a]
6335 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6336 # or 0 if neither is true.
6337 proc anc_or_desc {a b} {
6338 global arcout arcstart arcend arcnos cached_isanc
6340 if {$arcnos($a) eq $arcnos($b)} {
6341 # Both are on the same arc(s); either both are the same BMP,
6342 # or if one is not a BMP, the other is also not a BMP or is
6343 # the BMP at end of the arc (and it only has 1 incoming arc).
6344 # Or both can be BMPs with no incoming arcs.
6345 if {$a eq $b || $arcnos($a) eq {}} {
6346 return 0
6348 # assert {[llength $arcnos($a)] == 1}
6349 set arc [lindex $arcnos($a) 0]
6350 set i [lsearch -exact $arcids($arc) $a]
6351 set j [lsearch -exact $arcids($arc) $b]
6352 if {$i < 0 || $i > $j} {
6353 return 1
6354 } else {
6355 return -1
6359 if {![info exists arcout($a)]} {
6360 set arc [lindex $arcnos($a) 0]
6361 if {[info exists arcend($arc)]} {
6362 set aend $arcend($arc)
6363 } else {
6364 set aend {}
6366 set a $arcstart($arc)
6367 } else {
6368 set aend $a
6370 if {![info exists arcout($b)]} {
6371 set arc [lindex $arcnos($b) 0]
6372 if {[info exists arcend($arc)]} {
6373 set bend $arcend($arc)
6374 } else {
6375 set bend {}
6377 set b $arcstart($arc)
6378 } else {
6379 set bend $b
6381 if {$a eq $bend} {
6382 return 1
6384 if {$b eq $aend} {
6385 return -1
6387 if {[info exists cached_isanc($a,$bend)]} {
6388 if {$cached_isanc($a,$bend)} {
6389 return 1
6392 if {[info exists cached_isanc($b,$aend)]} {
6393 if {$cached_isanc($b,$aend)} {
6394 return -1
6396 if {[info exists cached_isanc($a,$bend)]} {
6397 return 0
6401 set todo [list $a $b]
6402 set anc($a) a
6403 set anc($b) b
6404 for {set i 0} {$i < [llength $todo]} {incr i} {
6405 set x [lindex $todo $i]
6406 if {$anc($x) eq {}} {
6407 continue
6409 foreach arc $arcnos($x) {
6410 set xd $arcstart($arc)
6411 if {$xd eq $bend} {
6412 set cached_isanc($a,$bend) 1
6413 set cached_isanc($b,$aend) 0
6414 return 1
6415 } elseif {$xd eq $aend} {
6416 set cached_isanc($b,$aend) 1
6417 set cached_isanc($a,$bend) 0
6418 return -1
6420 if {![info exists anc($xd)]} {
6421 set anc($xd) $anc($x)
6422 lappend todo $xd
6423 } elseif {$anc($xd) ne $anc($x)} {
6424 set anc($xd) {}
6428 set cached_isanc($a,$bend) 0
6429 set cached_isanc($b,$aend) 0
6430 return 0
6433 # This identifies whether $desc has an ancestor that is
6434 # a growing tip of the graph and which is not an ancestor of $anc
6435 # and returns 0 if so and 1 if not.
6436 # If we subsequently discover a tag on such a growing tip, and that
6437 # turns out to be a descendent of $anc (which it could, since we
6438 # don't necessarily see children before parents), then $desc
6439 # isn't a good choice to display as a descendent tag of
6440 # $anc (since it is the descendent of another tag which is
6441 # a descendent of $anc). Similarly, $anc isn't a good choice to
6442 # display as a ancestor tag of $desc.
6444 proc is_certain {desc anc} {
6445 global arcnos arcout arcstart arcend growing problems
6447 set certain {}
6448 if {[llength $arcnos($anc)] == 1} {
6449 # tags on the same arc are certain
6450 if {$arcnos($desc) eq $arcnos($anc)} {
6451 return 1
6453 if {![info exists arcout($anc)]} {
6454 # if $anc is partway along an arc, use the start of the arc instead
6455 set a [lindex $arcnos($anc) 0]
6456 set anc $arcstart($a)
6459 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6460 set x $desc
6461 } else {
6462 set a [lindex $arcnos($desc) 0]
6463 set x $arcend($a)
6465 if {$x == $anc} {
6466 return 1
6468 set anclist [list $x]
6469 set dl($x) 1
6470 set nnh 1
6471 set ngrowanc 0
6472 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6473 set x [lindex $anclist $i]
6474 if {$dl($x)} {
6475 incr nnh -1
6477 set done($x) 1
6478 foreach a $arcout($x) {
6479 if {[info exists growing($a)]} {
6480 if {![info exists growanc($x)] && $dl($x)} {
6481 set growanc($x) 1
6482 incr ngrowanc
6484 } else {
6485 set y $arcend($a)
6486 if {[info exists dl($y)]} {
6487 if {$dl($y)} {
6488 if {!$dl($x)} {
6489 set dl($y) 0
6490 if {![info exists done($y)]} {
6491 incr nnh -1
6493 if {[info exists growanc($x)]} {
6494 incr ngrowanc -1
6496 set xl [list $y]
6497 for {set k 0} {$k < [llength $xl]} {incr k} {
6498 set z [lindex $xl $k]
6499 foreach c $arcout($z) {
6500 if {[info exists arcend($c)]} {
6501 set v $arcend($c)
6502 if {[info exists dl($v)] && $dl($v)} {
6503 set dl($v) 0
6504 if {![info exists done($v)]} {
6505 incr nnh -1
6507 if {[info exists growanc($v)]} {
6508 incr ngrowanc -1
6510 lappend xl $v
6517 } elseif {$y eq $anc || !$dl($x)} {
6518 set dl($y) 0
6519 lappend anclist $y
6520 } else {
6521 set dl($y) 1
6522 lappend anclist $y
6523 incr nnh
6528 foreach x [array names growanc] {
6529 if {$dl($x)} {
6530 return 0
6532 return 0
6534 return 1
6537 proc validate_arctags {a} {
6538 global arctags idtags
6540 set i -1
6541 set na $arctags($a)
6542 foreach id $arctags($a) {
6543 incr i
6544 if {![info exists idtags($id)]} {
6545 set na [lreplace $na $i $i]
6546 incr i -1
6549 set arctags($a) $na
6552 proc validate_archeads {a} {
6553 global archeads idheads
6555 set i -1
6556 set na $archeads($a)
6557 foreach id $archeads($a) {
6558 incr i
6559 if {![info exists idheads($id)]} {
6560 set na [lreplace $na $i $i]
6561 incr i -1
6564 set archeads($a) $na
6567 # Return the list of IDs that have tags that are descendents of id,
6568 # ignoring IDs that are descendents of IDs already reported.
6569 proc desctags {id} {
6570 global arcnos arcstart arcids arctags idtags allparents
6571 global growing cached_dtags
6573 if {![info exists allparents($id)]} {
6574 return {}
6576 set t1 [clock clicks -milliseconds]
6577 set argid $id
6578 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6579 # part-way along an arc; check that arc first
6580 set a [lindex $arcnos($id) 0]
6581 if {$arctags($a) ne {}} {
6582 validate_arctags $a
6583 set i [lsearch -exact $arcids($a) $id]
6584 set tid {}
6585 foreach t $arctags($a) {
6586 set j [lsearch -exact $arcids($a) $t]
6587 if {$j >= $i} break
6588 set tid $t
6590 if {$tid ne {}} {
6591 return $tid
6594 set id $arcstart($a)
6595 if {[info exists idtags($id)]} {
6596 return $id
6599 if {[info exists cached_dtags($id)]} {
6600 return $cached_dtags($id)
6603 set origid $id
6604 set todo [list $id]
6605 set queued($id) 1
6606 set nc 1
6607 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6608 set id [lindex $todo $i]
6609 set done($id) 1
6610 set ta [info exists hastaggedancestor($id)]
6611 if {!$ta} {
6612 incr nc -1
6614 # ignore tags on starting node
6615 if {!$ta && $i > 0} {
6616 if {[info exists idtags($id)]} {
6617 set tagloc($id) $id
6618 set ta 1
6619 } elseif {[info exists cached_dtags($id)]} {
6620 set tagloc($id) $cached_dtags($id)
6621 set ta 1
6624 foreach a $arcnos($id) {
6625 set d $arcstart($a)
6626 if {!$ta && $arctags($a) ne {}} {
6627 validate_arctags $a
6628 if {$arctags($a) ne {}} {
6629 lappend tagloc($id) [lindex $arctags($a) end]
6632 if {$ta || $arctags($a) ne {}} {
6633 set tomark [list $d]
6634 for {set j 0} {$j < [llength $tomark]} {incr j} {
6635 set dd [lindex $tomark $j]
6636 if {![info exists hastaggedancestor($dd)]} {
6637 if {[info exists done($dd)]} {
6638 foreach b $arcnos($dd) {
6639 lappend tomark $arcstart($b)
6641 if {[info exists tagloc($dd)]} {
6642 unset tagloc($dd)
6644 } elseif {[info exists queued($dd)]} {
6645 incr nc -1
6647 set hastaggedancestor($dd) 1
6651 if {![info exists queued($d)]} {
6652 lappend todo $d
6653 set queued($d) 1
6654 if {![info exists hastaggedancestor($d)]} {
6655 incr nc
6660 set tags {}
6661 foreach id [array names tagloc] {
6662 if {![info exists hastaggedancestor($id)]} {
6663 foreach t $tagloc($id) {
6664 if {[lsearch -exact $tags $t] < 0} {
6665 lappend tags $t
6670 set t2 [clock clicks -milliseconds]
6671 set loopix $i
6673 # remove tags that are descendents of other tags
6674 for {set i 0} {$i < [llength $tags]} {incr i} {
6675 set a [lindex $tags $i]
6676 for {set j 0} {$j < $i} {incr j} {
6677 set b [lindex $tags $j]
6678 set r [anc_or_desc $a $b]
6679 if {$r == 1} {
6680 set tags [lreplace $tags $j $j]
6681 incr j -1
6682 incr i -1
6683 } elseif {$r == -1} {
6684 set tags [lreplace $tags $i $i]
6685 incr i -1
6686 break
6691 if {[array names growing] ne {}} {
6692 # graph isn't finished, need to check if any tag could get
6693 # eclipsed by another tag coming later. Simply ignore any
6694 # tags that could later get eclipsed.
6695 set ctags {}
6696 foreach t $tags {
6697 if {[is_certain $t $origid]} {
6698 lappend ctags $t
6701 if {$tags eq $ctags} {
6702 set cached_dtags($origid) $tags
6703 } else {
6704 set tags $ctags
6706 } else {
6707 set cached_dtags($origid) $tags
6709 set t3 [clock clicks -milliseconds]
6710 if {0 && $t3 - $t1 >= 100} {
6711 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6712 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6714 return $tags
6717 proc anctags {id} {
6718 global arcnos arcids arcout arcend arctags idtags allparents
6719 global growing cached_atags
6721 if {![info exists allparents($id)]} {
6722 return {}
6724 set t1 [clock clicks -milliseconds]
6725 set argid $id
6726 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6727 # part-way along an arc; check that arc first
6728 set a [lindex $arcnos($id) 0]
6729 if {$arctags($a) ne {}} {
6730 validate_arctags $a
6731 set i [lsearch -exact $arcids($a) $id]
6732 foreach t $arctags($a) {
6733 set j [lsearch -exact $arcids($a) $t]
6734 if {$j > $i} {
6735 return $t
6739 if {![info exists arcend($a)]} {
6740 return {}
6742 set id $arcend($a)
6743 if {[info exists idtags($id)]} {
6744 return $id
6747 if {[info exists cached_atags($id)]} {
6748 return $cached_atags($id)
6751 set origid $id
6752 set todo [list $id]
6753 set queued($id) 1
6754 set taglist {}
6755 set nc 1
6756 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6757 set id [lindex $todo $i]
6758 set done($id) 1
6759 set td [info exists hastaggeddescendent($id)]
6760 if {!$td} {
6761 incr nc -1
6763 # ignore tags on starting node
6764 if {!$td && $i > 0} {
6765 if {[info exists idtags($id)]} {
6766 set tagloc($id) $id
6767 set td 1
6768 } elseif {[info exists cached_atags($id)]} {
6769 set tagloc($id) $cached_atags($id)
6770 set td 1
6773 foreach a $arcout($id) {
6774 if {!$td && $arctags($a) ne {}} {
6775 validate_arctags $a
6776 if {$arctags($a) ne {}} {
6777 lappend tagloc($id) [lindex $arctags($a) 0]
6780 if {![info exists arcend($a)]} continue
6781 set d $arcend($a)
6782 if {$td || $arctags($a) ne {}} {
6783 set tomark [list $d]
6784 for {set j 0} {$j < [llength $tomark]} {incr j} {
6785 set dd [lindex $tomark $j]
6786 if {![info exists hastaggeddescendent($dd)]} {
6787 if {[info exists done($dd)]} {
6788 foreach b $arcout($dd) {
6789 if {[info exists arcend($b)]} {
6790 lappend tomark $arcend($b)
6793 if {[info exists tagloc($dd)]} {
6794 unset tagloc($dd)
6796 } elseif {[info exists queued($dd)]} {
6797 incr nc -1
6799 set hastaggeddescendent($dd) 1
6803 if {![info exists queued($d)]} {
6804 lappend todo $d
6805 set queued($d) 1
6806 if {![info exists hastaggeddescendent($d)]} {
6807 incr nc
6812 set t2 [clock clicks -milliseconds]
6813 set loopix $i
6814 set tags {}
6815 foreach id [array names tagloc] {
6816 if {![info exists hastaggeddescendent($id)]} {
6817 foreach t $tagloc($id) {
6818 if {[lsearch -exact $tags $t] < 0} {
6819 lappend tags $t
6825 # remove tags that are ancestors of other tags
6826 for {set i 0} {$i < [llength $tags]} {incr i} {
6827 set a [lindex $tags $i]
6828 for {set j 0} {$j < $i} {incr j} {
6829 set b [lindex $tags $j]
6830 set r [anc_or_desc $a $b]
6831 if {$r == -1} {
6832 set tags [lreplace $tags $j $j]
6833 incr j -1
6834 incr i -1
6835 } elseif {$r == 1} {
6836 set tags [lreplace $tags $i $i]
6837 incr i -1
6838 break
6843 if {[array names growing] ne {}} {
6844 # graph isn't finished, need to check if any tag could get
6845 # eclipsed by another tag coming later. Simply ignore any
6846 # tags that could later get eclipsed.
6847 set ctags {}
6848 foreach t $tags {
6849 if {[is_certain $origid $t]} {
6850 lappend ctags $t
6853 if {$tags eq $ctags} {
6854 set cached_atags($origid) $tags
6855 } else {
6856 set tags $ctags
6858 } else {
6859 set cached_atags($origid) $tags
6861 set t3 [clock clicks -milliseconds]
6862 if {0 && $t3 - $t1 >= 100} {
6863 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6864 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6866 return $tags
6869 # Return the list of IDs that have heads that are descendents of id,
6870 # including id itself if it has a head.
6871 proc descheads {id} {
6872 global arcnos arcstart arcids archeads idheads cached_dheads
6873 global allparents
6875 if {![info exists allparents($id)]} {
6876 return {}
6878 set aret {}
6879 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6880 # part-way along an arc; check it first
6881 set a [lindex $arcnos($id) 0]
6882 if {$archeads($a) ne {}} {
6883 validate_archeads $a
6884 set i [lsearch -exact $arcids($a) $id]
6885 foreach t $archeads($a) {
6886 set j [lsearch -exact $arcids($a) $t]
6887 if {$j > $i} break
6888 lappend aret $t
6891 set id $arcstart($a)
6893 set origid $id
6894 set todo [list $id]
6895 set seen($id) 1
6896 set ret {}
6897 for {set i 0} {$i < [llength $todo]} {incr i} {
6898 set id [lindex $todo $i]
6899 if {[info exists cached_dheads($id)]} {
6900 set ret [concat $ret $cached_dheads($id)]
6901 } else {
6902 if {[info exists idheads($id)]} {
6903 lappend ret $id
6905 foreach a $arcnos($id) {
6906 if {$archeads($a) ne {}} {
6907 validate_archeads $a
6908 if {$archeads($a) ne {}} {
6909 set ret [concat $ret $archeads($a)]
6912 set d $arcstart($a)
6913 if {![info exists seen($d)]} {
6914 lappend todo $d
6915 set seen($d) 1
6920 set ret [lsort -unique $ret]
6921 set cached_dheads($origid) $ret
6922 return [concat $ret $aret]
6925 proc addedtag {id} {
6926 global arcnos arcout cached_dtags cached_atags
6928 if {![info exists arcnos($id)]} return
6929 if {![info exists arcout($id)]} {
6930 recalcarc [lindex $arcnos($id) 0]
6932 catch {unset cached_dtags}
6933 catch {unset cached_atags}
6936 proc addedhead {hid head} {
6937 global arcnos arcout cached_dheads
6939 if {![info exists arcnos($hid)]} return
6940 if {![info exists arcout($hid)]} {
6941 recalcarc [lindex $arcnos($hid) 0]
6943 catch {unset cached_dheads}
6946 proc removedhead {hid head} {
6947 global cached_dheads
6949 catch {unset cached_dheads}
6952 proc movedhead {hid head} {
6953 global arcnos arcout cached_dheads
6955 if {![info exists arcnos($hid)]} return
6956 if {![info exists arcout($hid)]} {
6957 recalcarc [lindex $arcnos($hid) 0]
6959 catch {unset cached_dheads}
6962 proc changedrefs {} {
6963 global cached_dheads cached_dtags cached_atags
6964 global arctags archeads arcnos arcout idheads idtags
6966 foreach id [concat [array names idheads] [array names idtags]] {
6967 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6968 set a [lindex $arcnos($id) 0]
6969 if {![info exists donearc($a)]} {
6970 recalcarc $a
6971 set donearc($a) 1
6975 catch {unset cached_dtags}
6976 catch {unset cached_atags}
6977 catch {unset cached_dheads}
6980 proc rereadrefs {} {
6981 global idtags idheads idotherrefs mainhead
6983 set refids [concat [array names idtags] \
6984 [array names idheads] [array names idotherrefs]]
6985 foreach id $refids {
6986 if {![info exists ref($id)]} {
6987 set ref($id) [listrefs $id]
6990 set oldmainhead $mainhead
6991 readrefs
6992 changedrefs
6993 set refids [lsort -unique [concat $refids [array names idtags] \
6994 [array names idheads] [array names idotherrefs]]]
6995 foreach id $refids {
6996 set v [listrefs $id]
6997 if {![info exists ref($id)] || $ref($id) != $v ||
6998 ($id eq $oldmainhead && $id ne $mainhead) ||
6999 ($id eq $mainhead && $id ne $oldmainhead)} {
7000 redrawtags $id
7005 proc listrefs {id} {
7006 global idtags idheads idotherrefs
7008 set x {}
7009 if {[info exists idtags($id)]} {
7010 set x $idtags($id)
7012 set y {}
7013 if {[info exists idheads($id)]} {
7014 set y $idheads($id)
7016 set z {}
7017 if {[info exists idotherrefs($id)]} {
7018 set z $idotherrefs($id)
7020 return [list $x $y $z]
7023 proc showtag {tag isnew} {
7024 global ctext tagcontents tagids linknum tagobjid
7026 if {$isnew} {
7027 addtohistory [list showtag $tag 0]
7029 $ctext conf -state normal
7030 clear_ctext
7031 set linknum 0
7032 if {![info exists tagcontents($tag)]} {
7033 catch {
7034 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7037 if {[info exists tagcontents($tag)]} {
7038 set text $tagcontents($tag)
7039 } else {
7040 set text "Tag: $tag\nId: $tagids($tag)"
7042 appendwithlinks $text {}
7043 $ctext conf -state disabled
7044 init_flist {}
7047 proc doquit {} {
7048 global stopped
7049 set stopped 100
7050 savestuff .
7051 destroy .
7054 proc doprefs {} {
7055 global maxwidth maxgraphpct diffopts
7056 global oldprefs prefstop showneartags showlocalchanges
7057 global bgcolor fgcolor ctext diffcolors selectbgcolor
7058 global uifont tabstop
7060 set top .gitkprefs
7061 set prefstop $top
7062 if {[winfo exists $top]} {
7063 raise $top
7064 return
7066 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7067 set oldprefs($v) [set $v]
7069 toplevel $top
7070 wm title $top "Gitk preferences"
7071 label $top.ldisp -text "Commit list display options"
7072 $top.ldisp configure -font $uifont
7073 grid $top.ldisp - -sticky w -pady 10
7074 label $top.spacer -text " "
7075 label $top.maxwidthl -text "Maximum graph width (lines)" \
7076 -font optionfont
7077 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7078 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7079 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7080 -font optionfont
7081 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7082 grid x $top.maxpctl $top.maxpct -sticky w
7083 frame $top.showlocal
7084 label $top.showlocal.l -text "Show local changes" -font optionfont
7085 checkbutton $top.showlocal.b -variable showlocalchanges
7086 pack $top.showlocal.b $top.showlocal.l -side left
7087 grid x $top.showlocal -sticky w
7089 label $top.ddisp -text "Diff display options"
7090 $top.ddisp configure -font $uifont
7091 grid $top.ddisp - -sticky w -pady 10
7092 label $top.diffoptl -text "Options for diff program" \
7093 -font optionfont
7094 entry $top.diffopt -width 20 -textvariable diffopts
7095 grid x $top.diffoptl $top.diffopt -sticky w
7096 frame $top.ntag
7097 label $top.ntag.l -text "Display nearby tags" -font optionfont
7098 checkbutton $top.ntag.b -variable showneartags
7099 pack $top.ntag.b $top.ntag.l -side left
7100 grid x $top.ntag -sticky w
7101 label $top.tabstopl -text "tabstop" -font optionfont
7102 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7103 grid x $top.tabstopl $top.tabstop -sticky w
7105 label $top.cdisp -text "Colors: press to choose"
7106 $top.cdisp configure -font $uifont
7107 grid $top.cdisp - -sticky w -pady 10
7108 label $top.bg -padx 40 -relief sunk -background $bgcolor
7109 button $top.bgbut -text "Background" -font optionfont \
7110 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7111 grid x $top.bgbut $top.bg -sticky w
7112 label $top.fg -padx 40 -relief sunk -background $fgcolor
7113 button $top.fgbut -text "Foreground" -font optionfont \
7114 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7115 grid x $top.fgbut $top.fg -sticky w
7116 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7117 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7118 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7119 [list $ctext tag conf d0 -foreground]]
7120 grid x $top.diffoldbut $top.diffold -sticky w
7121 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7122 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7123 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7124 [list $ctext tag conf d1 -foreground]]
7125 grid x $top.diffnewbut $top.diffnew -sticky w
7126 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7127 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7128 -command [list choosecolor diffcolors 2 $top.hunksep \
7129 "diff hunk header" \
7130 [list $ctext tag conf hunksep -foreground]]
7131 grid x $top.hunksepbut $top.hunksep -sticky w
7132 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7133 button $top.selbgbut -text "Select bg" -font optionfont \
7134 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7135 grid x $top.selbgbut $top.selbgsep -sticky w
7137 frame $top.buts
7138 button $top.buts.ok -text "OK" -command prefsok -default active
7139 $top.buts.ok configure -font $uifont
7140 button $top.buts.can -text "Cancel" -command prefscan -default normal
7141 $top.buts.can configure -font $uifont
7142 grid $top.buts.ok $top.buts.can
7143 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7144 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7145 grid $top.buts - - -pady 10 -sticky ew
7146 bind $top <Visibility> "focus $top.buts.ok"
7149 proc choosecolor {v vi w x cmd} {
7150 global $v
7152 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7153 -title "Gitk: choose color for $x"]
7154 if {$c eq {}} return
7155 $w conf -background $c
7156 lset $v $vi $c
7157 eval $cmd $c
7160 proc setselbg {c} {
7161 global bglist cflist
7162 foreach w $bglist {
7163 $w configure -selectbackground $c
7165 $cflist tag configure highlight \
7166 -background [$cflist cget -selectbackground]
7167 allcanvs itemconf secsel -fill $c
7170 proc setbg {c} {
7171 global bglist
7173 foreach w $bglist {
7174 $w conf -background $c
7178 proc setfg {c} {
7179 global fglist canv
7181 foreach w $fglist {
7182 $w conf -foreground $c
7184 allcanvs itemconf text -fill $c
7185 $canv itemconf circle -outline $c
7188 proc prefscan {} {
7189 global maxwidth maxgraphpct diffopts
7190 global oldprefs prefstop showneartags showlocalchanges
7192 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7193 set $v $oldprefs($v)
7195 catch {destroy $prefstop}
7196 unset prefstop
7199 proc prefsok {} {
7200 global maxwidth maxgraphpct
7201 global oldprefs prefstop showneartags showlocalchanges
7202 global charspc ctext tabstop
7204 catch {destroy $prefstop}
7205 unset prefstop
7206 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7207 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7208 if {$showlocalchanges} {
7209 doshowlocalchanges
7210 } else {
7211 dohidelocalchanges
7214 if {$maxwidth != $oldprefs(maxwidth)
7215 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7216 redisplay
7217 } elseif {$showneartags != $oldprefs(showneartags)} {
7218 reselectline
7222 proc formatdate {d} {
7223 if {$d ne {}} {
7224 set d [clock format $d -format "%Y-%m-%d %H:%M:%S"]
7226 return $d
7229 # This list of encoding names and aliases is distilled from
7230 # http://www.iana.org/assignments/character-sets.
7231 # Not all of them are supported by Tcl.
7232 set encoding_aliases {
7233 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7234 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7235 { ISO-10646-UTF-1 csISO10646UTF1 }
7236 { ISO_646.basic:1983 ref csISO646basic1983 }
7237 { INVARIANT csINVARIANT }
7238 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7239 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7240 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7241 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7242 { NATS-DANO iso-ir-9-1 csNATSDANO }
7243 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7244 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7245 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7246 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7247 { ISO-2022-KR csISO2022KR }
7248 { EUC-KR csEUCKR }
7249 { ISO-2022-JP csISO2022JP }
7250 { ISO-2022-JP-2 csISO2022JP2 }
7251 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7252 csISO13JISC6220jp }
7253 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7254 { IT iso-ir-15 ISO646-IT csISO15Italian }
7255 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7256 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7257 { greek7-old iso-ir-18 csISO18Greek7Old }
7258 { latin-greek iso-ir-19 csISO19LatinGreek }
7259 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7260 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7261 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7262 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7263 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7264 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7265 { INIS iso-ir-49 csISO49INIS }
7266 { INIS-8 iso-ir-50 csISO50INIS8 }
7267 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7268 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7269 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7270 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7271 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7272 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7273 csISO60Norwegian1 }
7274 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7275 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7276 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7277 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7278 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7279 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7280 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7281 { greek7 iso-ir-88 csISO88Greek7 }
7282 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7283 { iso-ir-90 csISO90 }
7284 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7285 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7286 csISO92JISC62991984b }
7287 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7288 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7289 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7290 csISO95JIS62291984handadd }
7291 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7292 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7293 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7294 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7295 CP819 csISOLatin1 }
7296 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7297 { T.61-7bit iso-ir-102 csISO102T617bit }
7298 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7299 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7300 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7301 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7302 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7303 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7304 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7305 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7306 arabic csISOLatinArabic }
7307 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7308 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7309 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7310 greek greek8 csISOLatinGreek }
7311 { T.101-G2 iso-ir-128 csISO128T101G2 }
7312 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7313 csISOLatinHebrew }
7314 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7315 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7316 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7317 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7318 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7319 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7320 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7321 csISOLatinCyrillic }
7322 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7323 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7324 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7325 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7326 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7327 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7328 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7329 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7330 { ISO_10367-box iso-ir-155 csISO10367Box }
7331 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7332 { latin-lap lap iso-ir-158 csISO158Lap }
7333 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7334 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7335 { us-dk csUSDK }
7336 { dk-us csDKUS }
7337 { JIS_X0201 X0201 csHalfWidthKatakana }
7338 { KSC5636 ISO646-KR csKSC5636 }
7339 { ISO-10646-UCS-2 csUnicode }
7340 { ISO-10646-UCS-4 csUCS4 }
7341 { DEC-MCS dec csDECMCS }
7342 { hp-roman8 roman8 r8 csHPRoman8 }
7343 { macintosh mac csMacintosh }
7344 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7345 csIBM037 }
7346 { IBM038 EBCDIC-INT cp038 csIBM038 }
7347 { IBM273 CP273 csIBM273 }
7348 { IBM274 EBCDIC-BE CP274 csIBM274 }
7349 { IBM275 EBCDIC-BR cp275 csIBM275 }
7350 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7351 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7352 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7353 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7354 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7355 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7356 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7357 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7358 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7359 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7360 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7361 { IBM437 cp437 437 csPC8CodePage437 }
7362 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7363 { IBM775 cp775 csPC775Baltic }
7364 { IBM850 cp850 850 csPC850Multilingual }
7365 { IBM851 cp851 851 csIBM851 }
7366 { IBM852 cp852 852 csPCp852 }
7367 { IBM855 cp855 855 csIBM855 }
7368 { IBM857 cp857 857 csIBM857 }
7369 { IBM860 cp860 860 csIBM860 }
7370 { IBM861 cp861 861 cp-is csIBM861 }
7371 { IBM862 cp862 862 csPC862LatinHebrew }
7372 { IBM863 cp863 863 csIBM863 }
7373 { IBM864 cp864 csIBM864 }
7374 { IBM865 cp865 865 csIBM865 }
7375 { IBM866 cp866 866 csIBM866 }
7376 { IBM868 CP868 cp-ar csIBM868 }
7377 { IBM869 cp869 869 cp-gr csIBM869 }
7378 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7379 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7380 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7381 { IBM891 cp891 csIBM891 }
7382 { IBM903 cp903 csIBM903 }
7383 { IBM904 cp904 904 csIBBM904 }
7384 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7385 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7386 { IBM1026 CP1026 csIBM1026 }
7387 { EBCDIC-AT-DE csIBMEBCDICATDE }
7388 { EBCDIC-AT-DE-A csEBCDICATDEA }
7389 { EBCDIC-CA-FR csEBCDICCAFR }
7390 { EBCDIC-DK-NO csEBCDICDKNO }
7391 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7392 { EBCDIC-FI-SE csEBCDICFISE }
7393 { EBCDIC-FI-SE-A csEBCDICFISEA }
7394 { EBCDIC-FR csEBCDICFR }
7395 { EBCDIC-IT csEBCDICIT }
7396 { EBCDIC-PT csEBCDICPT }
7397 { EBCDIC-ES csEBCDICES }
7398 { EBCDIC-ES-A csEBCDICESA }
7399 { EBCDIC-ES-S csEBCDICESS }
7400 { EBCDIC-UK csEBCDICUK }
7401 { EBCDIC-US csEBCDICUS }
7402 { UNKNOWN-8BIT csUnknown8BiT }
7403 { MNEMONIC csMnemonic }
7404 { MNEM csMnem }
7405 { VISCII csVISCII }
7406 { VIQR csVIQR }
7407 { KOI8-R csKOI8R }
7408 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7409 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7410 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7411 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7412 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7413 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7414 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7415 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7416 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7417 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7418 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7419 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7420 { IBM1047 IBM-1047 }
7421 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7422 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7423 { UNICODE-1-1 csUnicode11 }
7424 { CESU-8 csCESU-8 }
7425 { BOCU-1 csBOCU-1 }
7426 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7427 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7428 l8 }
7429 { ISO-8859-15 ISO_8859-15 Latin-9 }
7430 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7431 { GBK CP936 MS936 windows-936 }
7432 { JIS_Encoding csJISEncoding }
7433 { Shift_JIS MS_Kanji csShiftJIS }
7434 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7435 EUC-JP }
7436 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7437 { ISO-10646-UCS-Basic csUnicodeASCII }
7438 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7439 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7440 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7441 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7442 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7443 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7444 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7445 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7446 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7447 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7448 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7449 { Ventura-US csVenturaUS }
7450 { Ventura-International csVenturaInternational }
7451 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7452 { PC8-Turkish csPC8Turkish }
7453 { IBM-Symbols csIBMSymbols }
7454 { IBM-Thai csIBMThai }
7455 { HP-Legal csHPLegal }
7456 { HP-Pi-font csHPPiFont }
7457 { HP-Math8 csHPMath8 }
7458 { Adobe-Symbol-Encoding csHPPSMath }
7459 { HP-DeskTop csHPDesktop }
7460 { Ventura-Math csVenturaMath }
7461 { Microsoft-Publishing csMicrosoftPublishing }
7462 { Windows-31J csWindows31J }
7463 { GB2312 csGB2312 }
7464 { Big5 csBig5 }
7467 proc tcl_encoding {enc} {
7468 global encoding_aliases
7469 set names [encoding names]
7470 set lcnames [string tolower $names]
7471 set enc [string tolower $enc]
7472 set i [lsearch -exact $lcnames $enc]
7473 if {$i < 0} {
7474 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7475 if {[regsub {^iso[-_]} $enc iso encx]} {
7476 set i [lsearch -exact $lcnames $encx]
7479 if {$i < 0} {
7480 foreach l $encoding_aliases {
7481 set ll [string tolower $l]
7482 if {[lsearch -exact $ll $enc] < 0} continue
7483 # look through the aliases for one that tcl knows about
7484 foreach e $ll {
7485 set i [lsearch -exact $lcnames $e]
7486 if {$i < 0} {
7487 if {[regsub {^iso[-_]} $e iso ex]} {
7488 set i [lsearch -exact $lcnames $ex]
7491 if {$i >= 0} break
7493 break
7496 if {$i >= 0} {
7497 return [lindex $names $i]
7499 return {}
7502 # defaults...
7503 set datemode 0
7504 set diffopts "-U 5 -p"
7505 set wrcomcmd "git diff-tree --stdin -p --pretty"
7507 set gitencoding {}
7508 catch {
7509 set gitencoding [exec git config --get i18n.commitencoding]
7511 if {$gitencoding == ""} {
7512 set gitencoding "utf-8"
7514 set tclencoding [tcl_encoding $gitencoding]
7515 if {$tclencoding == {}} {
7516 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7519 set mainfont {Helvetica 9}
7520 set textfont {Courier 9}
7521 set uifont {Helvetica 9 bold}
7522 set tabstop 8
7523 set findmergefiles 0
7524 set maxgraphpct 50
7525 set maxwidth 16
7526 set revlistorder 0
7527 set fastdate 0
7528 set uparrowlen 7
7529 set downarrowlen 7
7530 set mingaplen 30
7531 set cmitmode "patch"
7532 set wrapcomment "none"
7533 set showneartags 1
7534 set maxrefs 20
7535 set maxlinelen 200
7536 set showlocalchanges 1
7538 set colors {green red blue magenta darkgrey brown orange}
7539 set bgcolor white
7540 set fgcolor black
7541 set diffcolors {red "#00a000" blue}
7542 set selectbgcolor gray85
7544 catch {source ~/.gitk}
7546 font create optionfont -family sans-serif -size -12
7548 # check that we can find a .git directory somewhere...
7549 set gitdir [gitdir]
7550 if {![file isdirectory $gitdir]} {
7551 show_error {} . "Cannot find the git directory \"$gitdir\"."
7552 exit 1
7555 set revtreeargs {}
7556 set cmdline_files {}
7557 set i 0
7558 foreach arg $argv {
7559 switch -- $arg {
7560 "" { }
7561 "-d" { set datemode 1 }
7562 "--" {
7563 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7564 break
7566 default {
7567 lappend revtreeargs $arg
7570 incr i
7573 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7574 # no -- on command line, but some arguments (other than -d)
7575 if {[catch {
7576 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7577 set cmdline_files [split $f "\n"]
7578 set n [llength $cmdline_files]
7579 set revtreeargs [lrange $revtreeargs 0 end-$n]
7580 # Unfortunately git rev-parse doesn't produce an error when
7581 # something is both a revision and a filename. To be consistent
7582 # with git log and git rev-list, check revtreeargs for filenames.
7583 foreach arg $revtreeargs {
7584 if {[file exists $arg]} {
7585 show_error {} . "Ambiguous argument '$arg': both revision\
7586 and filename"
7587 exit 1
7590 } err]} {
7591 # unfortunately we get both stdout and stderr in $err,
7592 # so look for "fatal:".
7593 set i [string first "fatal:" $err]
7594 if {$i > 0} {
7595 set err [string range $err [expr {$i + 6}] end]
7597 show_error {} . "Bad arguments to gitk:\n$err"
7598 exit 1
7602 set nullid "0000000000000000000000000000000000000000"
7603 set nullid2 "0000000000000000000000000000000000000001"
7606 set runq {}
7607 set history {}
7608 set historyindex 0
7609 set fh_serial 0
7610 set nhl_names {}
7611 set highlight_paths {}
7612 set searchdirn -forwards
7613 set boldrows {}
7614 set boldnamerows {}
7615 set diffelide {0 0}
7616 set markingmatches 0
7618 set optim_delay 16
7620 set nextviewnum 1
7621 set curview 0
7622 set selectedview 0
7623 set selectedhlview None
7624 set viewfiles(0) {}
7625 set viewperm(0) 0
7626 set viewargs(0) {}
7628 set cmdlineok 0
7629 set stopped 0
7630 set stuffsaved 0
7631 set patchnum 0
7632 set lookingforhead 0
7633 set localirow -1
7634 set localfrow -1
7635 set lserial 0
7636 setcoords
7637 makewindow
7638 wm title . "[file tail $argv0]: [file tail [pwd]]"
7639 readrefs
7641 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7642 # create a view for the files/dirs specified on the command line
7643 set curview 1
7644 set selectedview 1
7645 set nextviewnum 2
7646 set viewname(1) "Command line"
7647 set viewfiles(1) $cmdline_files
7648 set viewargs(1) $revtreeargs
7649 set viewperm(1) 0
7650 addviewmenu 1
7651 .bar.view entryconf Edit* -state normal
7652 .bar.view entryconf Delete* -state normal
7655 if {[info exists permviews]} {
7656 foreach v $permviews {
7657 set n $nextviewnum
7658 incr nextviewnum
7659 set viewname($n) [lindex $v 0]
7660 set viewfiles($n) [lindex $v 1]
7661 set viewargs($n) [lindex $v 2]
7662 set viewperm($n) 1
7663 addviewmenu $n
7666 getcommits