290deff7b223c9baea87219b9a7e2560d537fcdd
1#!/bin/sh
2# Tcl ignores the next line -*- tcl -*- \
3exec wish "$0" -- "$@"
4
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.
9
10proc 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]
16 }
17}
18
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.
24proc run args {
25 global isonrunq runq
26
27 set script $args
28 if {[info exists isonrunq($script)]} return
29 if {$runq eq {}} {
30 after idle dorunq
31 }
32 lappend runq [list {} $script]
33 set isonrunq($script) 1
34}
35
36proc filerun {fd script} {
37 fileevent $fd readable [list filereadable $fd $script]
38}
39
40proc filereadable {fd script} {
41 global runq
42
43 fileevent $fd readable {}
44 if {$runq eq {}} {
45 after idle dorunq
46 }
47 lappend runq [list $fd $script]
48}
49
50proc dorunq {} {
51 global isonrunq runq
52
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]
69 }
70 } elseif {$fd eq {}} {
71 unset isonrunq($script)
72 }
73 set t0 $t1
74 if {$t1 - $tstart >= 80} break
75 }
76 if {$runq ne {}} {
77 after idle dorunq
78 }
79}
80
81# Start off a git rev-list process and arrange to read its output
82proc start_rev_list {view} {
83 global startmsecs
84 global commfd leftover tclencoding datemode
85 global viewargs viewfiles commitidx viewcomplete vnextroot
86 global showlocalchanges commitinterest mainheadid
87 global progressdirn progresscoords proglastnc curview
88
89 set startmsecs [clock clicks -milliseconds]
90 set commitidx($view) 0
91 set viewcomplete($view) 0
92 set vnextroot($view) 0
93 set order "--topo-order"
94 if {$datemode} {
95 set order "--date-order"
96 }
97 if {[catch {
98 set fd [open [concat | git log -z --pretty=raw $order --parents \
99 --boundary $viewargs($view) "--" $viewfiles($view)] r]
100 } err]} {
101 error_popup "Error executing git rev-list: $err"
102 exit 1
103 }
104 set commfd($view) $fd
105 set leftover($view) {}
106 if {$showlocalchanges} {
107 lappend commitinterest($mainheadid) {dodiffindex}
108 }
109 fconfigure $fd -blocking 0 -translation lf -eofchar {}
110 if {$tclencoding != {}} {
111 fconfigure $fd -encoding $tclencoding
112 }
113 filerun $fd [list getcommitlines $fd $view]
114 nowbusy $view
115 if {$view == $curview} {
116 set progressdirn 1
117 set progresscoords {0 0}
118 set proglastnc 0
119 }
120}
121
122proc stop_rev_list {} {
123 global commfd curview
124
125 if {![info exists commfd($curview)]} return
126 set fd $commfd($curview)
127 catch {
128 set pid [pid $fd]
129 exec kill $pid
130 }
131 catch {close $fd}
132 unset commfd($curview)
133}
134
135proc getcommits {} {
136 global phase canv curview
137
138 set phase getcommits
139 initlayout
140 start_rev_list $curview
141 show_status "Reading commits..."
142}
143
144# This makes a string representation of a positive integer which
145# sorts as a string in numerical order
146proc strrep {n} {
147 if {$n < 16} {
148 return [format "%x" $n]
149 } elseif {$n < 256} {
150 return [format "x%.2x" $n]
151 } elseif {$n < 65536} {
152 return [format "y%.4x" $n]
153 }
154 return [format "z%.8x" $n]
155}
156
157proc getcommitlines {fd view} {
158 global commitlisted commitinterest
159 global leftover commfd
160 global displayorder commitidx viewcomplete commitrow commitdata
161 global parentlist children curview hlview
162 global vparentlist vdisporder vcmitlisted
163 global ordertok vnextroot idpending
164
165 set stuff [read $fd 500000]
166 # git log doesn't terminate the last commit with a null...
167 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
168 set stuff "\0"
169 }
170 if {$stuff == {}} {
171 if {![eof $fd]} {
172 return 1
173 }
174 # Check if we have seen any ids listed as parents that haven't
175 # appeared in the list
176 foreach vid [array names idpending "$view,*"] {
177 # should only get here if git log is buggy
178 set id [lindex [split $vid ","] 1]
179 set commitrow($vid) $commitidx($view)
180 incr commitidx($view)
181 if {$view == $curview} {
182 lappend parentlist {}
183 lappend displayorder $id
184 lappend commitlisted 0
185 } else {
186 lappend vparentlist($view) {}
187 lappend vdisporder($view) $id
188 lappend vcmitlisted($view) 0
189 }
190 }
191 set viewcomplete($view) 1
192 global viewname progresscoords
193 unset commfd($view)
194 notbusy $view
195 set progresscoords {0 0}
196 adjustprogress
197 # set it blocking so we wait for the process to terminate
198 fconfigure $fd -blocking 1
199 if {[catch {close $fd} err]} {
200 set fv {}
201 if {$view != $curview} {
202 set fv " for the \"$viewname($view)\" view"
203 }
204 if {[string range $err 0 4] == "usage"} {
205 set err "Gitk: error reading commits$fv:\
206 bad arguments to git rev-list."
207 if {$viewname($view) eq "Command line"} {
208 append err \
209 " (Note: arguments to gitk are passed to git rev-list\
210 to allow selection of commits to be displayed.)"
211 }
212 } else {
213 set err "Error reading commits$fv: $err"
214 }
215 error_popup $err
216 }
217 if {$view == $curview} {
218 run chewcommits $view
219 }
220 return 0
221 }
222 set start 0
223 set gotsome 0
224 while 1 {
225 set i [string first "\0" $stuff $start]
226 if {$i < 0} {
227 append leftover($view) [string range $stuff $start end]
228 break
229 }
230 if {$start == 0} {
231 set cmit $leftover($view)
232 append cmit [string range $stuff 0 [expr {$i - 1}]]
233 set leftover($view) {}
234 } else {
235 set cmit [string range $stuff $start [expr {$i - 1}]]
236 }
237 set start [expr {$i + 1}]
238 set j [string first "\n" $cmit]
239 set ok 0
240 set listed 1
241 if {$j >= 0 && [string match "commit *" $cmit]} {
242 set ids [string range $cmit 7 [expr {$j - 1}]]
243 if {[string match {[-<>]*} $ids]} {
244 switch -- [string index $ids 0] {
245 "-" {set listed 0}
246 "<" {set listed 2}
247 ">" {set listed 3}
248 }
249 set ids [string range $ids 1 end]
250 }
251 set ok 1
252 foreach id $ids {
253 if {[string length $id] != 40} {
254 set ok 0
255 break
256 }
257 }
258 }
259 if {!$ok} {
260 set shortcmit $cmit
261 if {[string length $shortcmit] > 80} {
262 set shortcmit "[string range $shortcmit 0 80]..."
263 }
264 error_popup "Can't parse git log output: {$shortcmit}"
265 exit 1
266 }
267 set id [lindex $ids 0]
268 if {![info exists ordertok($view,$id)]} {
269 set otok "o[strrep $vnextroot($view)]"
270 incr vnextroot($view)
271 set ordertok($view,$id) $otok
272 } else {
273 set otok $ordertok($view,$id)
274 unset idpending($view,$id)
275 }
276 if {$listed} {
277 set olds [lrange $ids 1 end]
278 if {[llength $olds] == 1} {
279 set p [lindex $olds 0]
280 lappend children($view,$p) $id
281 if {![info exists ordertok($view,$p)]} {
282 set ordertok($view,$p) $ordertok($view,$id)
283 set idpending($view,$p) 1
284 }
285 } else {
286 set i 0
287 foreach p $olds {
288 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
289 lappend children($view,$p) $id
290 }
291 if {![info exists ordertok($view,$p)]} {
292 set ordertok($view,$p) "$otok[strrep $i]]"
293 set idpending($view,$p) 1
294 }
295 incr i
296 }
297 }
298 } else {
299 set olds {}
300 }
301 if {![info exists children($view,$id)]} {
302 set children($view,$id) {}
303 }
304 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
305 set commitrow($view,$id) $commitidx($view)
306 incr commitidx($view)
307 if {$view == $curview} {
308 lappend parentlist $olds
309 lappend displayorder $id
310 lappend commitlisted $listed
311 } else {
312 lappend vparentlist($view) $olds
313 lappend vdisporder($view) $id
314 lappend vcmitlisted($view) $listed
315 }
316 if {[info exists commitinterest($id)]} {
317 foreach script $commitinterest($id) {
318 eval [string map [list "%I" $id] $script]
319 }
320 unset commitinterest($id)
321 }
322 set gotsome 1
323 }
324 if {$gotsome} {
325 run chewcommits $view
326 if {$view == $curview} {
327 # update progress bar
328 global progressdirn progresscoords proglastnc
329 set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
330 set proglastnc $commitidx($view)
331 set l [lindex $progresscoords 0]
332 set r [lindex $progresscoords 1]
333 if {$progressdirn} {
334 set r [expr {$r + $inc}]
335 if {$r >= 1.0} {
336 set r 1.0
337 set progressdirn 0
338 }
339 if {$r > 0.2} {
340 set l [expr {$r - 0.2}]
341 }
342 } else {
343 set l [expr {$l - $inc}]
344 if {$l <= 0.0} {
345 set l 0.0
346 set progressdirn 1
347 }
348 set r [expr {$l + 0.2}]
349 }
350 set progresscoords [list $l $r]
351 adjustprogress
352 }
353 }
354 return 2
355}
356
357proc chewcommits {view} {
358 global curview hlview viewcomplete
359 global selectedline pending_select
360
361 if {$view == $curview} {
362 layoutmore
363 if {$viewcomplete($view)} {
364 global displayorder commitidx phase
365 global numcommits startmsecs
366
367 if {[info exists pending_select]} {
368 set row [first_real_row]
369 selectline $row 1
370 }
371 if {$commitidx($curview) > 0} {
372 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
373 #puts "overall $ms ms for $numcommits commits"
374 } else {
375 show_status "No commits selected"
376 }
377 notbusy layout
378 set phase {}
379 }
380 }
381 if {[info exists hlview] && $view == $hlview} {
382 vhighlightmore
383 }
384 return 0
385}
386
387proc readcommit {id} {
388 if {[catch {set contents [exec git cat-file commit $id]}]} return
389 parsecommit $id $contents 0
390}
391
392proc updatecommits {} {
393 global viewdata curview phase displayorder ordertok idpending
394 global children commitrow selectedline thickerline showneartags
395
396 if {$phase ne {}} {
397 stop_rev_list
398 set phase {}
399 }
400 set n $curview
401 foreach id $displayorder {
402 catch {unset children($n,$id)}
403 catch {unset commitrow($n,$id)}
404 catch {unset ordertok($n,$id)}
405 }
406 foreach vid [array names idpending "$n,*"] {
407 unset idpending($vid)
408 }
409 set curview -1
410 catch {unset selectedline}
411 catch {unset thickerline}
412 catch {unset viewdata($n)}
413 readrefs
414 changedrefs
415 if {$showneartags} {
416 getallcommits
417 }
418 showview $n
419}
420
421proc parsecommit {id contents listed} {
422 global commitinfo cdate
423
424 set inhdr 1
425 set comment {}
426 set headline {}
427 set auname {}
428 set audate {}
429 set comname {}
430 set comdate {}
431 set hdrend [string first "\n\n" $contents]
432 if {$hdrend < 0} {
433 # should never happen...
434 set hdrend [string length $contents]
435 }
436 set header [string range $contents 0 [expr {$hdrend - 1}]]
437 set comment [string range $contents [expr {$hdrend + 2}] end]
438 foreach line [split $header "\n"] {
439 set tag [lindex $line 0]
440 if {$tag == "author"} {
441 set audate [lindex $line end-1]
442 set auname [lrange $line 1 end-2]
443 } elseif {$tag == "committer"} {
444 set comdate [lindex $line end-1]
445 set comname [lrange $line 1 end-2]
446 }
447 }
448 set headline {}
449 # take the first non-blank line of the comment as the headline
450 set headline [string trimleft $comment]
451 set i [string first "\n" $headline]
452 if {$i >= 0} {
453 set headline [string range $headline 0 $i]
454 }
455 set headline [string trimright $headline]
456 set i [string first "\r" $headline]
457 if {$i >= 0} {
458 set headline [string trimright [string range $headline 0 $i]]
459 }
460 if {!$listed} {
461 # git rev-list indents the comment by 4 spaces;
462 # if we got this via git cat-file, add the indentation
463 set newcomment {}
464 foreach line [split $comment "\n"] {
465 append newcomment " "
466 append newcomment $line
467 append newcomment "\n"
468 }
469 set comment $newcomment
470 }
471 if {$comdate != {}} {
472 set cdate($id) $comdate
473 }
474 set commitinfo($id) [list $headline $auname $audate \
475 $comname $comdate $comment]
476}
477
478proc getcommit {id} {
479 global commitdata commitinfo
480
481 if {[info exists commitdata($id)]} {
482 parsecommit $id $commitdata($id) 1
483 } else {
484 readcommit $id
485 if {![info exists commitinfo($id)]} {
486 set commitinfo($id) {"No commit information available"}
487 }
488 }
489 return 1
490}
491
492proc readrefs {} {
493 global tagids idtags headids idheads tagobjid
494 global otherrefids idotherrefs mainhead mainheadid
495
496 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
497 catch {unset $v}
498 }
499 set refd [open [list | git show-ref -d] r]
500 while {[gets $refd line] >= 0} {
501 if {[string index $line 40] ne " "} continue
502 set id [string range $line 0 39]
503 set ref [string range $line 41 end]
504 if {![string match "refs/*" $ref]} continue
505 set name [string range $ref 5 end]
506 if {[string match "remotes/*" $name]} {
507 if {![string match "*/HEAD" $name]} {
508 set headids($name) $id
509 lappend idheads($id) $name
510 }
511 } elseif {[string match "heads/*" $name]} {
512 set name [string range $name 6 end]
513 set headids($name) $id
514 lappend idheads($id) $name
515 } elseif {[string match "tags/*" $name]} {
516 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
517 # which is what we want since the former is the commit ID
518 set name [string range $name 5 end]
519 if {[string match "*^{}" $name]} {
520 set name [string range $name 0 end-3]
521 } else {
522 set tagobjid($name) $id
523 }
524 set tagids($name) $id
525 lappend idtags($id) $name
526 } else {
527 set otherrefids($name) $id
528 lappend idotherrefs($id) $name
529 }
530 }
531 catch {close $refd}
532 set mainhead {}
533 set mainheadid {}
534 catch {
535 set thehead [exec git symbolic-ref HEAD]
536 if {[string match "refs/heads/*" $thehead]} {
537 set mainhead [string range $thehead 11 end]
538 if {[info exists headids($mainhead)]} {
539 set mainheadid $headids($mainhead)
540 }
541 }
542 }
543}
544
545# skip over fake commits
546proc first_real_row {} {
547 global nullid nullid2 displayorder numcommits
548
549 for {set row 0} {$row < $numcommits} {incr row} {
550 set id [lindex $displayorder $row]
551 if {$id ne $nullid && $id ne $nullid2} {
552 break
553 }
554 }
555 return $row
556}
557
558# update things for a head moved to a child of its previous location
559proc movehead {id name} {
560 global headids idheads
561
562 removehead $headids($name) $name
563 set headids($name) $id
564 lappend idheads($id) $name
565}
566
567# update things when a head has been removed
568proc removehead {id name} {
569 global headids idheads
570
571 if {$idheads($id) eq $name} {
572 unset idheads($id)
573 } else {
574 set i [lsearch -exact $idheads($id) $name]
575 if {$i >= 0} {
576 set idheads($id) [lreplace $idheads($id) $i $i]
577 }
578 }
579 unset headids($name)
580}
581
582proc show_error {w top msg} {
583 message $w.m -text $msg -justify center -aspect 400
584 pack $w.m -side top -fill x -padx 20 -pady 20
585 button $w.ok -text OK -command "destroy $top"
586 pack $w.ok -side bottom -fill x
587 bind $top <Visibility> "grab $top; focus $top"
588 bind $top <Key-Return> "destroy $top"
589 tkwait window $top
590}
591
592proc error_popup msg {
593 set w .error
594 toplevel $w
595 wm transient $w .
596 show_error $w $w $msg
597}
598
599proc confirm_popup msg {
600 global confirm_ok
601 set confirm_ok 0
602 set w .confirm
603 toplevel $w
604 wm transient $w .
605 message $w.m -text $msg -justify center -aspect 400
606 pack $w.m -side top -fill x -padx 20 -pady 20
607 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
608 pack $w.ok -side left -fill x
609 button $w.cancel -text Cancel -command "destroy $w"
610 pack $w.cancel -side right -fill x
611 bind $w <Visibility> "grab $w; focus $w"
612 tkwait window $w
613 return $confirm_ok
614}
615
616proc makewindow {} {
617 global canv canv2 canv3 linespc charspc ctext cflist
618 global tabstop
619 global findtype findtypemenu findloc findstring fstring geometry
620 global entries sha1entry sha1string sha1but
621 global diffcontextstring diffcontext
622 global maincursor textcursor curtextcursor
623 global rowctxmenu fakerowmenu mergemax wrapcomment
624 global highlight_files gdttype
625 global searchstring sstring
626 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
627 global headctxmenu progresscanv progressitem progresscoords statusw
628 global fprogitem fprogcoord lastprogupdate progupdatepending
629 global have_tk85
630
631 menu .bar
632 .bar add cascade -label "File" -menu .bar.file
633 .bar configure -font uifont
634 menu .bar.file
635 .bar.file add command -label "Update" -command updatecommits
636 .bar.file add command -label "Reread references" -command rereadrefs
637 .bar.file add command -label "List references" -command showrefs
638 .bar.file add command -label "Quit" -command doquit
639 .bar.file configure -font uifont
640 menu .bar.edit
641 .bar add cascade -label "Edit" -menu .bar.edit
642 .bar.edit add command -label "Preferences" -command doprefs
643 .bar.edit configure -font uifont
644
645 menu .bar.view -font uifont
646 .bar add cascade -label "View" -menu .bar.view
647 .bar.view add command -label "New view..." -command {newview 0}
648 .bar.view add command -label "Edit view..." -command editview \
649 -state disabled
650 .bar.view add command -label "Delete view" -command delview -state disabled
651 .bar.view add separator
652 .bar.view add radiobutton -label "All files" -command {showview 0} \
653 -variable selectedview -value 0
654
655 menu .bar.help
656 .bar add cascade -label "Help" -menu .bar.help
657 .bar.help add command -label "About gitk" -command about
658 .bar.help add command -label "Key bindings" -command keys
659 .bar.help configure -font uifont
660 . configure -menu .bar
661
662 # the gui has upper and lower half, parts of a paned window.
663 panedwindow .ctop -orient vertical
664
665 # possibly use assumed geometry
666 if {![info exists geometry(pwsash0)]} {
667 set geometry(topheight) [expr {15 * $linespc}]
668 set geometry(topwidth) [expr {80 * $charspc}]
669 set geometry(botheight) [expr {15 * $linespc}]
670 set geometry(botwidth) [expr {50 * $charspc}]
671 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
672 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
673 }
674
675 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
676 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
677 frame .tf.histframe
678 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
679
680 # create three canvases
681 set cscroll .tf.histframe.csb
682 set canv .tf.histframe.pwclist.canv
683 canvas $canv \
684 -selectbackground $selectbgcolor \
685 -background $bgcolor -bd 0 \
686 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
687 .tf.histframe.pwclist add $canv
688 set canv2 .tf.histframe.pwclist.canv2
689 canvas $canv2 \
690 -selectbackground $selectbgcolor \
691 -background $bgcolor -bd 0 -yscrollincr $linespc
692 .tf.histframe.pwclist add $canv2
693 set canv3 .tf.histframe.pwclist.canv3
694 canvas $canv3 \
695 -selectbackground $selectbgcolor \
696 -background $bgcolor -bd 0 -yscrollincr $linespc
697 .tf.histframe.pwclist add $canv3
698 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
699 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
700
701 # a scroll bar to rule them
702 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
703 pack $cscroll -side right -fill y
704 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
705 lappend bglist $canv $canv2 $canv3
706 pack .tf.histframe.pwclist -fill both -expand 1 -side left
707
708 # we have two button bars at bottom of top frame. Bar 1
709 frame .tf.bar
710 frame .tf.lbar -height 15
711
712 set sha1entry .tf.bar.sha1
713 set entries $sha1entry
714 set sha1but .tf.bar.sha1label
715 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
716 -command gotocommit -width 8 -font uifont
717 $sha1but conf -disabledforeground [$sha1but cget -foreground]
718 pack .tf.bar.sha1label -side left
719 entry $sha1entry -width 40 -font textfont -textvariable sha1string
720 trace add variable sha1string write sha1change
721 pack $sha1entry -side left -pady 2
722
723 image create bitmap bm-left -data {
724 #define left_width 16
725 #define left_height 16
726 static unsigned char left_bits[] = {
727 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
728 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
729 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
730 }
731 image create bitmap bm-right -data {
732 #define right_width 16
733 #define right_height 16
734 static unsigned char right_bits[] = {
735 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
736 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
737 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
738 }
739 button .tf.bar.leftbut -image bm-left -command goback \
740 -state disabled -width 26
741 pack .tf.bar.leftbut -side left -fill y
742 button .tf.bar.rightbut -image bm-right -command goforw \
743 -state disabled -width 26
744 pack .tf.bar.rightbut -side left -fill y
745
746 # Status label and progress bar
747 set statusw .tf.bar.status
748 label $statusw -width 15 -relief sunken -font uifont
749 pack $statusw -side left -padx 5
750 set h [expr {[font metrics uifont -linespace] + 2}]
751 set progresscanv .tf.bar.progress
752 canvas $progresscanv -relief sunken -height $h -borderwidth 2
753 set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
754 set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
755 pack $progresscanv -side right -expand 1 -fill x
756 set progresscoords {0 0}
757 set fprogcoord 0
758 bind $progresscanv <Configure> adjustprogress
759 set lastprogupdate [clock clicks -milliseconds]
760 set progupdatepending 0
761
762 # build up the bottom bar of upper window
763 label .tf.lbar.flabel -text "Find " -font uifont
764 button .tf.lbar.fnext -text "next" -command dofind -font uifont
765 button .tf.lbar.fprev -text "prev" -command {dofind 1} -font uifont
766 label .tf.lbar.flab2 -text " commit " -font uifont
767 pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
768 -side left -fill y
769 set gdttype "containing:"
770 set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
771 "containing:" \
772 "touching paths:" \
773 "adding/removing string:"]
774 trace add variable gdttype write gdttype_change
775 $gm conf -font uifont
776 .tf.lbar.gdttype conf -font uifont
777 pack .tf.lbar.gdttype -side left -fill y
778
779 set findstring {}
780 set fstring .tf.lbar.findstring
781 lappend entries $fstring
782 entry $fstring -width 30 -font textfont -textvariable findstring
783 trace add variable findstring write find_change
784 set findtype Exact
785 set findtypemenu [tk_optionMenu .tf.lbar.findtype \
786 findtype Exact IgnCase Regexp]
787 trace add variable findtype write findcom_change
788 .tf.lbar.findtype configure -font uifont
789 .tf.lbar.findtype.menu configure -font uifont
790 set findloc "All fields"
791 tk_optionMenu .tf.lbar.findloc findloc "All fields" Headline \
792 Comments Author Committer
793 trace add variable findloc write find_change
794 .tf.lbar.findloc configure -font uifont
795 .tf.lbar.findloc.menu configure -font uifont
796 pack .tf.lbar.findloc -side right
797 pack .tf.lbar.findtype -side right
798 pack $fstring -side left -expand 1 -fill x
799
800 # Finish putting the upper half of the viewer together
801 pack .tf.lbar -in .tf -side bottom -fill x
802 pack .tf.bar -in .tf -side bottom -fill x
803 pack .tf.histframe -fill both -side top -expand 1
804 .ctop add .tf
805 .ctop paneconfigure .tf -height $geometry(topheight)
806 .ctop paneconfigure .tf -width $geometry(topwidth)
807
808 # now build up the bottom
809 panedwindow .pwbottom -orient horizontal
810
811 # lower left, a text box over search bar, scroll bar to the right
812 # if we know window height, then that will set the lower text height, otherwise
813 # we set lower text height which will drive window height
814 if {[info exists geometry(main)]} {
815 frame .bleft -width $geometry(botwidth)
816 } else {
817 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
818 }
819 frame .bleft.top
820 frame .bleft.mid
821
822 button .bleft.top.search -text "Search" -command dosearch \
823 -font uifont
824 pack .bleft.top.search -side left -padx 5
825 set sstring .bleft.top.sstring
826 entry $sstring -width 20 -font textfont -textvariable searchstring
827 lappend entries $sstring
828 trace add variable searchstring write incrsearch
829 pack $sstring -side left -expand 1 -fill x
830 radiobutton .bleft.mid.diff -text "Diff" \
831 -command changediffdisp -variable diffelide -value {0 0}
832 radiobutton .bleft.mid.old -text "Old version" \
833 -command changediffdisp -variable diffelide -value {0 1}
834 radiobutton .bleft.mid.new -text "New version" \
835 -command changediffdisp -variable diffelide -value {1 0}
836 label .bleft.mid.labeldiffcontext -text " Lines of context: " \
837 -font uifont
838 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
839 spinbox .bleft.mid.diffcontext -width 5 -font textfont \
840 -from 1 -increment 1 -to 10000000 \
841 -validate all -validatecommand "diffcontextvalidate %P" \
842 -textvariable diffcontextstring
843 .bleft.mid.diffcontext set $diffcontext
844 trace add variable diffcontextstring write diffcontextchange
845 lappend entries .bleft.mid.diffcontext
846 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
847 set ctext .bleft.ctext
848 text $ctext -background $bgcolor -foreground $fgcolor \
849 -state disabled -font textfont \
850 -yscrollcommand scrolltext -wrap none
851 if {$have_tk85} {
852 $ctext conf -tabstyle wordprocessor
853 }
854 scrollbar .bleft.sb -command "$ctext yview"
855 pack .bleft.top -side top -fill x
856 pack .bleft.mid -side top -fill x
857 pack .bleft.sb -side right -fill y
858 pack $ctext -side left -fill both -expand 1
859 lappend bglist $ctext
860 lappend fglist $ctext
861
862 $ctext tag conf comment -wrap $wrapcomment
863 $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
864 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
865 $ctext tag conf d0 -fore [lindex $diffcolors 0]
866 $ctext tag conf d1 -fore [lindex $diffcolors 1]
867 $ctext tag conf m0 -fore red
868 $ctext tag conf m1 -fore blue
869 $ctext tag conf m2 -fore green
870 $ctext tag conf m3 -fore purple
871 $ctext tag conf m4 -fore brown
872 $ctext tag conf m5 -fore "#009090"
873 $ctext tag conf m6 -fore magenta
874 $ctext tag conf m7 -fore "#808000"
875 $ctext tag conf m8 -fore "#009000"
876 $ctext tag conf m9 -fore "#ff0080"
877 $ctext tag conf m10 -fore cyan
878 $ctext tag conf m11 -fore "#b07070"
879 $ctext tag conf m12 -fore "#70b0f0"
880 $ctext tag conf m13 -fore "#70f0b0"
881 $ctext tag conf m14 -fore "#f0b070"
882 $ctext tag conf m15 -fore "#ff70b0"
883 $ctext tag conf mmax -fore darkgrey
884 set mergemax 16
885 $ctext tag conf mresult -font textfontbold
886 $ctext tag conf msep -font textfontbold
887 $ctext tag conf found -back yellow
888
889 .pwbottom add .bleft
890 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
891
892 # lower right
893 frame .bright
894 frame .bright.mode
895 radiobutton .bright.mode.patch -text "Patch" \
896 -command reselectline -variable cmitmode -value "patch"
897 .bright.mode.patch configure -font uifont
898 radiobutton .bright.mode.tree -text "Tree" \
899 -command reselectline -variable cmitmode -value "tree"
900 .bright.mode.tree configure -font uifont
901 grid .bright.mode.patch .bright.mode.tree -sticky ew
902 pack .bright.mode -side top -fill x
903 set cflist .bright.cfiles
904 set indent [font measure mainfont "nn"]
905 text $cflist \
906 -selectbackground $selectbgcolor \
907 -background $bgcolor -foreground $fgcolor \
908 -font mainfont \
909 -tabs [list $indent [expr {2 * $indent}]] \
910 -yscrollcommand ".bright.sb set" \
911 -cursor [. cget -cursor] \
912 -spacing1 1 -spacing3 1
913 lappend bglist $cflist
914 lappend fglist $cflist
915 scrollbar .bright.sb -command "$cflist yview"
916 pack .bright.sb -side right -fill y
917 pack $cflist -side left -fill both -expand 1
918 $cflist tag configure highlight \
919 -background [$cflist cget -selectbackground]
920 $cflist tag configure bold -font mainfontbold
921
922 .pwbottom add .bright
923 .ctop add .pwbottom
924
925 # restore window position if known
926 if {[info exists geometry(main)]} {
927 wm geometry . "$geometry(main)"
928 }
929
930 if {[tk windowingsystem] eq {aqua}} {
931 set M1B M1
932 } else {
933 set M1B Control
934 }
935
936 bind .pwbottom <Configure> {resizecdetpanes %W %w}
937 pack .ctop -fill both -expand 1
938 bindall <1> {selcanvline %W %x %y}
939 #bindall <B1-Motion> {selcanvline %W %x %y}
940 if {[tk windowingsystem] == "win32"} {
941 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
942 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
943 } else {
944 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
945 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
946 }
947 bindall <2> "canvscan mark %W %x %y"
948 bindall <B2-Motion> "canvscan dragto %W %x %y"
949 bindkey <Home> selfirstline
950 bindkey <End> sellastline
951 bind . <Key-Up> "selnextline -1"
952 bind . <Key-Down> "selnextline 1"
953 bindkey <Key-Right> "goforw"
954 bindkey <Key-Left> "goback"
955 bind . <Key-Prior> "selnextpage -1"
956 bind . <Key-Next> "selnextpage 1"
957 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
958 bind . <$M1B-End> "allcanvs yview moveto 1.0"
959 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
960 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
961 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
962 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
963 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
964 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
965 bindkey <Key-space> "$ctext yview scroll 1 pages"
966 bindkey p "selnextline -1"
967 bindkey n "selnextline 1"
968 bindkey z "goback"
969 bindkey x "goforw"
970 bindkey i "selnextline -1"
971 bindkey k "selnextline 1"
972 bindkey j "goback"
973 bindkey l "goforw"
974 bindkey b "$ctext yview scroll -1 pages"
975 bindkey d "$ctext yview scroll 18 units"
976 bindkey u "$ctext yview scroll -18 units"
977 bindkey / {findnext 1}
978 bindkey <Key-Return> {findnext 0}
979 bindkey ? findprev
980 bindkey f nextfile
981 bindkey <F5> updatecommits
982 bind . <$M1B-q> doquit
983 bind . <$M1B-f> dofind
984 bind . <$M1B-g> {findnext 0}
985 bind . <$M1B-r> dosearchback
986 bind . <$M1B-s> dosearch
987 bind . <$M1B-equal> {incrfont 1}
988 bind . <$M1B-KP_Add> {incrfont 1}
989 bind . <$M1B-minus> {incrfont -1}
990 bind . <$M1B-KP_Subtract> {incrfont -1}
991 wm protocol . WM_DELETE_WINDOW doquit
992 bind . <Button-1> "click %W"
993 bind $fstring <Key-Return> dofind
994 bind $sha1entry <Key-Return> gotocommit
995 bind $sha1entry <<PasteSelection>> clearsha1
996 bind $cflist <1> {sel_flist %W %x %y; break}
997 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
998 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
999 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1000
1001 set maincursor [. cget -cursor]
1002 set textcursor [$ctext cget -cursor]
1003 set curtextcursor $textcursor
1004
1005 set rowctxmenu .rowctxmenu
1006 menu $rowctxmenu -tearoff 0
1007 $rowctxmenu add command -label "Diff this -> selected" \
1008 -command {diffvssel 0}
1009 $rowctxmenu add command -label "Diff selected -> this" \
1010 -command {diffvssel 1}
1011 $rowctxmenu add command -label "Make patch" -command mkpatch
1012 $rowctxmenu add command -label "Create tag" -command mktag
1013 $rowctxmenu add command -label "Write commit to file" -command writecommit
1014 $rowctxmenu add command -label "Create new branch" -command mkbranch
1015 $rowctxmenu add command -label "Cherry-pick this commit" \
1016 -command cherrypick
1017 $rowctxmenu add command -label "Reset HEAD branch to here" \
1018 -command resethead
1019
1020 set fakerowmenu .fakerowmenu
1021 menu $fakerowmenu -tearoff 0
1022 $fakerowmenu add command -label "Diff this -> selected" \
1023 -command {diffvssel 0}
1024 $fakerowmenu add command -label "Diff selected -> this" \
1025 -command {diffvssel 1}
1026 $fakerowmenu add command -label "Make patch" -command mkpatch
1027# $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1028# $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1029# $fakerowmenu add command -label "Revert local changes" -command revertlocal
1030
1031 set headctxmenu .headctxmenu
1032 menu $headctxmenu -tearoff 0
1033 $headctxmenu add command -label "Check out this branch" \
1034 -command cobranch
1035 $headctxmenu add command -label "Remove this branch" \
1036 -command rmbranch
1037
1038 global flist_menu
1039 set flist_menu .flistctxmenu
1040 menu $flist_menu -tearoff 0
1041 $flist_menu add command -label "Highlight this too" \
1042 -command {flist_hl 0}
1043 $flist_menu add command -label "Highlight this only" \
1044 -command {flist_hl 1}
1045}
1046
1047# Windows sends all mouse wheel events to the current focused window, not
1048# the one where the mouse hovers, so bind those events here and redirect
1049# to the correct window
1050proc windows_mousewheel_redirector {W X Y D} {
1051 global canv canv2 canv3
1052 set w [winfo containing -displayof $W $X $Y]
1053 if {$w ne ""} {
1054 set u [expr {$D < 0 ? 5 : -5}]
1055 if {$w == $canv || $w == $canv2 || $w == $canv3} {
1056 allcanvs yview scroll $u units
1057 } else {
1058 catch {
1059 $w yview scroll $u units
1060 }
1061 }
1062 }
1063}
1064
1065# mouse-2 makes all windows scan vertically, but only the one
1066# the cursor is in scans horizontally
1067proc canvscan {op w x y} {
1068 global canv canv2 canv3
1069 foreach c [list $canv $canv2 $canv3] {
1070 if {$c == $w} {
1071 $c scan $op $x $y
1072 } else {
1073 $c scan $op 0 $y
1074 }
1075 }
1076}
1077
1078proc scrollcanv {cscroll f0 f1} {
1079 $cscroll set $f0 $f1
1080 drawfrac $f0 $f1
1081 flushhighlights
1082}
1083
1084# when we make a key binding for the toplevel, make sure
1085# it doesn't get triggered when that key is pressed in the
1086# find string entry widget.
1087proc bindkey {ev script} {
1088 global entries
1089 bind . $ev $script
1090 set escript [bind Entry $ev]
1091 if {$escript == {}} {
1092 set escript [bind Entry <Key>]
1093 }
1094 foreach e $entries {
1095 bind $e $ev "$escript; break"
1096 }
1097}
1098
1099# set the focus back to the toplevel for any click outside
1100# the entry widgets
1101proc click {w} {
1102 global ctext entries
1103 foreach e [concat $entries $ctext] {
1104 if {$w == $e} return
1105 }
1106 focus .
1107}
1108
1109# Adjust the progress bar for a change in requested extent or canvas size
1110proc adjustprogress {} {
1111 global progresscanv progressitem progresscoords
1112 global fprogitem fprogcoord lastprogupdate progupdatepending
1113
1114 set w [expr {[winfo width $progresscanv] - 4}]
1115 set x0 [expr {$w * [lindex $progresscoords 0]}]
1116 set x1 [expr {$w * [lindex $progresscoords 1]}]
1117 set h [winfo height $progresscanv]
1118 $progresscanv coords $progressitem $x0 0 $x1 $h
1119 $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1120 set now [clock clicks -milliseconds]
1121 if {$now >= $lastprogupdate + 100} {
1122 set progupdatepending 0
1123 update
1124 } elseif {!$progupdatepending} {
1125 set progupdatepending 1
1126 after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1127 }
1128}
1129
1130proc doprogupdate {} {
1131 global lastprogupdate progupdatepending
1132
1133 if {$progupdatepending} {
1134 set progupdatepending 0
1135 set lastprogupdate [clock clicks -milliseconds]
1136 update
1137 }
1138}
1139
1140proc savestuff {w} {
1141 global canv canv2 canv3 mainfont textfont uifont tabstop
1142 global stuffsaved findmergefiles maxgraphpct
1143 global maxwidth showneartags showlocalchanges
1144 global viewname viewfiles viewargs viewperm nextviewnum
1145 global cmitmode wrapcomment datetimeformat
1146 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1147
1148 if {$stuffsaved} return
1149 if {![winfo viewable .]} return
1150 catch {
1151 set f [open "~/.gitk-new" w]
1152 puts $f [list set mainfont $mainfont]
1153 puts $f [list set textfont $textfont]
1154 puts $f [list set uifont $uifont]
1155 puts $f [list set tabstop $tabstop]
1156 puts $f [list set findmergefiles $findmergefiles]
1157 puts $f [list set maxgraphpct $maxgraphpct]
1158 puts $f [list set maxwidth $maxwidth]
1159 puts $f [list set cmitmode $cmitmode]
1160 puts $f [list set wrapcomment $wrapcomment]
1161 puts $f [list set showneartags $showneartags]
1162 puts $f [list set showlocalchanges $showlocalchanges]
1163 puts $f [list set datetimeformat $datetimeformat]
1164 puts $f [list set bgcolor $bgcolor]
1165 puts $f [list set fgcolor $fgcolor]
1166 puts $f [list set colors $colors]
1167 puts $f [list set diffcolors $diffcolors]
1168 puts $f [list set diffcontext $diffcontext]
1169 puts $f [list set selectbgcolor $selectbgcolor]
1170
1171 puts $f "set geometry(main) [wm geometry .]"
1172 puts $f "set geometry(topwidth) [winfo width .tf]"
1173 puts $f "set geometry(topheight) [winfo height .tf]"
1174 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1175 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1176 puts $f "set geometry(botwidth) [winfo width .bleft]"
1177 puts $f "set geometry(botheight) [winfo height .bleft]"
1178
1179 puts -nonewline $f "set permviews {"
1180 for {set v 0} {$v < $nextviewnum} {incr v} {
1181 if {$viewperm($v)} {
1182 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1183 }
1184 }
1185 puts $f "}"
1186 close $f
1187 file rename -force "~/.gitk-new" "~/.gitk"
1188 }
1189 set stuffsaved 1
1190}
1191
1192proc resizeclistpanes {win w} {
1193 global oldwidth
1194 if {[info exists oldwidth($win)]} {
1195 set s0 [$win sash coord 0]
1196 set s1 [$win sash coord 1]
1197 if {$w < 60} {
1198 set sash0 [expr {int($w/2 - 2)}]
1199 set sash1 [expr {int($w*5/6 - 2)}]
1200 } else {
1201 set factor [expr {1.0 * $w / $oldwidth($win)}]
1202 set sash0 [expr {int($factor * [lindex $s0 0])}]
1203 set sash1 [expr {int($factor * [lindex $s1 0])}]
1204 if {$sash0 < 30} {
1205 set sash0 30
1206 }
1207 if {$sash1 < $sash0 + 20} {
1208 set sash1 [expr {$sash0 + 20}]
1209 }
1210 if {$sash1 > $w - 10} {
1211 set sash1 [expr {$w - 10}]
1212 if {$sash0 > $sash1 - 20} {
1213 set sash0 [expr {$sash1 - 20}]
1214 }
1215 }
1216 }
1217 $win sash place 0 $sash0 [lindex $s0 1]
1218 $win sash place 1 $sash1 [lindex $s1 1]
1219 }
1220 set oldwidth($win) $w
1221}
1222
1223proc resizecdetpanes {win w} {
1224 global oldwidth
1225 if {[info exists oldwidth($win)]} {
1226 set s0 [$win sash coord 0]
1227 if {$w < 60} {
1228 set sash0 [expr {int($w*3/4 - 2)}]
1229 } else {
1230 set factor [expr {1.0 * $w / $oldwidth($win)}]
1231 set sash0 [expr {int($factor * [lindex $s0 0])}]
1232 if {$sash0 < 45} {
1233 set sash0 45
1234 }
1235 if {$sash0 > $w - 15} {
1236 set sash0 [expr {$w - 15}]
1237 }
1238 }
1239 $win sash place 0 $sash0 [lindex $s0 1]
1240 }
1241 set oldwidth($win) $w
1242}
1243
1244proc allcanvs args {
1245 global canv canv2 canv3
1246 eval $canv $args
1247 eval $canv2 $args
1248 eval $canv3 $args
1249}
1250
1251proc bindall {event action} {
1252 global canv canv2 canv3
1253 bind $canv $event $action
1254 bind $canv2 $event $action
1255 bind $canv3 $event $action
1256}
1257
1258proc about {} {
1259 global uifont
1260 set w .about
1261 if {[winfo exists $w]} {
1262 raise $w
1263 return
1264 }
1265 toplevel $w
1266 wm title $w "About gitk"
1267 message $w.m -text {
1268Gitk - a commit viewer for git
1269
1270Copyright © 2005-2006 Paul Mackerras
1271
1272Use and redistribute under the terms of the GNU General Public License} \
1273 -justify center -aspect 400 -border 2 -bg white -relief groove
1274 pack $w.m -side top -fill x -padx 2 -pady 2
1275 $w.m configure -font uifont
1276 button $w.ok -text Close -command "destroy $w" -default active
1277 pack $w.ok -side bottom
1278 $w.ok configure -font uifont
1279 bind $w <Visibility> "focus $w.ok"
1280 bind $w <Key-Escape> "destroy $w"
1281 bind $w <Key-Return> "destroy $w"
1282}
1283
1284proc keys {} {
1285 global uifont
1286 set w .keys
1287 if {[winfo exists $w]} {
1288 raise $w
1289 return
1290 }
1291 if {[tk windowingsystem] eq {aqua}} {
1292 set M1T Cmd
1293 } else {
1294 set M1T Ctrl
1295 }
1296 toplevel $w
1297 wm title $w "Gitk key bindings"
1298 message $w.m -text "
1299Gitk key bindings:
1300
1301<$M1T-Q> Quit
1302<Home> Move to first commit
1303<End> Move to last commit
1304<Up>, p, i Move up one commit
1305<Down>, n, k Move down one commit
1306<Left>, z, j Go back in history list
1307<Right>, x, l Go forward in history list
1308<PageUp> Move up one page in commit list
1309<PageDown> Move down one page in commit list
1310<$M1T-Home> Scroll to top of commit list
1311<$M1T-End> Scroll to bottom of commit list
1312<$M1T-Up> Scroll commit list up one line
1313<$M1T-Down> Scroll commit list down one line
1314<$M1T-PageUp> Scroll commit list up one page
1315<$M1T-PageDown> Scroll commit list down one page
1316<Shift-Up> Move to previous highlighted line
1317<Shift-Down> Move to next highlighted line
1318<Delete>, b Scroll diff view up one page
1319<Backspace> Scroll diff view up one page
1320<Space> Scroll diff view down one page
1321u Scroll diff view up 18 lines
1322d Scroll diff view down 18 lines
1323<$M1T-F> Find
1324<$M1T-G> Move to next find hit
1325<Return> Move to next find hit
1326/ Move to next find hit, or redo find
1327? Move to previous find hit
1328f Scroll diff view to next file
1329<$M1T-S> Search for next hit in diff view
1330<$M1T-R> Search for previous hit in diff view
1331<$M1T-KP+> Increase font size
1332<$M1T-plus> Increase font size
1333<$M1T-KP-> Decrease font size
1334<$M1T-minus> Decrease font size
1335<F5> Update
1336" \
1337 -justify left -bg white -border 2 -relief groove
1338 pack $w.m -side top -fill both -padx 2 -pady 2
1339 $w.m configure -font uifont
1340 button $w.ok -text Close -command "destroy $w" -default active
1341 pack $w.ok -side bottom
1342 $w.ok configure -font uifont
1343 bind $w <Visibility> "focus $w.ok"
1344 bind $w <Key-Escape> "destroy $w"
1345 bind $w <Key-Return> "destroy $w"
1346}
1347
1348# Procedures for manipulating the file list window at the
1349# bottom right of the overall window.
1350
1351proc treeview {w l openlevs} {
1352 global treecontents treediropen treeheight treeparent treeindex
1353
1354 set ix 0
1355 set treeindex() 0
1356 set lev 0
1357 set prefix {}
1358 set prefixend -1
1359 set prefendstack {}
1360 set htstack {}
1361 set ht 0
1362 set treecontents() {}
1363 $w conf -state normal
1364 foreach f $l {
1365 while {[string range $f 0 $prefixend] ne $prefix} {
1366 if {$lev <= $openlevs} {
1367 $w mark set e:$treeindex($prefix) "end -1c"
1368 $w mark gravity e:$treeindex($prefix) left
1369 }
1370 set treeheight($prefix) $ht
1371 incr ht [lindex $htstack end]
1372 set htstack [lreplace $htstack end end]
1373 set prefixend [lindex $prefendstack end]
1374 set prefendstack [lreplace $prefendstack end end]
1375 set prefix [string range $prefix 0 $prefixend]
1376 incr lev -1
1377 }
1378 set tail [string range $f [expr {$prefixend+1}] end]
1379 while {[set slash [string first "/" $tail]] >= 0} {
1380 lappend htstack $ht
1381 set ht 0
1382 lappend prefendstack $prefixend
1383 incr prefixend [expr {$slash + 1}]
1384 set d [string range $tail 0 $slash]
1385 lappend treecontents($prefix) $d
1386 set oldprefix $prefix
1387 append prefix $d
1388 set treecontents($prefix) {}
1389 set treeindex($prefix) [incr ix]
1390 set treeparent($prefix) $oldprefix
1391 set tail [string range $tail [expr {$slash+1}] end]
1392 if {$lev <= $openlevs} {
1393 set ht 1
1394 set treediropen($prefix) [expr {$lev < $openlevs}]
1395 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1396 $w mark set d:$ix "end -1c"
1397 $w mark gravity d:$ix left
1398 set str "\n"
1399 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1400 $w insert end $str
1401 $w image create end -align center -image $bm -padx 1 \
1402 -name a:$ix
1403 $w insert end $d [highlight_tag $prefix]
1404 $w mark set s:$ix "end -1c"
1405 $w mark gravity s:$ix left
1406 }
1407 incr lev
1408 }
1409 if {$tail ne {}} {
1410 if {$lev <= $openlevs} {
1411 incr ht
1412 set str "\n"
1413 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1414 $w insert end $str
1415 $w insert end $tail [highlight_tag $f]
1416 }
1417 lappend treecontents($prefix) $tail
1418 }
1419 }
1420 while {$htstack ne {}} {
1421 set treeheight($prefix) $ht
1422 incr ht [lindex $htstack end]
1423 set htstack [lreplace $htstack end end]
1424 set prefixend [lindex $prefendstack end]
1425 set prefendstack [lreplace $prefendstack end end]
1426 set prefix [string range $prefix 0 $prefixend]
1427 }
1428 $w conf -state disabled
1429}
1430
1431proc linetoelt {l} {
1432 global treeheight treecontents
1433
1434 set y 2
1435 set prefix {}
1436 while {1} {
1437 foreach e $treecontents($prefix) {
1438 if {$y == $l} {
1439 return "$prefix$e"
1440 }
1441 set n 1
1442 if {[string index $e end] eq "/"} {
1443 set n $treeheight($prefix$e)
1444 if {$y + $n > $l} {
1445 append prefix $e
1446 incr y
1447 break
1448 }
1449 }
1450 incr y $n
1451 }
1452 }
1453}
1454
1455proc highlight_tree {y prefix} {
1456 global treeheight treecontents cflist
1457
1458 foreach e $treecontents($prefix) {
1459 set path $prefix$e
1460 if {[highlight_tag $path] ne {}} {
1461 $cflist tag add bold $y.0 "$y.0 lineend"
1462 }
1463 incr y
1464 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1465 set y [highlight_tree $y $path]
1466 }
1467 }
1468 return $y
1469}
1470
1471proc treeclosedir {w dir} {
1472 global treediropen treeheight treeparent treeindex
1473
1474 set ix $treeindex($dir)
1475 $w conf -state normal
1476 $w delete s:$ix e:$ix
1477 set treediropen($dir) 0
1478 $w image configure a:$ix -image tri-rt
1479 $w conf -state disabled
1480 set n [expr {1 - $treeheight($dir)}]
1481 while {$dir ne {}} {
1482 incr treeheight($dir) $n
1483 set dir $treeparent($dir)
1484 }
1485}
1486
1487proc treeopendir {w dir} {
1488 global treediropen treeheight treeparent treecontents treeindex
1489
1490 set ix $treeindex($dir)
1491 $w conf -state normal
1492 $w image configure a:$ix -image tri-dn
1493 $w mark set e:$ix s:$ix
1494 $w mark gravity e:$ix right
1495 set lev 0
1496 set str "\n"
1497 set n [llength $treecontents($dir)]
1498 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1499 incr lev
1500 append str "\t"
1501 incr treeheight($x) $n
1502 }
1503 foreach e $treecontents($dir) {
1504 set de $dir$e
1505 if {[string index $e end] eq "/"} {
1506 set iy $treeindex($de)
1507 $w mark set d:$iy e:$ix
1508 $w mark gravity d:$iy left
1509 $w insert e:$ix $str
1510 set treediropen($de) 0
1511 $w image create e:$ix -align center -image tri-rt -padx 1 \
1512 -name a:$iy
1513 $w insert e:$ix $e [highlight_tag $de]
1514 $w mark set s:$iy e:$ix
1515 $w mark gravity s:$iy left
1516 set treeheight($de) 1
1517 } else {
1518 $w insert e:$ix $str
1519 $w insert e:$ix $e [highlight_tag $de]
1520 }
1521 }
1522 $w mark gravity e:$ix left
1523 $w conf -state disabled
1524 set treediropen($dir) 1
1525 set top [lindex [split [$w index @0,0] .] 0]
1526 set ht [$w cget -height]
1527 set l [lindex [split [$w index s:$ix] .] 0]
1528 if {$l < $top} {
1529 $w yview $l.0
1530 } elseif {$l + $n + 1 > $top + $ht} {
1531 set top [expr {$l + $n + 2 - $ht}]
1532 if {$l < $top} {
1533 set top $l
1534 }
1535 $w yview $top.0
1536 }
1537}
1538
1539proc treeclick {w x y} {
1540 global treediropen cmitmode ctext cflist cflist_top
1541
1542 if {$cmitmode ne "tree"} return
1543 if {![info exists cflist_top]} return
1544 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1545 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1546 $cflist tag add highlight $l.0 "$l.0 lineend"
1547 set cflist_top $l
1548 if {$l == 1} {
1549 $ctext yview 1.0
1550 return
1551 }
1552 set e [linetoelt $l]
1553 if {[string index $e end] ne "/"} {
1554 showfile $e
1555 } elseif {$treediropen($e)} {
1556 treeclosedir $w $e
1557 } else {
1558 treeopendir $w $e
1559 }
1560}
1561
1562proc setfilelist {id} {
1563 global treefilelist cflist
1564
1565 treeview $cflist $treefilelist($id) 0
1566}
1567
1568image create bitmap tri-rt -background black -foreground blue -data {
1569 #define tri-rt_width 13
1570 #define tri-rt_height 13
1571 static unsigned char tri-rt_bits[] = {
1572 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1573 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1574 0x00, 0x00};
1575} -maskdata {
1576 #define tri-rt-mask_width 13
1577 #define tri-rt-mask_height 13
1578 static unsigned char tri-rt-mask_bits[] = {
1579 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1580 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1581 0x08, 0x00};
1582}
1583image create bitmap tri-dn -background black -foreground blue -data {
1584 #define tri-dn_width 13
1585 #define tri-dn_height 13
1586 static unsigned char tri-dn_bits[] = {
1587 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1588 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1589 0x00, 0x00};
1590} -maskdata {
1591 #define tri-dn-mask_width 13
1592 #define tri-dn-mask_height 13
1593 static unsigned char tri-dn-mask_bits[] = {
1594 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1595 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1596 0x00, 0x00};
1597}
1598
1599image create bitmap reficon-T -background black -foreground yellow -data {
1600 #define tagicon_width 13
1601 #define tagicon_height 9
1602 static unsigned char tagicon_bits[] = {
1603 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1604 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1605} -maskdata {
1606 #define tagicon-mask_width 13
1607 #define tagicon-mask_height 9
1608 static unsigned char tagicon-mask_bits[] = {
1609 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1610 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1611}
1612set rectdata {
1613 #define headicon_width 13
1614 #define headicon_height 9
1615 static unsigned char headicon_bits[] = {
1616 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1617 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1618}
1619set rectmask {
1620 #define headicon-mask_width 13
1621 #define headicon-mask_height 9
1622 static unsigned char headicon-mask_bits[] = {
1623 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1624 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1625}
1626image create bitmap reficon-H -background black -foreground green \
1627 -data $rectdata -maskdata $rectmask
1628image create bitmap reficon-o -background black -foreground "#ddddff" \
1629 -data $rectdata -maskdata $rectmask
1630
1631proc init_flist {first} {
1632 global cflist cflist_top selectedline difffilestart
1633
1634 $cflist conf -state normal
1635 $cflist delete 0.0 end
1636 if {$first ne {}} {
1637 $cflist insert end $first
1638 set cflist_top 1
1639 $cflist tag add highlight 1.0 "1.0 lineend"
1640 } else {
1641 catch {unset cflist_top}
1642 }
1643 $cflist conf -state disabled
1644 set difffilestart {}
1645}
1646
1647proc highlight_tag {f} {
1648 global highlight_paths
1649
1650 foreach p $highlight_paths {
1651 if {[string match $p $f]} {
1652 return "bold"
1653 }
1654 }
1655 return {}
1656}
1657
1658proc highlight_filelist {} {
1659 global cmitmode cflist
1660
1661 $cflist conf -state normal
1662 if {$cmitmode ne "tree"} {
1663 set end [lindex [split [$cflist index end] .] 0]
1664 for {set l 2} {$l < $end} {incr l} {
1665 set line [$cflist get $l.0 "$l.0 lineend"]
1666 if {[highlight_tag $line] ne {}} {
1667 $cflist tag add bold $l.0 "$l.0 lineend"
1668 }
1669 }
1670 } else {
1671 highlight_tree 2 {}
1672 }
1673 $cflist conf -state disabled
1674}
1675
1676proc unhighlight_filelist {} {
1677 global cflist
1678
1679 $cflist conf -state normal
1680 $cflist tag remove bold 1.0 end
1681 $cflist conf -state disabled
1682}
1683
1684proc add_flist {fl} {
1685 global cflist
1686
1687 $cflist conf -state normal
1688 foreach f $fl {
1689 $cflist insert end "\n"
1690 $cflist insert end $f [highlight_tag $f]
1691 }
1692 $cflist conf -state disabled
1693}
1694
1695proc sel_flist {w x y} {
1696 global ctext difffilestart cflist cflist_top cmitmode
1697
1698 if {$cmitmode eq "tree"} return
1699 if {![info exists cflist_top]} return
1700 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1701 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1702 $cflist tag add highlight $l.0 "$l.0 lineend"
1703 set cflist_top $l
1704 if {$l == 1} {
1705 $ctext yview 1.0
1706 } else {
1707 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1708 }
1709}
1710
1711proc pop_flist_menu {w X Y x y} {
1712 global ctext cflist cmitmode flist_menu flist_menu_file
1713 global treediffs diffids
1714
1715 stopfinding
1716 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1717 if {$l <= 1} return
1718 if {$cmitmode eq "tree"} {
1719 set e [linetoelt $l]
1720 if {[string index $e end] eq "/"} return
1721 } else {
1722 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1723 }
1724 set flist_menu_file $e
1725 tk_popup $flist_menu $X $Y
1726}
1727
1728proc flist_hl {only} {
1729 global flist_menu_file findstring gdttype
1730
1731 set x [shellquote $flist_menu_file]
1732 if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1733 set findstring $x
1734 } else {
1735 append findstring " " $x
1736 }
1737 set gdttype "touching paths:"
1738}
1739
1740# Functions for adding and removing shell-type quoting
1741
1742proc shellquote {str} {
1743 if {![string match "*\['\"\\ \t]*" $str]} {
1744 return $str
1745 }
1746 if {![string match "*\['\"\\]*" $str]} {
1747 return "\"$str\""
1748 }
1749 if {![string match "*'*" $str]} {
1750 return "'$str'"
1751 }
1752 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1753}
1754
1755proc shellarglist {l} {
1756 set str {}
1757 foreach a $l {
1758 if {$str ne {}} {
1759 append str " "
1760 }
1761 append str [shellquote $a]
1762 }
1763 return $str
1764}
1765
1766proc shelldequote {str} {
1767 set ret {}
1768 set used -1
1769 while {1} {
1770 incr used
1771 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1772 append ret [string range $str $used end]
1773 set used [string length $str]
1774 break
1775 }
1776 set first [lindex $first 0]
1777 set ch [string index $str $first]
1778 if {$first > $used} {
1779 append ret [string range $str $used [expr {$first - 1}]]
1780 set used $first
1781 }
1782 if {$ch eq " " || $ch eq "\t"} break
1783 incr used
1784 if {$ch eq "'"} {
1785 set first [string first "'" $str $used]
1786 if {$first < 0} {
1787 error "unmatched single-quote"
1788 }
1789 append ret [string range $str $used [expr {$first - 1}]]
1790 set used $first
1791 continue
1792 }
1793 if {$ch eq "\\"} {
1794 if {$used >= [string length $str]} {
1795 error "trailing backslash"
1796 }
1797 append ret [string index $str $used]
1798 continue
1799 }
1800 # here ch == "\""
1801 while {1} {
1802 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1803 error "unmatched double-quote"
1804 }
1805 set first [lindex $first 0]
1806 set ch [string index $str $first]
1807 if {$first > $used} {
1808 append ret [string range $str $used [expr {$first - 1}]]
1809 set used $first
1810 }
1811 if {$ch eq "\""} break
1812 incr used
1813 append ret [string index $str $used]
1814 incr used
1815 }
1816 }
1817 return [list $used $ret]
1818}
1819
1820proc shellsplit {str} {
1821 set l {}
1822 while {1} {
1823 set str [string trimleft $str]
1824 if {$str eq {}} break
1825 set dq [shelldequote $str]
1826 set n [lindex $dq 0]
1827 set word [lindex $dq 1]
1828 set str [string range $str $n end]
1829 lappend l $word
1830 }
1831 return $l
1832}
1833
1834# Code to implement multiple views
1835
1836proc newview {ishighlight} {
1837 global nextviewnum newviewname newviewperm uifont newishighlight
1838 global newviewargs revtreeargs
1839
1840 set newishighlight $ishighlight
1841 set top .gitkview
1842 if {[winfo exists $top]} {
1843 raise $top
1844 return
1845 }
1846 set newviewname($nextviewnum) "View $nextviewnum"
1847 set newviewperm($nextviewnum) 0
1848 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1849 vieweditor $top $nextviewnum "Gitk view definition"
1850}
1851
1852proc editview {} {
1853 global curview
1854 global viewname viewperm newviewname newviewperm
1855 global viewargs newviewargs
1856
1857 set top .gitkvedit-$curview
1858 if {[winfo exists $top]} {
1859 raise $top
1860 return
1861 }
1862 set newviewname($curview) $viewname($curview)
1863 set newviewperm($curview) $viewperm($curview)
1864 set newviewargs($curview) [shellarglist $viewargs($curview)]
1865 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1866}
1867
1868proc vieweditor {top n title} {
1869 global newviewname newviewperm viewfiles
1870 global uifont
1871
1872 toplevel $top
1873 wm title $top $title
1874 label $top.nl -text "Name" -font uifont
1875 entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1876 grid $top.nl $top.name -sticky w -pady 5
1877 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1878 -font uifont
1879 grid $top.perm - -pady 5 -sticky w
1880 message $top.al -aspect 1000 -font uifont \
1881 -text "Commits to include (arguments to git rev-list):"
1882 grid $top.al - -sticky w -pady 5
1883 entry $top.args -width 50 -textvariable newviewargs($n) \
1884 -background white -font uifont
1885 grid $top.args - -sticky ew -padx 5
1886 message $top.l -aspect 1000 -font uifont \
1887 -text "Enter files and directories to include, one per line:"
1888 grid $top.l - -sticky w
1889 text $top.t -width 40 -height 10 -background white -font uifont
1890 if {[info exists viewfiles($n)]} {
1891 foreach f $viewfiles($n) {
1892 $top.t insert end $f
1893 $top.t insert end "\n"
1894 }
1895 $top.t delete {end - 1c} end
1896 $top.t mark set insert 0.0
1897 }
1898 grid $top.t - -sticky ew -padx 5
1899 frame $top.buts
1900 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1901 -font uifont
1902 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1903 -font uifont
1904 grid $top.buts.ok $top.buts.can
1905 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1906 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1907 grid $top.buts - -pady 10 -sticky ew
1908 focus $top.t
1909}
1910
1911proc doviewmenu {m first cmd op argv} {
1912 set nmenu [$m index end]
1913 for {set i $first} {$i <= $nmenu} {incr i} {
1914 if {[$m entrycget $i -command] eq $cmd} {
1915 eval $m $op $i $argv
1916 break
1917 }
1918 }
1919}
1920
1921proc allviewmenus {n op args} {
1922 # global viewhlmenu
1923
1924 doviewmenu .bar.view 5 [list showview $n] $op $args
1925 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1926}
1927
1928proc newviewok {top n} {
1929 global nextviewnum newviewperm newviewname newishighlight
1930 global viewname viewfiles viewperm selectedview curview
1931 global viewargs newviewargs viewhlmenu
1932
1933 if {[catch {
1934 set newargs [shellsplit $newviewargs($n)]
1935 } err]} {
1936 error_popup "Error in commit selection arguments: $err"
1937 wm raise $top
1938 focus $top
1939 return
1940 }
1941 set files {}
1942 foreach f [split [$top.t get 0.0 end] "\n"] {
1943 set ft [string trim $f]
1944 if {$ft ne {}} {
1945 lappend files $ft
1946 }
1947 }
1948 if {![info exists viewfiles($n)]} {
1949 # creating a new view
1950 incr nextviewnum
1951 set viewname($n) $newviewname($n)
1952 set viewperm($n) $newviewperm($n)
1953 set viewfiles($n) $files
1954 set viewargs($n) $newargs
1955 addviewmenu $n
1956 if {!$newishighlight} {
1957 run showview $n
1958 } else {
1959 run addvhighlight $n
1960 }
1961 } else {
1962 # editing an existing view
1963 set viewperm($n) $newviewperm($n)
1964 if {$newviewname($n) ne $viewname($n)} {
1965 set viewname($n) $newviewname($n)
1966 doviewmenu .bar.view 5 [list showview $n] \
1967 entryconf [list -label $viewname($n)]
1968 # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1969 # entryconf [list -label $viewname($n) -value $viewname($n)]
1970 }
1971 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1972 set viewfiles($n) $files
1973 set viewargs($n) $newargs
1974 if {$curview == $n} {
1975 run updatecommits
1976 }
1977 }
1978 }
1979 catch {destroy $top}
1980}
1981
1982proc delview {} {
1983 global curview viewdata viewperm hlview selectedhlview
1984
1985 if {$curview == 0} return
1986 if {[info exists hlview] && $hlview == $curview} {
1987 set selectedhlview None
1988 unset hlview
1989 }
1990 allviewmenus $curview delete
1991 set viewdata($curview) {}
1992 set viewperm($curview) 0
1993 showview 0
1994}
1995
1996proc addviewmenu {n} {
1997 global viewname viewhlmenu
1998
1999 .bar.view add radiobutton -label $viewname($n) \
2000 -command [list showview $n] -variable selectedview -value $n
2001 #$viewhlmenu add radiobutton -label $viewname($n) \
2002 # -command [list addvhighlight $n] -variable selectedhlview
2003}
2004
2005proc flatten {var} {
2006 global $var
2007
2008 set ret {}
2009 foreach i [array names $var] {
2010 lappend ret $i [set $var\($i\)]
2011 }
2012 return $ret
2013}
2014
2015proc unflatten {var l} {
2016 global $var
2017
2018 catch {unset $var}
2019 foreach {i v} $l {
2020 set $var\($i\) $v
2021 }
2022}
2023
2024proc showview {n} {
2025 global curview viewdata viewfiles
2026 global displayorder parentlist rowidlist rowisopt rowfinal
2027 global colormap rowtextx commitrow nextcolor canvxmax
2028 global numcommits commitlisted
2029 global selectedline currentid canv canvy0
2030 global treediffs
2031 global pending_select phase
2032 global commitidx
2033 global commfd
2034 global selectedview selectfirst
2035 global vparentlist vdisporder vcmitlisted
2036 global hlview selectedhlview commitinterest
2037
2038 if {$n == $curview} return
2039 set selid {}
2040 if {[info exists selectedline]} {
2041 set selid $currentid
2042 set y [yc $selectedline]
2043 set ymax [lindex [$canv cget -scrollregion] 3]
2044 set span [$canv yview]
2045 set ytop [expr {[lindex $span 0] * $ymax}]
2046 set ybot [expr {[lindex $span 1] * $ymax}]
2047 if {$ytop < $y && $y < $ybot} {
2048 set yscreen [expr {$y - $ytop}]
2049 } else {
2050 set yscreen [expr {($ybot - $ytop) / 2}]
2051 }
2052 } elseif {[info exists pending_select]} {
2053 set selid $pending_select
2054 unset pending_select
2055 }
2056 unselectline
2057 normalline
2058 if {$curview >= 0} {
2059 set vparentlist($curview) $parentlist
2060 set vdisporder($curview) $displayorder
2061 set vcmitlisted($curview) $commitlisted
2062 if {$phase ne {} ||
2063 ![info exists viewdata($curview)] ||
2064 [lindex $viewdata($curview) 0] ne {}} {
2065 set viewdata($curview) \
2066 [list $phase $rowidlist $rowisopt $rowfinal]
2067 }
2068 }
2069 catch {unset treediffs}
2070 clear_display
2071 if {[info exists hlview] && $hlview == $n} {
2072 unset hlview
2073 set selectedhlview None
2074 }
2075 catch {unset commitinterest}
2076
2077 set curview $n
2078 set selectedview $n
2079 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2080 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2081
2082 run refill_reflist
2083 if {![info exists viewdata($n)]} {
2084 if {$selid ne {}} {
2085 set pending_select $selid
2086 }
2087 getcommits
2088 return
2089 }
2090
2091 set v $viewdata($n)
2092 set phase [lindex $v 0]
2093 set displayorder $vdisporder($n)
2094 set parentlist $vparentlist($n)
2095 set commitlisted $vcmitlisted($n)
2096 set rowidlist [lindex $v 1]
2097 set rowisopt [lindex $v 2]
2098 set rowfinal [lindex $v 3]
2099 set numcommits $commitidx($n)
2100
2101 catch {unset colormap}
2102 catch {unset rowtextx}
2103 set nextcolor 0
2104 set canvxmax [$canv cget -width]
2105 set curview $n
2106 set row 0
2107 setcanvscroll
2108 set yf 0
2109 set row {}
2110 set selectfirst 0
2111 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2112 set row $commitrow($n,$selid)
2113 # try to get the selected row in the same position on the screen
2114 set ymax [lindex [$canv cget -scrollregion] 3]
2115 set ytop [expr {[yc $row] - $yscreen}]
2116 if {$ytop < 0} {
2117 set ytop 0
2118 }
2119 set yf [expr {$ytop * 1.0 / $ymax}]
2120 }
2121 allcanvs yview moveto $yf
2122 drawvisible
2123 if {$row ne {}} {
2124 selectline $row 0
2125 } elseif {$selid ne {}} {
2126 set pending_select $selid
2127 } else {
2128 set row [first_real_row]
2129 if {$row < $numcommits} {
2130 selectline $row 0
2131 } else {
2132 set selectfirst 1
2133 }
2134 }
2135 if {$phase ne {}} {
2136 if {$phase eq "getcommits"} {
2137 show_status "Reading commits..."
2138 }
2139 run chewcommits $n
2140 } elseif {$numcommits == 0} {
2141 show_status "No commits selected"
2142 }
2143}
2144
2145# Stuff relating to the highlighting facility
2146
2147proc ishighlighted {row} {
2148 global vhighlights fhighlights nhighlights rhighlights
2149
2150 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2151 return $nhighlights($row)
2152 }
2153 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2154 return $vhighlights($row)
2155 }
2156 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2157 return $fhighlights($row)
2158 }
2159 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2160 return $rhighlights($row)
2161 }
2162 return 0
2163}
2164
2165proc bolden {row font} {
2166 global canv linehtag selectedline boldrows
2167
2168 lappend boldrows $row
2169 $canv itemconf $linehtag($row) -font $font
2170 if {[info exists selectedline] && $row == $selectedline} {
2171 $canv delete secsel
2172 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2173 -outline {{}} -tags secsel \
2174 -fill [$canv cget -selectbackground]]
2175 $canv lower $t
2176 }
2177}
2178
2179proc bolden_name {row font} {
2180 global canv2 linentag selectedline boldnamerows
2181
2182 lappend boldnamerows $row
2183 $canv2 itemconf $linentag($row) -font $font
2184 if {[info exists selectedline] && $row == $selectedline} {
2185 $canv2 delete secsel
2186 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2187 -outline {{}} -tags secsel \
2188 -fill [$canv2 cget -selectbackground]]
2189 $canv2 lower $t
2190 }
2191}
2192
2193proc unbolden {} {
2194 global boldrows
2195
2196 set stillbold {}
2197 foreach row $boldrows {
2198 if {![ishighlighted $row]} {
2199 bolden $row mainfont
2200 } else {
2201 lappend stillbold $row
2202 }
2203 }
2204 set boldrows $stillbold
2205}
2206
2207proc addvhighlight {n} {
2208 global hlview curview viewdata vhl_done vhighlights commitidx
2209
2210 if {[info exists hlview]} {
2211 delvhighlight
2212 }
2213 set hlview $n
2214 if {$n != $curview && ![info exists viewdata($n)]} {
2215 set viewdata($n) [list getcommits {{}} 0 0 0]
2216 set vparentlist($n) {}
2217 set vdisporder($n) {}
2218 set vcmitlisted($n) {}
2219 start_rev_list $n
2220 }
2221 set vhl_done $commitidx($hlview)
2222 if {$vhl_done > 0} {
2223 drawvisible
2224 }
2225}
2226
2227proc delvhighlight {} {
2228 global hlview vhighlights
2229
2230 if {![info exists hlview]} return
2231 unset hlview
2232 catch {unset vhighlights}
2233 unbolden
2234}
2235
2236proc vhighlightmore {} {
2237 global hlview vhl_done commitidx vhighlights
2238 global displayorder vdisporder curview
2239
2240 set max $commitidx($hlview)
2241 if {$hlview == $curview} {
2242 set disp $displayorder
2243 } else {
2244 set disp $vdisporder($hlview)
2245 }
2246 set vr [visiblerows]
2247 set r0 [lindex $vr 0]
2248 set r1 [lindex $vr 1]
2249 for {set i $vhl_done} {$i < $max} {incr i} {
2250 set id [lindex $disp $i]
2251 if {[info exists commitrow($curview,$id)]} {
2252 set row $commitrow($curview,$id)
2253 if {$r0 <= $row && $row <= $r1} {
2254 if {![highlighted $row]} {
2255 bolden $row mainfontbold
2256 }
2257 set vhighlights($row) 1
2258 }
2259 }
2260 }
2261 set vhl_done $max
2262}
2263
2264proc askvhighlight {row id} {
2265 global hlview vhighlights commitrow iddrawn
2266
2267 if {[info exists commitrow($hlview,$id)]} {
2268 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2269 bolden $row mainfontbold
2270 }
2271 set vhighlights($row) 1
2272 } else {
2273 set vhighlights($row) 0
2274 }
2275}
2276
2277proc hfiles_change {} {
2278 global highlight_files filehighlight fhighlights fh_serial
2279 global highlight_paths gdttype
2280
2281 if {[info exists filehighlight]} {
2282 # delete previous highlights
2283 catch {close $filehighlight}
2284 unset filehighlight
2285 catch {unset fhighlights}
2286 unbolden
2287 unhighlight_filelist
2288 }
2289 set highlight_paths {}
2290 after cancel do_file_hl $fh_serial
2291 incr fh_serial
2292 if {$highlight_files ne {}} {
2293 after 300 do_file_hl $fh_serial
2294 }
2295}
2296
2297proc gdttype_change {name ix op} {
2298 global gdttype highlight_files findstring findpattern
2299
2300 stopfinding
2301 if {$findstring ne {}} {
2302 if {$gdttype eq "containing:"} {
2303 if {$highlight_files ne {}} {
2304 set highlight_files {}
2305 hfiles_change
2306 }
2307 findcom_change
2308 } else {
2309 if {$findpattern ne {}} {
2310 set findpattern {}
2311 findcom_change
2312 }
2313 set highlight_files $findstring
2314 hfiles_change
2315 }
2316 drawvisible
2317 }
2318 # enable/disable findtype/findloc menus too
2319}
2320
2321proc find_change {name ix op} {
2322 global gdttype findstring highlight_files
2323
2324 stopfinding
2325 if {$gdttype eq "containing:"} {
2326 findcom_change
2327 } else {
2328 if {$highlight_files ne $findstring} {
2329 set highlight_files $findstring
2330 hfiles_change
2331 }
2332 }
2333 drawvisible
2334}
2335
2336proc findcom_change args {
2337 global nhighlights boldnamerows
2338 global findpattern findtype findstring gdttype
2339
2340 stopfinding
2341 # delete previous highlights, if any
2342 foreach row $boldnamerows {
2343 bolden_name $row mainfont
2344 }
2345 set boldnamerows {}
2346 catch {unset nhighlights}
2347 unbolden
2348 unmarkmatches
2349 if {$gdttype ne "containing:" || $findstring eq {}} {
2350 set findpattern {}
2351 } elseif {$findtype eq "Regexp"} {
2352 set findpattern $findstring
2353 } else {
2354 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2355 $findstring]
2356 set findpattern "*$e*"
2357 }
2358}
2359
2360proc makepatterns {l} {
2361 set ret {}
2362 foreach e $l {
2363 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2364 if {[string index $ee end] eq "/"} {
2365 lappend ret "$ee*"
2366 } else {
2367 lappend ret $ee
2368 lappend ret "$ee/*"
2369 }
2370 }
2371 return $ret
2372}
2373
2374proc do_file_hl {serial} {
2375 global highlight_files filehighlight highlight_paths gdttype fhl_list
2376
2377 if {$gdttype eq "touching paths:"} {
2378 if {[catch {set paths [shellsplit $highlight_files]}]} return
2379 set highlight_paths [makepatterns $paths]
2380 highlight_filelist
2381 set gdtargs [concat -- $paths]
2382 } elseif {$gdttype eq "adding/removing string:"} {
2383 set gdtargs [list "-S$highlight_files"]
2384 } else {
2385 # must be "containing:", i.e. we're searching commit info
2386 return
2387 }
2388 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2389 set filehighlight [open $cmd r+]
2390 fconfigure $filehighlight -blocking 0
2391 filerun $filehighlight readfhighlight
2392 set fhl_list {}
2393 drawvisible
2394 flushhighlights
2395}
2396
2397proc flushhighlights {} {
2398 global filehighlight fhl_list
2399
2400 if {[info exists filehighlight]} {
2401 lappend fhl_list {}
2402 puts $filehighlight ""
2403 flush $filehighlight
2404 }
2405}
2406
2407proc askfilehighlight {row id} {
2408 global filehighlight fhighlights fhl_list
2409
2410 lappend fhl_list $id
2411 set fhighlights($row) -1
2412 puts $filehighlight $id
2413}
2414
2415proc readfhighlight {} {
2416 global filehighlight fhighlights commitrow curview iddrawn
2417 global fhl_list find_dirn
2418
2419 if {![info exists filehighlight]} {
2420 return 0
2421 }
2422 set nr 0
2423 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2424 set line [string trim $line]
2425 set i [lsearch -exact $fhl_list $line]
2426 if {$i < 0} continue
2427 for {set j 0} {$j < $i} {incr j} {
2428 set id [lindex $fhl_list $j]
2429 if {[info exists commitrow($curview,$id)]} {
2430 set fhighlights($commitrow($curview,$id)) 0
2431 }
2432 }
2433 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2434 if {$line eq {}} continue
2435 if {![info exists commitrow($curview,$line)]} continue
2436 set row $commitrow($curview,$line)
2437 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2438 bolden $row mainfontbold
2439 }
2440 set fhighlights($row) 1
2441 }
2442 if {[eof $filehighlight]} {
2443 # strange...
2444 puts "oops, git diff-tree died"
2445 catch {close $filehighlight}
2446 unset filehighlight
2447 return 0
2448 }
2449 if {[info exists find_dirn]} {
2450 if {$find_dirn > 0} {
2451 run findmore
2452 } else {
2453 run findmorerev
2454 }
2455 }
2456 return 1
2457}
2458
2459proc doesmatch {f} {
2460 global findtype findpattern
2461
2462 if {$findtype eq "Regexp"} {
2463 return [regexp $findpattern $f]
2464 } elseif {$findtype eq "IgnCase"} {
2465 return [string match -nocase $findpattern $f]
2466 } else {
2467 return [string match $findpattern $f]
2468 }
2469}
2470
2471proc askfindhighlight {row id} {
2472 global nhighlights commitinfo iddrawn
2473 global findloc
2474 global markingmatches
2475
2476 if {![info exists commitinfo($id)]} {
2477 getcommit $id
2478 }
2479 set info $commitinfo($id)
2480 set isbold 0
2481 set fldtypes {Headline Author Date Committer CDate Comments}
2482 foreach f $info ty $fldtypes {
2483 if {($findloc eq "All fields" || $findloc eq $ty) &&
2484 [doesmatch $f]} {
2485 if {$ty eq "Author"} {
2486 set isbold 2
2487 break
2488 }
2489 set isbold 1
2490 }
2491 }
2492 if {$isbold && [info exists iddrawn($id)]} {
2493 if {![ishighlighted $row]} {
2494 bolden $row mainfontbold
2495 if {$isbold > 1} {
2496 bolden_name $row mainfontbold
2497 }
2498 }
2499 if {$markingmatches} {
2500 markrowmatches $row $id
2501 }
2502 }
2503 set nhighlights($row) $isbold
2504}
2505
2506proc markrowmatches {row id} {
2507 global canv canv2 linehtag linentag commitinfo findloc
2508
2509 set headline [lindex $commitinfo($id) 0]
2510 set author [lindex $commitinfo($id) 1]
2511 $canv delete match$row
2512 $canv2 delete match$row
2513 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2514 set m [findmatches $headline]
2515 if {$m ne {}} {
2516 markmatches $canv $row $headline $linehtag($row) $m \
2517 [$canv itemcget $linehtag($row) -font] $row
2518 }
2519 }
2520 if {$findloc eq "All fields" || $findloc eq "Author"} {
2521 set m [findmatches $author]
2522 if {$m ne {}} {
2523 markmatches $canv2 $row $author $linentag($row) $m \
2524 [$canv2 itemcget $linentag($row) -font] $row
2525 }
2526 }
2527}
2528
2529proc vrel_change {name ix op} {
2530 global highlight_related
2531
2532 rhighlight_none
2533 if {$highlight_related ne "None"} {
2534 run drawvisible
2535 }
2536}
2537
2538# prepare for testing whether commits are descendents or ancestors of a
2539proc rhighlight_sel {a} {
2540 global descendent desc_todo ancestor anc_todo
2541 global highlight_related rhighlights
2542
2543 catch {unset descendent}
2544 set desc_todo [list $a]
2545 catch {unset ancestor}
2546 set anc_todo [list $a]
2547 if {$highlight_related ne "None"} {
2548 rhighlight_none
2549 run drawvisible
2550 }
2551}
2552
2553proc rhighlight_none {} {
2554 global rhighlights
2555
2556 catch {unset rhighlights}
2557 unbolden
2558}
2559
2560proc is_descendent {a} {
2561 global curview children commitrow descendent desc_todo
2562
2563 set v $curview
2564 set la $commitrow($v,$a)
2565 set todo $desc_todo
2566 set leftover {}
2567 set done 0
2568 for {set i 0} {$i < [llength $todo]} {incr i} {
2569 set do [lindex $todo $i]
2570 if {$commitrow($v,$do) < $la} {
2571 lappend leftover $do
2572 continue
2573 }
2574 foreach nk $children($v,$do) {
2575 if {![info exists descendent($nk)]} {
2576 set descendent($nk) 1
2577 lappend todo $nk
2578 if {$nk eq $a} {
2579 set done 1
2580 }
2581 }
2582 }
2583 if {$done} {
2584 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2585 return
2586 }
2587 }
2588 set descendent($a) 0
2589 set desc_todo $leftover
2590}
2591
2592proc is_ancestor {a} {
2593 global curview parentlist commitrow ancestor anc_todo
2594
2595 set v $curview
2596 set la $commitrow($v,$a)
2597 set todo $anc_todo
2598 set leftover {}
2599 set done 0
2600 for {set i 0} {$i < [llength $todo]} {incr i} {
2601 set do [lindex $todo $i]
2602 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2603 lappend leftover $do
2604 continue
2605 }
2606 foreach np [lindex $parentlist $commitrow($v,$do)] {
2607 if {![info exists ancestor($np)]} {
2608 set ancestor($np) 1
2609 lappend todo $np
2610 if {$np eq $a} {
2611 set done 1
2612 }
2613 }
2614 }
2615 if {$done} {
2616 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2617 return
2618 }
2619 }
2620 set ancestor($a) 0
2621 set anc_todo $leftover
2622}
2623
2624proc askrelhighlight {row id} {
2625 global descendent highlight_related iddrawn rhighlights
2626 global selectedline ancestor
2627
2628 if {![info exists selectedline]} return
2629 set isbold 0
2630 if {$highlight_related eq "Descendent" ||
2631 $highlight_related eq "Not descendent"} {
2632 if {![info exists descendent($id)]} {
2633 is_descendent $id
2634 }
2635 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2636 set isbold 1
2637 }
2638 } elseif {$highlight_related eq "Ancestor" ||
2639 $highlight_related eq "Not ancestor"} {
2640 if {![info exists ancestor($id)]} {
2641 is_ancestor $id
2642 }
2643 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2644 set isbold 1
2645 }
2646 }
2647 if {[info exists iddrawn($id)]} {
2648 if {$isbold && ![ishighlighted $row]} {
2649 bolden $row mainfontbold
2650 }
2651 }
2652 set rhighlights($row) $isbold
2653}
2654
2655# Graph layout functions
2656
2657proc shortids {ids} {
2658 set res {}
2659 foreach id $ids {
2660 if {[llength $id] > 1} {
2661 lappend res [shortids $id]
2662 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2663 lappend res [string range $id 0 7]
2664 } else {
2665 lappend res $id
2666 }
2667 }
2668 return $res
2669}
2670
2671proc ntimes {n o} {
2672 set ret {}
2673 set o [list $o]
2674 for {set mask 1} {$mask <= $n} {incr mask $mask} {
2675 if {($n & $mask) != 0} {
2676 set ret [concat $ret $o]
2677 }
2678 set o [concat $o $o]
2679 }
2680 return $ret
2681}
2682
2683# Work out where id should go in idlist so that order-token
2684# values increase from left to right
2685proc idcol {idlist id {i 0}} {
2686 global ordertok curview
2687
2688 set t $ordertok($curview,$id)
2689 if {$i >= [llength $idlist] ||
2690 $t < $ordertok($curview,[lindex $idlist $i])} {
2691 if {$i > [llength $idlist]} {
2692 set i [llength $idlist]
2693 }
2694 while {[incr i -1] >= 0 &&
2695 $t < $ordertok($curview,[lindex $idlist $i])} {}
2696 incr i
2697 } else {
2698 if {$t > $ordertok($curview,[lindex $idlist $i])} {
2699 while {[incr i] < [llength $idlist] &&
2700 $t >= $ordertok($curview,[lindex $idlist $i])} {}
2701 }
2702 }
2703 return $i
2704}
2705
2706proc initlayout {} {
2707 global rowidlist rowisopt rowfinal displayorder commitlisted
2708 global numcommits canvxmax canv
2709 global nextcolor
2710 global parentlist
2711 global colormap rowtextx
2712 global selectfirst
2713
2714 set numcommits 0
2715 set displayorder {}
2716 set commitlisted {}
2717 set parentlist {}
2718 set nextcolor 0
2719 set rowidlist {}
2720 set rowisopt {}
2721 set rowfinal {}
2722 set canvxmax [$canv cget -width]
2723 catch {unset colormap}
2724 catch {unset rowtextx}
2725 set selectfirst 1
2726}
2727
2728proc setcanvscroll {} {
2729 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2730
2731 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2732 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2733 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2734 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2735}
2736
2737proc visiblerows {} {
2738 global canv numcommits linespc
2739
2740 set ymax [lindex [$canv cget -scrollregion] 3]
2741 if {$ymax eq {} || $ymax == 0} return
2742 set f [$canv yview]
2743 set y0 [expr {int([lindex $f 0] * $ymax)}]
2744 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2745 if {$r0 < 0} {
2746 set r0 0
2747 }
2748 set y1 [expr {int([lindex $f 1] * $ymax)}]
2749 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2750 if {$r1 >= $numcommits} {
2751 set r1 [expr {$numcommits - 1}]
2752 }
2753 return [list $r0 $r1]
2754}
2755
2756proc layoutmore {} {
2757 global commitidx viewcomplete numcommits
2758 global uparrowlen downarrowlen mingaplen curview
2759
2760 set show $commitidx($curview)
2761 if {$show > $numcommits || $viewcomplete($curview)} {
2762 showstuff $show $viewcomplete($curview)
2763 }
2764}
2765
2766proc showstuff {canshow last} {
2767 global numcommits commitrow pending_select selectedline curview
2768 global mainheadid displayorder selectfirst
2769 global lastscrollset commitinterest
2770
2771 if {$numcommits == 0} {
2772 global phase
2773 set phase "incrdraw"
2774 allcanvs delete all
2775 }
2776 set r0 $numcommits
2777 set prev $numcommits
2778 set numcommits $canshow
2779 set t [clock clicks -milliseconds]
2780 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2781 set lastscrollset $t
2782 setcanvscroll
2783 }
2784 set rows [visiblerows]
2785 set r1 [lindex $rows 1]
2786 if {$r1 >= $canshow} {
2787 set r1 [expr {$canshow - 1}]
2788 }
2789 if {$r0 <= $r1} {
2790 drawcommits $r0 $r1
2791 }
2792 if {[info exists pending_select] &&
2793 [info exists commitrow($curview,$pending_select)] &&
2794 $commitrow($curview,$pending_select) < $numcommits} {
2795 selectline $commitrow($curview,$pending_select) 1
2796 }
2797 if {$selectfirst} {
2798 if {[info exists selectedline] || [info exists pending_select]} {
2799 set selectfirst 0
2800 } else {
2801 set l [first_real_row]
2802 selectline $l 1
2803 set selectfirst 0
2804 }
2805 }
2806}
2807
2808proc doshowlocalchanges {} {
2809 global curview mainheadid phase commitrow
2810
2811 if {[info exists commitrow($curview,$mainheadid)] &&
2812 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2813 dodiffindex
2814 } elseif {$phase ne {}} {
2815 lappend commitinterest($mainheadid) {}
2816 }
2817}
2818
2819proc dohidelocalchanges {} {
2820 global localfrow localirow lserial
2821
2822 if {$localfrow >= 0} {
2823 removerow $localfrow
2824 set localfrow -1
2825 if {$localirow > 0} {
2826 incr localirow -1
2827 }
2828 }
2829 if {$localirow >= 0} {
2830 removerow $localirow
2831 set localirow -1
2832 }
2833 incr lserial
2834}
2835
2836# spawn off a process to do git diff-index --cached HEAD
2837proc dodiffindex {} {
2838 global localirow localfrow lserial showlocalchanges
2839
2840 if {!$showlocalchanges} return
2841 incr lserial
2842 set localfrow -1
2843 set localirow -1
2844 set fd [open "|git diff-index --cached HEAD" r]
2845 fconfigure $fd -blocking 0
2846 filerun $fd [list readdiffindex $fd $lserial]
2847}
2848
2849proc readdiffindex {fd serial} {
2850 global localirow commitrow mainheadid nullid2 curview
2851 global commitinfo commitdata lserial
2852
2853 set isdiff 1
2854 if {[gets $fd line] < 0} {
2855 if {![eof $fd]} {
2856 return 1
2857 }
2858 set isdiff 0
2859 }
2860 # we only need to see one line and we don't really care what it says...
2861 close $fd
2862
2863 # now see if there are any local changes not checked in to the index
2864 if {$serial == $lserial} {
2865 set fd [open "|git diff-files" r]
2866 fconfigure $fd -blocking 0
2867 filerun $fd [list readdifffiles $fd $serial]
2868 }
2869
2870 if {$isdiff && $serial == $lserial && $localirow == -1} {
2871 # add the line for the changes in the index to the graph
2872 set localirow $commitrow($curview,$mainheadid)
2873 set hl "Local changes checked in to index but not committed"
2874 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2875 set commitdata($nullid2) "\n $hl\n"
2876 insertrow $localirow $nullid2
2877 }
2878 return 0
2879}
2880
2881proc readdifffiles {fd serial} {
2882 global localirow localfrow commitrow mainheadid nullid curview
2883 global commitinfo commitdata lserial
2884
2885 set isdiff 1
2886 if {[gets $fd line] < 0} {
2887 if {![eof $fd]} {
2888 return 1
2889 }
2890 set isdiff 0
2891 }
2892 # we only need to see one line and we don't really care what it says...
2893 close $fd
2894
2895 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2896 # add the line for the local diff to the graph
2897 if {$localirow >= 0} {
2898 set localfrow $localirow
2899 incr localirow
2900 } else {
2901 set localfrow $commitrow($curview,$mainheadid)
2902 }
2903 set hl "Local uncommitted changes, not checked in to index"
2904 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2905 set commitdata($nullid) "\n $hl\n"
2906 insertrow $localfrow $nullid
2907 }
2908 return 0
2909}
2910
2911proc nextuse {id row} {
2912 global commitrow curview children
2913
2914 if {[info exists children($curview,$id)]} {
2915 foreach kid $children($curview,$id) {
2916 if {![info exists commitrow($curview,$kid)]} {
2917 return -1
2918 }
2919 if {$commitrow($curview,$kid) > $row} {
2920 return $commitrow($curview,$kid)
2921 }
2922 }
2923 }
2924 if {[info exists commitrow($curview,$id)]} {
2925 return $commitrow($curview,$id)
2926 }
2927 return -1
2928}
2929
2930proc prevuse {id row} {
2931 global commitrow curview children
2932
2933 set ret -1
2934 if {[info exists children($curview,$id)]} {
2935 foreach kid $children($curview,$id) {
2936 if {![info exists commitrow($curview,$kid)]} break
2937 if {$commitrow($curview,$kid) < $row} {
2938 set ret $commitrow($curview,$kid)
2939 }
2940 }
2941 }
2942 return $ret
2943}
2944
2945proc make_idlist {row} {
2946 global displayorder parentlist uparrowlen downarrowlen mingaplen
2947 global commitidx curview ordertok children commitrow
2948
2949 set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2950 if {$r < 0} {
2951 set r 0
2952 }
2953 set ra [expr {$row - $downarrowlen}]
2954 if {$ra < 0} {
2955 set ra 0
2956 }
2957 set rb [expr {$row + $uparrowlen}]
2958 if {$rb > $commitidx($curview)} {
2959 set rb $commitidx($curview)
2960 }
2961 set ids {}
2962 for {} {$r < $ra} {incr r} {
2963 set nextid [lindex $displayorder [expr {$r + 1}]]
2964 foreach p [lindex $parentlist $r] {
2965 if {$p eq $nextid} continue
2966 set rn [nextuse $p $r]
2967 if {$rn >= $row &&
2968 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2969 lappend ids [list $ordertok($curview,$p) $p]
2970 }
2971 }
2972 }
2973 for {} {$r < $row} {incr r} {
2974 set nextid [lindex $displayorder [expr {$r + 1}]]
2975 foreach p [lindex $parentlist $r] {
2976 if {$p eq $nextid} continue
2977 set rn [nextuse $p $r]
2978 if {$rn < 0 || $rn >= $row} {
2979 lappend ids [list $ordertok($curview,$p) $p]
2980 }
2981 }
2982 }
2983 set id [lindex $displayorder $row]
2984 lappend ids [list $ordertok($curview,$id) $id]
2985 while {$r < $rb} {
2986 foreach p [lindex $parentlist $r] {
2987 set firstkid [lindex $children($curview,$p) 0]
2988 if {$commitrow($curview,$firstkid) < $row} {
2989 lappend ids [list $ordertok($curview,$p) $p]
2990 }
2991 }
2992 incr r
2993 set id [lindex $displayorder $r]
2994 if {$id ne {}} {
2995 set firstkid [lindex $children($curview,$id) 0]
2996 if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
2997 lappend ids [list $ordertok($curview,$id) $id]
2998 }
2999 }
3000 }
3001 set idlist {}
3002 foreach idx [lsort -unique $ids] {
3003 lappend idlist [lindex $idx 1]
3004 }
3005 return $idlist
3006}
3007
3008proc rowsequal {a b} {
3009 while {[set i [lsearch -exact $a {}]] >= 0} {
3010 set a [lreplace $a $i $i]
3011 }
3012 while {[set i [lsearch -exact $b {}]] >= 0} {
3013 set b [lreplace $b $i $i]
3014 }
3015 return [expr {$a eq $b}]
3016}
3017
3018proc makeupline {id row rend col} {
3019 global rowidlist uparrowlen downarrowlen mingaplen
3020
3021 for {set r $rend} {1} {set r $rstart} {
3022 set rstart [prevuse $id $r]
3023 if {$rstart < 0} return
3024 if {$rstart < $row} break
3025 }
3026 if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3027 set rstart [expr {$rend - $uparrowlen - 1}]
3028 }
3029 for {set r $rstart} {[incr r] <= $row} {} {
3030 set idlist [lindex $rowidlist $r]
3031 if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3032 set col [idcol $idlist $id $col]
3033 lset rowidlist $r [linsert $idlist $col $id]
3034 changedrow $r
3035 }
3036 }
3037}
3038
3039proc layoutrows {row endrow} {
3040 global rowidlist rowisopt rowfinal displayorder
3041 global uparrowlen downarrowlen maxwidth mingaplen
3042 global children parentlist
3043 global commitidx viewcomplete curview commitrow
3044
3045 set idlist {}
3046 if {$row > 0} {
3047 set rm1 [expr {$row - 1}]
3048 foreach id [lindex $rowidlist $rm1] {
3049 if {$id ne {}} {
3050 lappend idlist $id
3051 }
3052 }
3053 set final [lindex $rowfinal $rm1]
3054 }
3055 for {} {$row < $endrow} {incr row} {
3056 set rm1 [expr {$row - 1}]
3057 if {$rm1 < 0 || $idlist eq {}} {
3058 set idlist [make_idlist $row]
3059 set final 1
3060 } else {
3061 set id [lindex $displayorder $rm1]
3062 set col [lsearch -exact $idlist $id]
3063 set idlist [lreplace $idlist $col $col]
3064 foreach p [lindex $parentlist $rm1] {
3065 if {[lsearch -exact $idlist $p] < 0} {
3066 set col [idcol $idlist $p $col]
3067 set idlist [linsert $idlist $col $p]
3068 # if not the first child, we have to insert a line going up
3069 if {$id ne [lindex $children($curview,$p) 0]} {
3070 makeupline $p $rm1 $row $col
3071 }
3072 }
3073 }
3074 set id [lindex $displayorder $row]
3075 if {$row > $downarrowlen} {
3076 set termrow [expr {$row - $downarrowlen - 1}]
3077 foreach p [lindex $parentlist $termrow] {
3078 set i [lsearch -exact $idlist $p]
3079 if {$i < 0} continue
3080 set nr [nextuse $p $termrow]
3081 if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3082 set idlist [lreplace $idlist $i $i]
3083 }
3084 }
3085 }
3086 set col [lsearch -exact $idlist $id]
3087 if {$col < 0} {
3088 set col [idcol $idlist $id]
3089 set idlist [linsert $idlist $col $id]
3090 if {$children($curview,$id) ne {}} {
3091 makeupline $id $rm1 $row $col
3092 }
3093 }
3094 set r [expr {$row + $uparrowlen - 1}]
3095 if {$r < $commitidx($curview)} {
3096 set x $col
3097 foreach p [lindex $parentlist $r] {
3098 if {[lsearch -exact $idlist $p] >= 0} continue
3099 set fk [lindex $children($curview,$p) 0]
3100 if {$commitrow($curview,$fk) < $row} {
3101 set x [idcol $idlist $p $x]
3102 set idlist [linsert $idlist $x $p]
3103 }
3104 }
3105 if {[incr r] < $commitidx($curview)} {
3106 set p [lindex $displayorder $r]
3107 if {[lsearch -exact $idlist $p] < 0} {
3108 set fk [lindex $children($curview,$p) 0]
3109 if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3110 set x [idcol $idlist $p $x]
3111 set idlist [linsert $idlist $x $p]
3112 }
3113 }
3114 }
3115 }
3116 }
3117 if {$final && !$viewcomplete($curview) &&
3118 $row + $uparrowlen + $mingaplen + $downarrowlen
3119 >= $commitidx($curview)} {
3120 set final 0
3121 }
3122 set l [llength $rowidlist]
3123 if {$row == $l} {
3124 lappend rowidlist $idlist
3125 lappend rowisopt 0
3126 lappend rowfinal $final
3127 } elseif {$row < $l} {
3128 if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3129 lset rowidlist $row $idlist
3130 changedrow $row
3131 }
3132 lset rowfinal $row $final
3133 } else {
3134 set pad [ntimes [expr {$row - $l}] {}]
3135 set rowidlist [concat $rowidlist $pad]
3136 lappend rowidlist $idlist
3137 set rowfinal [concat $rowfinal $pad]
3138 lappend rowfinal $final
3139 set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3140 }
3141 }
3142 return $row
3143}
3144
3145proc changedrow {row} {
3146 global displayorder iddrawn rowisopt need_redisplay
3147
3148 set l [llength $rowisopt]
3149 if {$row < $l} {
3150 lset rowisopt $row 0
3151 if {$row + 1 < $l} {
3152 lset rowisopt [expr {$row + 1}] 0
3153 if {$row + 2 < $l} {
3154 lset rowisopt [expr {$row + 2}] 0
3155 }
3156 }
3157 }
3158 set id [lindex $displayorder $row]
3159 if {[info exists iddrawn($id)]} {
3160 set need_redisplay 1
3161 }
3162}
3163
3164proc insert_pad {row col npad} {
3165 global rowidlist
3166
3167 set pad [ntimes $npad {}]
3168 set idlist [lindex $rowidlist $row]
3169 set bef [lrange $idlist 0 [expr {$col - 1}]]
3170 set aft [lrange $idlist $col end]
3171 set i [lsearch -exact $aft {}]
3172 if {$i > 0} {
3173 set aft [lreplace $aft $i $i]
3174 }
3175 lset rowidlist $row [concat $bef $pad $aft]
3176 changedrow $row
3177}
3178
3179proc optimize_rows {row col endrow} {
3180 global rowidlist rowisopt displayorder curview children
3181
3182 if {$row < 1} {
3183 set row 1
3184 }
3185 for {} {$row < $endrow} {incr row; set col 0} {
3186 if {[lindex $rowisopt $row]} continue
3187 set haspad 0
3188 set y0 [expr {$row - 1}]
3189 set ym [expr {$row - 2}]
3190 set idlist [lindex $rowidlist $row]
3191 set previdlist [lindex $rowidlist $y0]
3192 if {$idlist eq {} || $previdlist eq {}} continue
3193 if {$ym >= 0} {
3194 set pprevidlist [lindex $rowidlist $ym]
3195 if {$pprevidlist eq {}} continue
3196 } else {
3197 set pprevidlist {}
3198 }
3199 set x0 -1
3200 set xm -1
3201 for {} {$col < [llength $idlist]} {incr col} {
3202 set id [lindex $idlist $col]
3203 if {[lindex $previdlist $col] eq $id} continue
3204 if {$id eq {}} {
3205 set haspad 1
3206 continue
3207 }
3208 set x0 [lsearch -exact $previdlist $id]
3209 if {$x0 < 0} continue
3210 set z [expr {$x0 - $col}]
3211 set isarrow 0
3212 set z0 {}
3213 if {$ym >= 0} {
3214 set xm [lsearch -exact $pprevidlist $id]
3215 if {$xm >= 0} {
3216 set z0 [expr {$xm - $x0}]
3217 }
3218 }
3219 if {$z0 eq {}} {
3220 # if row y0 is the first child of $id then it's not an arrow
3221 if {[lindex $children($curview,$id) 0] ne
3222 [lindex $displayorder $y0]} {
3223 set isarrow 1
3224 }
3225 }
3226 if {!$isarrow && $id ne [lindex $displayorder $row] &&
3227 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3228 set isarrow 1
3229 }
3230 # Looking at lines from this row to the previous row,
3231 # make them go straight up if they end in an arrow on
3232 # the previous row; otherwise make them go straight up
3233 # or at 45 degrees.
3234 if {$z < -1 || ($z < 0 && $isarrow)} {
3235 # Line currently goes left too much;
3236 # insert pads in the previous row, then optimize it
3237 set npad [expr {-1 - $z + $isarrow}]
3238 insert_pad $y0 $x0 $npad
3239 if {$y0 > 0} {
3240 optimize_rows $y0 $x0 $row
3241 }
3242 set previdlist [lindex $rowidlist $y0]
3243 set x0 [lsearch -exact $previdlist $id]
3244 set z [expr {$x0 - $col}]
3245 if {$z0 ne {}} {
3246 set pprevidlist [lindex $rowidlist $ym]
3247 set xm [lsearch -exact $pprevidlist $id]
3248 set z0 [expr {$xm - $x0}]
3249 }
3250 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3251 # Line currently goes right too much;
3252 # insert pads in this line
3253 set npad [expr {$z - 1 + $isarrow}]
3254 insert_pad $row $col $npad
3255 set idlist [lindex $rowidlist $row]
3256 incr col $npad
3257 set z [expr {$x0 - $col}]
3258 set haspad 1
3259 }
3260 if {$z0 eq {} && !$isarrow && $ym >= 0} {
3261 # this line links to its first child on row $row-2
3262 set id [lindex $displayorder $ym]
3263 set xc [lsearch -exact $pprevidlist $id]
3264 if {$xc >= 0} {
3265 set z0 [expr {$xc - $x0}]
3266 }
3267 }
3268 # avoid lines jigging left then immediately right
3269 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3270 insert_pad $y0 $x0 1
3271 incr x0
3272 optimize_rows $y0 $x0 $row
3273 set previdlist [lindex $rowidlist $y0]
3274 }
3275 }
3276 if {!$haspad} {
3277 # Find the first column that doesn't have a line going right
3278 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3279 set id [lindex $idlist $col]
3280 if {$id eq {}} break
3281 set x0 [lsearch -exact $previdlist $id]
3282 if {$x0 < 0} {
3283 # check if this is the link to the first child
3284 set kid [lindex $displayorder $y0]
3285 if {[lindex $children($curview,$id) 0] eq $kid} {
3286 # it is, work out offset to child
3287 set x0 [lsearch -exact $previdlist $kid]
3288 }
3289 }
3290 if {$x0 <= $col} break
3291 }
3292 # Insert a pad at that column as long as it has a line and
3293 # isn't the last column
3294 if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3295 set idlist [linsert $idlist $col {}]
3296 lset rowidlist $row $idlist
3297 changedrow $row
3298 }
3299 }
3300 }
3301}
3302
3303proc xc {row col} {
3304 global canvx0 linespc
3305 return [expr {$canvx0 + $col * $linespc}]
3306}
3307
3308proc yc {row} {
3309 global canvy0 linespc
3310 return [expr {$canvy0 + $row * $linespc}]
3311}
3312
3313proc linewidth {id} {
3314 global thickerline lthickness
3315
3316 set wid $lthickness
3317 if {[info exists thickerline] && $id eq $thickerline} {
3318 set wid [expr {2 * $lthickness}]
3319 }
3320 return $wid
3321}
3322
3323proc rowranges {id} {
3324 global commitrow curview children uparrowlen downarrowlen
3325 global rowidlist
3326
3327 set kids $children($curview,$id)
3328 if {$kids eq {}} {
3329 return {}
3330 }
3331 set ret {}
3332 lappend kids $id
3333 foreach child $kids {
3334 if {![info exists commitrow($curview,$child)]} break
3335 set row $commitrow($curview,$child)
3336 if {![info exists prev]} {
3337 lappend ret [expr {$row + 1}]
3338 } else {
3339 if {$row <= $prevrow} {
3340 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3341 }
3342 # see if the line extends the whole way from prevrow to row
3343 if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3344 [lsearch -exact [lindex $rowidlist \
3345 [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3346 # it doesn't, see where it ends
3347 set r [expr {$prevrow + $downarrowlen}]
3348 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3349 while {[incr r -1] > $prevrow &&
3350 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3351 } else {
3352 while {[incr r] <= $row &&
3353 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3354 incr r -1
3355 }
3356 lappend ret $r
3357 # see where it starts up again
3358 set r [expr {$row - $uparrowlen}]
3359 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3360 while {[incr r] < $row &&
3361 [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3362 } else {
3363 while {[incr r -1] >= $prevrow &&
3364 [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3365 incr r
3366 }
3367 lappend ret $r
3368 }
3369 }
3370 if {$child eq $id} {
3371 lappend ret $row
3372 }
3373 set prev $id
3374 set prevrow $row
3375 }
3376 return $ret
3377}
3378
3379proc drawlineseg {id row endrow arrowlow} {
3380 global rowidlist displayorder iddrawn linesegs
3381 global canv colormap linespc curview maxlinelen parentlist
3382
3383 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3384 set le [expr {$row + 1}]
3385 set arrowhigh 1
3386 while {1} {
3387 set c [lsearch -exact [lindex $rowidlist $le] $id]
3388 if {$c < 0} {
3389 incr le -1
3390 break
3391 }
3392 lappend cols $c
3393 set x [lindex $displayorder $le]
3394 if {$x eq $id} {
3395 set arrowhigh 0
3396 break
3397 }
3398 if {[info exists iddrawn($x)] || $le == $endrow} {
3399 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3400 if {$c >= 0} {
3401 lappend cols $c
3402 set arrowhigh 0
3403 }
3404 break
3405 }
3406 incr le
3407 }
3408 if {$le <= $row} {
3409 return $row
3410 }
3411
3412 set lines {}
3413 set i 0
3414 set joinhigh 0
3415 if {[info exists linesegs($id)]} {
3416 set lines $linesegs($id)
3417 foreach li $lines {
3418 set r0 [lindex $li 0]
3419 if {$r0 > $row} {
3420 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3421 set joinhigh 1
3422 }
3423 break
3424 }
3425 incr i
3426 }
3427 }
3428 set joinlow 0
3429 if {$i > 0} {
3430 set li [lindex $lines [expr {$i-1}]]
3431 set r1 [lindex $li 1]
3432 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3433 set joinlow 1
3434 }
3435 }
3436
3437 set x [lindex $cols [expr {$le - $row}]]
3438 set xp [lindex $cols [expr {$le - 1 - $row}]]
3439 set dir [expr {$xp - $x}]
3440 if {$joinhigh} {
3441 set ith [lindex $lines $i 2]
3442 set coords [$canv coords $ith]
3443 set ah [$canv itemcget $ith -arrow]
3444 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3445 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3446 if {$x2 ne {} && $x - $x2 == $dir} {
3447 set coords [lrange $coords 0 end-2]
3448 }
3449 } else {
3450 set coords [list [xc $le $x] [yc $le]]
3451 }
3452 if {$joinlow} {
3453 set itl [lindex $lines [expr {$i-1}] 2]
3454 set al [$canv itemcget $itl -arrow]
3455 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3456 } elseif {$arrowlow} {
3457 if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3458 [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3459 set arrowlow 0
3460 }
3461 }
3462 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3463 for {set y $le} {[incr y -1] > $row} {} {
3464 set x $xp
3465 set xp [lindex $cols [expr {$y - 1 - $row}]]
3466 set ndir [expr {$xp - $x}]
3467 if {$dir != $ndir || $xp < 0} {
3468 lappend coords [xc $y $x] [yc $y]
3469 }
3470 set dir $ndir
3471 }
3472 if {!$joinlow} {
3473 if {$xp < 0} {
3474 # join parent line to first child
3475 set ch [lindex $displayorder $row]
3476 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3477 if {$xc < 0} {
3478 puts "oops: drawlineseg: child $ch not on row $row"
3479 } elseif {$xc != $x} {
3480 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3481 set d [expr {int(0.5 * $linespc)}]
3482 set x1 [xc $row $x]
3483 if {$xc < $x} {
3484 set x2 [expr {$x1 - $d}]
3485 } else {
3486 set x2 [expr {$x1 + $d}]
3487 }
3488 set y2 [yc $row]
3489 set y1 [expr {$y2 + $d}]
3490 lappend coords $x1 $y1 $x2 $y2
3491 } elseif {$xc < $x - 1} {
3492 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3493 } elseif {$xc > $x + 1} {
3494 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3495 }
3496 set x $xc
3497 }
3498 lappend coords [xc $row $x] [yc $row]
3499 } else {
3500 set xn [xc $row $xp]
3501 set yn [yc $row]
3502 lappend coords $xn $yn
3503 }
3504 if {!$joinhigh} {
3505 assigncolor $id
3506 set t [$canv create line $coords -width [linewidth $id] \
3507 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3508 $canv lower $t
3509 bindline $t $id
3510 set lines [linsert $lines $i [list $row $le $t]]
3511 } else {
3512 $canv coords $ith $coords
3513 if {$arrow ne $ah} {
3514 $canv itemconf $ith -arrow $arrow
3515 }
3516 lset lines $i 0 $row
3517 }
3518 } else {
3519 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3520 set ndir [expr {$xo - $xp}]
3521 set clow [$canv coords $itl]
3522 if {$dir == $ndir} {
3523 set clow [lrange $clow 2 end]
3524 }
3525 set coords [concat $coords $clow]
3526 if {!$joinhigh} {
3527 lset lines [expr {$i-1}] 1 $le
3528 } else {
3529 # coalesce two pieces
3530 $canv delete $ith
3531 set b [lindex $lines [expr {$i-1}] 0]
3532 set e [lindex $lines $i 1]
3533 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3534 }
3535 $canv coords $itl $coords
3536 if {$arrow ne $al} {
3537 $canv itemconf $itl -arrow $arrow
3538 }
3539 }
3540
3541 set linesegs($id) $lines
3542 return $le
3543}
3544
3545proc drawparentlinks {id row} {
3546 global rowidlist canv colormap curview parentlist
3547 global idpos linespc
3548
3549 set rowids [lindex $rowidlist $row]
3550 set col [lsearch -exact $rowids $id]
3551 if {$col < 0} return
3552 set olds [lindex $parentlist $row]
3553 set row2 [expr {$row + 1}]
3554 set x [xc $row $col]
3555 set y [yc $row]
3556 set y2 [yc $row2]
3557 set d [expr {int(0.5 * $linespc)}]
3558 set ymid [expr {$y + $d}]
3559 set ids [lindex $rowidlist $row2]
3560 # rmx = right-most X coord used
3561 set rmx 0
3562 foreach p $olds {
3563 set i [lsearch -exact $ids $p]
3564 if {$i < 0} {
3565 puts "oops, parent $p of $id not in list"
3566 continue
3567 }
3568 set x2 [xc $row2 $i]
3569 if {$x2 > $rmx} {
3570 set rmx $x2
3571 }
3572 set j [lsearch -exact $rowids $p]
3573 if {$j < 0} {
3574 # drawlineseg will do this one for us
3575 continue
3576 }
3577 assigncolor $p
3578 # should handle duplicated parents here...
3579 set coords [list $x $y]
3580 if {$i != $col} {
3581 # if attaching to a vertical segment, draw a smaller
3582 # slant for visual distinctness
3583 if {$i == $j} {
3584 if {$i < $col} {
3585 lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3586 } else {
3587 lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3588 }
3589 } elseif {$i < $col && $i < $j} {
3590 # segment slants towards us already
3591 lappend coords [xc $row $j] $y
3592 } else {
3593 if {$i < $col - 1} {
3594 lappend coords [expr {$x2 + $linespc}] $y
3595 } elseif {$i > $col + 1} {
3596 lappend coords [expr {$x2 - $linespc}] $y
3597 }
3598 lappend coords $x2 $y2
3599 }
3600 } else {
3601 lappend coords $x2 $y2
3602 }
3603 set t [$canv create line $coords -width [linewidth $p] \
3604 -fill $colormap($p) -tags lines.$p]
3605 $canv lower $t
3606 bindline $t $p
3607 }
3608 if {$rmx > [lindex $idpos($id) 1]} {
3609 lset idpos($id) 1 $rmx
3610 redrawtags $id
3611 }
3612}
3613
3614proc drawlines {id} {
3615 global canv
3616
3617 $canv itemconf lines.$id -width [linewidth $id]
3618}
3619
3620proc drawcmittext {id row col} {
3621 global linespc canv canv2 canv3 canvy0 fgcolor curview
3622 global commitlisted commitinfo rowidlist parentlist
3623 global rowtextx idpos idtags idheads idotherrefs
3624 global linehtag linentag linedtag selectedline
3625 global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3626
3627 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3628 set listed [lindex $commitlisted $row]
3629 if {$id eq $nullid} {
3630 set ofill red
3631 } elseif {$id eq $nullid2} {
3632 set ofill green
3633 } else {
3634 set ofill [expr {$listed != 0? "blue": "white"}]
3635 }
3636 set x [xc $row $col]
3637 set y [yc $row]
3638 set orad [expr {$linespc / 3}]
3639 if {$listed <= 1} {
3640 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3641 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3642 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3643 } elseif {$listed == 2} {
3644 # triangle pointing left for left-side commits
3645 set t [$canv create polygon \
3646 [expr {$x - $orad}] $y \
3647 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3648 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3649 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3650 } else {
3651 # triangle pointing right for right-side commits
3652 set t [$canv create polygon \
3653 [expr {$x + $orad - 1}] $y \
3654 [expr {$x - $orad}] [expr {$y - $orad}] \
3655 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3656 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3657 }
3658 $canv raise $t
3659 $canv bind $t <1> {selcanvline {} %x %y}
3660 set rmx [llength [lindex $rowidlist $row]]
3661 set olds [lindex $parentlist $row]
3662 if {$olds ne {}} {
3663 set nextids [lindex $rowidlist [expr {$row + 1}]]
3664 foreach p $olds {
3665 set i [lsearch -exact $nextids $p]
3666 if {$i > $rmx} {
3667 set rmx $i
3668 }
3669 }
3670 }
3671 set xt [xc $row $rmx]
3672 set rowtextx($row) $xt
3673 set idpos($id) [list $x $xt $y]
3674 if {[info exists idtags($id)] || [info exists idheads($id)]
3675 || [info exists idotherrefs($id)]} {
3676 set xt [drawtags $id $x $xt $y]
3677 }
3678 set headline [lindex $commitinfo($id) 0]
3679 set name [lindex $commitinfo($id) 1]
3680 set date [lindex $commitinfo($id) 2]
3681 set date [formatdate $date]
3682 set font mainfont
3683 set nfont mainfont
3684 set isbold [ishighlighted $row]
3685 if {$isbold > 0} {
3686 lappend boldrows $row
3687 set font mainfontbold
3688 if {$isbold > 1} {
3689 lappend boldnamerows $row
3690 set nfont mainfontbold
3691 }
3692 }
3693 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3694 -text $headline -font $font -tags text]
3695 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3696 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3697 -text $name -font $nfont -tags text]
3698 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3699 -text $date -font mainfont -tags text]
3700 if {[info exists selectedline] && $selectedline == $row} {
3701 make_secsel $row
3702 }
3703 set xr [expr {$xt + [font measure $font $headline]}]
3704 if {$xr > $canvxmax} {
3705 set canvxmax $xr
3706 setcanvscroll
3707 }
3708}
3709
3710proc drawcmitrow {row} {
3711 global displayorder rowidlist nrows_drawn
3712 global iddrawn markingmatches
3713 global commitinfo parentlist numcommits
3714 global filehighlight fhighlights findpattern nhighlights
3715 global hlview vhighlights
3716 global highlight_related rhighlights
3717
3718 if {$row >= $numcommits} return
3719
3720 set id [lindex $displayorder $row]
3721 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3722 askvhighlight $row $id
3723 }
3724 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3725 askfilehighlight $row $id
3726 }
3727 if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3728 askfindhighlight $row $id
3729 }
3730 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3731 askrelhighlight $row $id
3732 }
3733 if {![info exists iddrawn($id)]} {
3734 set col [lsearch -exact [lindex $rowidlist $row] $id]
3735 if {$col < 0} {
3736 puts "oops, row $row id $id not in list"
3737 return
3738 }
3739 if {![info exists commitinfo($id)]} {
3740 getcommit $id
3741 }
3742 assigncolor $id
3743 drawcmittext $id $row $col
3744 set iddrawn($id) 1
3745 incr nrows_drawn
3746 }
3747 if {$markingmatches} {
3748 markrowmatches $row $id
3749 }
3750}
3751
3752proc drawcommits {row {endrow {}}} {
3753 global numcommits iddrawn displayorder curview need_redisplay
3754 global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3755
3756 if {$row < 0} {
3757 set row 0
3758 }
3759 if {$endrow eq {}} {
3760 set endrow $row
3761 }
3762 if {$endrow >= $numcommits} {
3763 set endrow [expr {$numcommits - 1}]
3764 }
3765
3766 set rl1 [expr {$row - $downarrowlen - 3}]
3767 if {$rl1 < 0} {
3768 set rl1 0
3769 }
3770 set ro1 [expr {$row - 3}]
3771 if {$ro1 < 0} {
3772 set ro1 0
3773 }
3774 set r2 [expr {$endrow + $uparrowlen + 3}]
3775 if {$r2 > $numcommits} {
3776 set r2 $numcommits
3777 }
3778 for {set r $rl1} {$r < $r2} {incr r} {
3779 if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3780 if {$rl1 < $r} {
3781 layoutrows $rl1 $r
3782 }
3783 set rl1 [expr {$r + 1}]
3784 }
3785 }
3786 if {$rl1 < $r} {
3787 layoutrows $rl1 $r
3788 }
3789 optimize_rows $ro1 0 $r2
3790 if {$need_redisplay || $nrows_drawn > 2000} {
3791 clear_display
3792 drawvisible
3793 }
3794
3795 # make the lines join to already-drawn rows either side
3796 set r [expr {$row - 1}]
3797 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3798 set r $row
3799 }
3800 set er [expr {$endrow + 1}]
3801 if {$er >= $numcommits ||
3802 ![info exists iddrawn([lindex $displayorder $er])]} {
3803 set er $endrow
3804 }
3805 for {} {$r <= $er} {incr r} {
3806 set id [lindex $displayorder $r]
3807 set wasdrawn [info exists iddrawn($id)]
3808 drawcmitrow $r
3809 if {$r == $er} break
3810 set nextid [lindex $displayorder [expr {$r + 1}]]
3811 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3812 catch {unset prevlines}
3813 continue
3814 }
3815 drawparentlinks $id $r
3816
3817 if {[info exists lineends($r)]} {
3818 foreach lid $lineends($r) {
3819 unset prevlines($lid)
3820 }
3821 }
3822 set rowids [lindex $rowidlist $r]
3823 foreach lid $rowids {
3824 if {$lid eq {}} continue
3825 if {$lid eq $id} {
3826 # see if this is the first child of any of its parents
3827 foreach p [lindex $parentlist $r] {
3828 if {[lsearch -exact $rowids $p] < 0} {
3829 # make this line extend up to the child
3830 set le [drawlineseg $p $r $er 0]
3831 lappend lineends($le) $p
3832 set prevlines($p) 1
3833 }
3834 }
3835 } elseif {![info exists prevlines($lid)]} {
3836 set le [drawlineseg $lid $r $er 1]
3837 lappend lineends($le) $lid
3838 set prevlines($lid) 1
3839 }
3840 }
3841 }
3842}
3843
3844proc drawfrac {f0 f1} {
3845 global canv linespc
3846
3847 set ymax [lindex [$canv cget -scrollregion] 3]
3848 if {$ymax eq {} || $ymax == 0} return
3849 set y0 [expr {int($f0 * $ymax)}]
3850 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3851 set y1 [expr {int($f1 * $ymax)}]
3852 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3853 drawcommits $row $endrow
3854}
3855
3856proc drawvisible {} {
3857 global canv
3858 eval drawfrac [$canv yview]
3859}
3860
3861proc clear_display {} {
3862 global iddrawn linesegs need_redisplay nrows_drawn
3863 global vhighlights fhighlights nhighlights rhighlights
3864
3865 allcanvs delete all
3866 catch {unset iddrawn}
3867 catch {unset linesegs}
3868 catch {unset vhighlights}
3869 catch {unset fhighlights}
3870 catch {unset nhighlights}
3871 catch {unset rhighlights}
3872 set need_redisplay 0
3873 set nrows_drawn 0
3874}
3875
3876proc findcrossings {id} {
3877 global rowidlist parentlist numcommits displayorder
3878
3879 set cross {}
3880 set ccross {}
3881 foreach {s e} [rowranges $id] {
3882 if {$e >= $numcommits} {
3883 set e [expr {$numcommits - 1}]
3884 }
3885 if {$e <= $s} continue
3886 for {set row $e} {[incr row -1] >= $s} {} {
3887 set x [lsearch -exact [lindex $rowidlist $row] $id]
3888 if {$x < 0} break
3889 set olds [lindex $parentlist $row]
3890 set kid [lindex $displayorder $row]
3891 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3892 if {$kidx < 0} continue
3893 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3894 foreach p $olds {
3895 set px [lsearch -exact $nextrow $p]
3896 if {$px < 0} continue
3897 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3898 if {[lsearch -exact $ccross $p] >= 0} continue
3899 if {$x == $px + ($kidx < $px? -1: 1)} {
3900 lappend ccross $p
3901 } elseif {[lsearch -exact $cross $p] < 0} {
3902 lappend cross $p
3903 }
3904 }
3905 }
3906 }
3907 }
3908 return [concat $ccross {{}} $cross]
3909}
3910
3911proc assigncolor {id} {
3912 global colormap colors nextcolor
3913 global commitrow parentlist children children curview
3914
3915 if {[info exists colormap($id)]} return
3916 set ncolors [llength $colors]
3917 if {[info exists children($curview,$id)]} {
3918 set kids $children($curview,$id)
3919 } else {
3920 set kids {}
3921 }
3922 if {[llength $kids] == 1} {
3923 set child [lindex $kids 0]
3924 if {[info exists colormap($child)]
3925 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3926 set colormap($id) $colormap($child)
3927 return
3928 }
3929 }
3930 set badcolors {}
3931 set origbad {}
3932 foreach x [findcrossings $id] {
3933 if {$x eq {}} {
3934 # delimiter between corner crossings and other crossings
3935 if {[llength $badcolors] >= $ncolors - 1} break
3936 set origbad $badcolors
3937 }
3938 if {[info exists colormap($x)]
3939 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3940 lappend badcolors $colormap($x)
3941 }
3942 }
3943 if {[llength $badcolors] >= $ncolors} {
3944 set badcolors $origbad
3945 }
3946 set origbad $badcolors
3947 if {[llength $badcolors] < $ncolors - 1} {
3948 foreach child $kids {
3949 if {[info exists colormap($child)]
3950 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3951 lappend badcolors $colormap($child)
3952 }
3953 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3954 if {[info exists colormap($p)]
3955 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3956 lappend badcolors $colormap($p)
3957 }
3958 }
3959 }
3960 if {[llength $badcolors] >= $ncolors} {
3961 set badcolors $origbad
3962 }
3963 }
3964 for {set i 0} {$i <= $ncolors} {incr i} {
3965 set c [lindex $colors $nextcolor]
3966 if {[incr nextcolor] >= $ncolors} {
3967 set nextcolor 0
3968 }
3969 if {[lsearch -exact $badcolors $c]} break
3970 }
3971 set colormap($id) $c
3972}
3973
3974proc bindline {t id} {
3975 global canv
3976
3977 $canv bind $t <Enter> "lineenter %x %y $id"
3978 $canv bind $t <Motion> "linemotion %x %y $id"
3979 $canv bind $t <Leave> "lineleave $id"
3980 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3981}
3982
3983proc drawtags {id x xt y1} {
3984 global idtags idheads idotherrefs mainhead
3985 global linespc lthickness
3986 global canv commitrow rowtextx curview fgcolor bgcolor
3987
3988 set marks {}
3989 set ntags 0
3990 set nheads 0
3991 if {[info exists idtags($id)]} {
3992 set marks $idtags($id)
3993 set ntags [llength $marks]
3994 }
3995 if {[info exists idheads($id)]} {
3996 set marks [concat $marks $idheads($id)]
3997 set nheads [llength $idheads($id)]
3998 }
3999 if {[info exists idotherrefs($id)]} {
4000 set marks [concat $marks $idotherrefs($id)]
4001 }
4002 if {$marks eq {}} {
4003 return $xt
4004 }
4005
4006 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4007 set yt [expr {$y1 - 0.5 * $linespc}]
4008 set yb [expr {$yt + $linespc - 1}]
4009 set xvals {}
4010 set wvals {}
4011 set i -1
4012 foreach tag $marks {
4013 incr i
4014 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4015 set wid [font measure mainfontbold $tag]
4016 } else {
4017 set wid [font measure mainfont $tag]
4018 }
4019 lappend xvals $xt
4020 lappend wvals $wid
4021 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4022 }
4023 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4024 -width $lthickness -fill black -tags tag.$id]
4025 $canv lower $t
4026 foreach tag $marks x $xvals wid $wvals {
4027 set xl [expr {$x + $delta}]
4028 set xr [expr {$x + $delta + $wid + $lthickness}]
4029 set font mainfont
4030 if {[incr ntags -1] >= 0} {
4031 # draw a tag
4032 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4033 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4034 -width 1 -outline black -fill yellow -tags tag.$id]
4035 $canv bind $t <1> [list showtag $tag 1]
4036 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4037 } else {
4038 # draw a head or other ref
4039 if {[incr nheads -1] >= 0} {
4040 set col green
4041 if {$tag eq $mainhead} {
4042 set font mainfontbold
4043 }
4044 } else {
4045 set col "#ddddff"
4046 }
4047 set xl [expr {$xl - $delta/2}]
4048 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4049 -width 1 -outline black -fill $col -tags tag.$id
4050 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4051 set rwid [font measure mainfont $remoteprefix]
4052 set xi [expr {$x + 1}]
4053 set yti [expr {$yt + 1}]
4054 set xri [expr {$x + $rwid}]
4055 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4056 -width 0 -fill "#ffddaa" -tags tag.$id
4057 }
4058 }
4059 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4060 -font $font -tags [list tag.$id text]]
4061 if {$ntags >= 0} {
4062 $canv bind $t <1> [list showtag $tag 1]
4063 } elseif {$nheads >= 0} {
4064 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4065 }
4066 }
4067 return $xt
4068}
4069
4070proc xcoord {i level ln} {
4071 global canvx0 xspc1 xspc2
4072
4073 set x [expr {$canvx0 + $i * $xspc1($ln)}]
4074 if {$i > 0 && $i == $level} {
4075 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4076 } elseif {$i > $level} {
4077 set x [expr {$x + $xspc2 - $xspc1($ln)}]
4078 }
4079 return $x
4080}
4081
4082proc show_status {msg} {
4083 global canv fgcolor
4084
4085 clear_display
4086 $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4087 -tags text -fill $fgcolor
4088}
4089
4090# Insert a new commit as the child of the commit on row $row.
4091# The new commit will be displayed on row $row and the commits
4092# on that row and below will move down one row.
4093proc insertrow {row newcmit} {
4094 global displayorder parentlist commitlisted children
4095 global commitrow curview rowidlist rowisopt rowfinal numcommits
4096 global numcommits
4097 global selectedline commitidx ordertok
4098
4099 if {$row >= $numcommits} {
4100 puts "oops, inserting new row $row but only have $numcommits rows"
4101 return
4102 }
4103 set p [lindex $displayorder $row]
4104 set displayorder [linsert $displayorder $row $newcmit]
4105 set parentlist [linsert $parentlist $row $p]
4106 set kids $children($curview,$p)
4107 lappend kids $newcmit
4108 set children($curview,$p) $kids
4109 set children($curview,$newcmit) {}
4110 set commitlisted [linsert $commitlisted $row 1]
4111 set l [llength $displayorder]
4112 for {set r $row} {$r < $l} {incr r} {
4113 set id [lindex $displayorder $r]
4114 set commitrow($curview,$id) $r
4115 }
4116 incr commitidx($curview)
4117 set ordertok($curview,$newcmit) $ordertok($curview,$p)
4118
4119 if {$row < [llength $rowidlist]} {
4120 set idlist [lindex $rowidlist $row]
4121 if {$idlist ne {}} {
4122 if {[llength $kids] == 1} {
4123 set col [lsearch -exact $idlist $p]
4124 lset idlist $col $newcmit
4125 } else {
4126 set col [llength $idlist]
4127 lappend idlist $newcmit
4128 }
4129 }
4130 set rowidlist [linsert $rowidlist $row $idlist]
4131 set rowisopt [linsert $rowisopt $row 0]
4132 set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4133 }
4134
4135 incr numcommits
4136
4137 if {[info exists selectedline] && $selectedline >= $row} {
4138 incr selectedline
4139 }
4140 redisplay
4141}
4142
4143# Remove a commit that was inserted with insertrow on row $row.
4144proc removerow {row} {
4145 global displayorder parentlist commitlisted children
4146 global commitrow curview rowidlist rowisopt rowfinal numcommits
4147 global numcommits
4148 global linesegends selectedline commitidx
4149
4150 if {$row >= $numcommits} {
4151 puts "oops, removing row $row but only have $numcommits rows"
4152 return
4153 }
4154 set rp1 [expr {$row + 1}]
4155 set id [lindex $displayorder $row]
4156 set p [lindex $parentlist $row]
4157 set displayorder [lreplace $displayorder $row $row]
4158 set parentlist [lreplace $parentlist $row $row]
4159 set commitlisted [lreplace $commitlisted $row $row]
4160 set kids $children($curview,$p)
4161 set i [lsearch -exact $kids $id]
4162 if {$i >= 0} {
4163 set kids [lreplace $kids $i $i]
4164 set children($curview,$p) $kids
4165 }
4166 set l [llength $displayorder]
4167 for {set r $row} {$r < $l} {incr r} {
4168 set id [lindex $displayorder $r]
4169 set commitrow($curview,$id) $r
4170 }
4171 incr commitidx($curview) -1
4172
4173 if {$row < [llength $rowidlist]} {
4174 set rowidlist [lreplace $rowidlist $row $row]
4175 set rowisopt [lreplace $rowisopt $row $row]
4176 set rowfinal [lreplace $rowfinal $row $row]
4177 }
4178
4179 incr numcommits -1
4180
4181 if {[info exists selectedline] && $selectedline > $row} {
4182 incr selectedline -1
4183 }
4184 redisplay
4185}
4186
4187# Don't change the text pane cursor if it is currently the hand cursor,
4188# showing that we are over a sha1 ID link.
4189proc settextcursor {c} {
4190 global ctext curtextcursor
4191
4192 if {[$ctext cget -cursor] == $curtextcursor} {
4193 $ctext config -cursor $c
4194 }
4195 set curtextcursor $c
4196}
4197
4198proc nowbusy {what} {
4199 global isbusy
4200
4201 if {[array names isbusy] eq {}} {
4202 . config -cursor watch
4203 settextcursor watch
4204 }
4205 set isbusy($what) 1
4206}
4207
4208proc notbusy {what} {
4209 global isbusy maincursor textcursor
4210
4211 catch {unset isbusy($what)}
4212 if {[array names isbusy] eq {}} {
4213 . config -cursor $maincursor
4214 settextcursor $textcursor
4215 }
4216}
4217
4218proc findmatches {f} {
4219 global findtype findstring
4220 if {$findtype == "Regexp"} {
4221 set matches [regexp -indices -all -inline $findstring $f]
4222 } else {
4223 set fs $findstring
4224 if {$findtype == "IgnCase"} {
4225 set f [string tolower $f]
4226 set fs [string tolower $fs]
4227 }
4228 set matches {}
4229 set i 0
4230 set l [string length $fs]
4231 while {[set j [string first $fs $f $i]] >= 0} {
4232 lappend matches [list $j [expr {$j+$l-1}]]
4233 set i [expr {$j + $l}]
4234 }
4235 }
4236 return $matches
4237}
4238
4239proc dofind {{rev 0}} {
4240 global findstring findstartline findcurline selectedline numcommits
4241 global gdttype filehighlight fh_serial find_dirn
4242
4243 unmarkmatches
4244 focus .
4245 if {$findstring eq {} || $numcommits == 0} return
4246 if {![info exists selectedline]} {
4247 set findstartline [lindex [visiblerows] $rev]
4248 } else {
4249 set findstartline $selectedline
4250 }
4251 set findcurline $findstartline
4252 nowbusy finding
4253 if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4254 after cancel do_file_hl $fh_serial
4255 do_file_hl $fh_serial
4256 }
4257 if {!$rev} {
4258 set find_dirn 1
4259 run findmore
4260 } else {
4261 set find_dirn -1
4262 run findmorerev
4263 }
4264}
4265
4266proc stopfinding {} {
4267 global find_dirn findcurline fprogcoord
4268
4269 if {[info exists find_dirn]} {
4270 unset find_dirn
4271 unset findcurline
4272 notbusy finding
4273 set fprogcoord 0
4274 adjustprogress
4275 }
4276}
4277
4278proc findnext {restart} {
4279 global findcurline find_dirn
4280
4281 if {[info exists find_dirn]} return
4282 set find_dirn 1
4283 if {![info exists findcurline]} {
4284 if {$restart} {
4285 dofind
4286 } else {
4287 bell
4288 }
4289 } else {
4290 run findmore
4291 nowbusy finding
4292 }
4293}
4294
4295proc findprev {} {
4296 global findcurline find_dirn
4297
4298 if {[info exists find_dirn]} return
4299 set find_dirn -1
4300 if {![info exists findcurline]} {
4301 dofind 1
4302 } else {
4303 run findmorerev
4304 nowbusy finding
4305 }
4306}
4307
4308proc findmore {} {
4309 global commitdata commitinfo numcommits findpattern findloc
4310 global findstartline findcurline displayorder
4311 global find_dirn gdttype fhighlights fprogcoord
4312
4313 if {![info exists find_dirn]} {
4314 return 0
4315 }
4316 set fldtypes {Headline Author Date Committer CDate Comments}
4317 set l [expr {$findcurline + 1}]
4318 if {$l >= $numcommits} {
4319 set l 0
4320 }
4321 if {$l <= $findstartline} {
4322 set lim [expr {$findstartline + 1}]
4323 } else {
4324 set lim $numcommits
4325 }
4326 if {$lim - $l > 500} {
4327 set lim [expr {$l + 500}]
4328 }
4329 set found 0
4330 set domore 1
4331 if {$gdttype eq "containing:"} {
4332 for {} {$l < $lim} {incr l} {
4333 set id [lindex $displayorder $l]
4334 # shouldn't happen unless git log doesn't give all the commits...
4335 if {![info exists commitdata($id)]} continue
4336 if {![doesmatch $commitdata($id)]} continue
4337 if {![info exists commitinfo($id)]} {
4338 getcommit $id
4339 }
4340 set info $commitinfo($id)
4341 foreach f $info ty $fldtypes {
4342 if {($findloc eq "All fields" || $findloc eq $ty) &&
4343 [doesmatch $f]} {
4344 set found 1
4345 break
4346 }
4347 }
4348 if {$found} break
4349 }
4350 } else {
4351 for {} {$l < $lim} {incr l} {
4352 set id [lindex $displayorder $l]
4353 if {![info exists fhighlights($l)]} {
4354 askfilehighlight $l $id
4355 if {$domore} {
4356 set domore 0
4357 set findcurline [expr {$l - 1}]
4358 }
4359 } elseif {$fhighlights($l)} {
4360 set found $domore
4361 break
4362 }
4363 }
4364 }
4365 if {$found || ($domore && $l == $findstartline + 1)} {
4366 unset findcurline
4367 unset find_dirn
4368 notbusy finding
4369 set fprogcoord 0
4370 adjustprogress
4371 if {$found} {
4372 findselectline $l
4373 } else {
4374 bell
4375 }
4376 return 0
4377 }
4378 if {!$domore} {
4379 flushhighlights
4380 } else {
4381 set findcurline [expr {$l - 1}]
4382 }
4383 set n [expr {$findcurline - ($findstartline + 1)}]
4384 if {$n < 0} {
4385 incr n $numcommits
4386 }
4387 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4388 adjustprogress
4389 return $domore
4390}
4391
4392proc findmorerev {} {
4393 global commitdata commitinfo numcommits findpattern findloc
4394 global findstartline findcurline displayorder
4395 global find_dirn gdttype fhighlights fprogcoord
4396
4397 if {![info exists find_dirn]} {
4398 return 0
4399 }
4400 set fldtypes {Headline Author Date Committer CDate Comments}
4401 set l $findcurline
4402 if {$l == 0} {
4403 set l $numcommits
4404 }
4405 incr l -1
4406 if {$l >= $findstartline} {
4407 set lim [expr {$findstartline - 1}]
4408 } else {
4409 set lim -1
4410 }
4411 if {$l - $lim > 500} {
4412 set lim [expr {$l - 500}]
4413 }
4414 set found 0
4415 set domore 1
4416 if {$gdttype eq "containing:"} {
4417 for {} {$l > $lim} {incr l -1} {
4418 set id [lindex $displayorder $l]
4419 if {![info exists commitdata($id)]} continue
4420 if {![doesmatch $commitdata($id)]} continue
4421 if {![info exists commitinfo($id)]} {
4422 getcommit $id
4423 }
4424 set info $commitinfo($id)
4425 foreach f $info ty $fldtypes {
4426 if {($findloc eq "All fields" || $findloc eq $ty) &&
4427 [doesmatch $f]} {
4428 set found 1
4429 break
4430 }
4431 }
4432 if {$found} break
4433 }
4434 } else {
4435 for {} {$l > $lim} {incr l -1} {
4436 set id [lindex $displayorder $l]
4437 if {![info exists fhighlights($l)]} {
4438 askfilehighlight $l $id
4439 if {$domore} {
4440 set domore 0
4441 set findcurline [expr {$l + 1}]
4442 }
4443 } elseif {$fhighlights($l)} {
4444 set found $domore
4445 break
4446 }
4447 }
4448 }
4449 if {$found || ($domore && $l == $findstartline - 1)} {
4450 unset findcurline
4451 unset find_dirn
4452 notbusy finding
4453 set fprogcoord 0
4454 adjustprogress
4455 if {$found} {
4456 findselectline $l
4457 } else {
4458 bell
4459 }
4460 return 0
4461 }
4462 if {!$domore} {
4463 flushhighlights
4464 } else {
4465 set findcurline [expr {$l + 1}]
4466 }
4467 set n [expr {($findstartline - 1) - $findcurline}]
4468 if {$n < 0} {
4469 incr n $numcommits
4470 }
4471 set fprogcoord [expr {$n * 1.0 / $numcommits}]
4472 adjustprogress
4473 return $domore
4474}
4475
4476proc findselectline {l} {
4477 global findloc commentend ctext findcurline markingmatches gdttype
4478
4479 set markingmatches 1
4480 set findcurline $l
4481 selectline $l 1
4482 if {$findloc == "All fields" || $findloc == "Comments"} {
4483 # highlight the matches in the comments
4484 set f [$ctext get 1.0 $commentend]
4485 set matches [findmatches $f]
4486 foreach match $matches {
4487 set start [lindex $match 0]
4488 set end [expr {[lindex $match 1] + 1}]
4489 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4490 }
4491 }
4492 drawvisible
4493}
4494
4495# mark the bits of a headline or author that match a find string
4496proc markmatches {canv l str tag matches font row} {
4497 global selectedline
4498
4499 set bbox [$canv bbox $tag]
4500 set x0 [lindex $bbox 0]
4501 set y0 [lindex $bbox 1]
4502 set y1 [lindex $bbox 3]
4503 foreach match $matches {
4504 set start [lindex $match 0]
4505 set end [lindex $match 1]
4506 if {$start > $end} continue
4507 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4508 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4509 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4510 [expr {$x0+$xlen+2}] $y1 \
4511 -outline {} -tags [list match$l matches] -fill yellow]
4512 $canv lower $t
4513 if {[info exists selectedline] && $row == $selectedline} {
4514 $canv raise $t secsel
4515 }
4516 }
4517}
4518
4519proc unmarkmatches {} {
4520 global markingmatches
4521
4522 allcanvs delete matches
4523 set markingmatches 0
4524 stopfinding
4525}
4526
4527proc selcanvline {w x y} {
4528 global canv canvy0 ctext linespc
4529 global rowtextx
4530 set ymax [lindex [$canv cget -scrollregion] 3]
4531 if {$ymax == {}} return
4532 set yfrac [lindex [$canv yview] 0]
4533 set y [expr {$y + $yfrac * $ymax}]
4534 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4535 if {$l < 0} {
4536 set l 0
4537 }
4538 if {$w eq $canv} {
4539 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4540 }
4541 unmarkmatches
4542 selectline $l 1
4543}
4544
4545proc commit_descriptor {p} {
4546 global commitinfo
4547 if {![info exists commitinfo($p)]} {
4548 getcommit $p
4549 }
4550 set l "..."
4551 if {[llength $commitinfo($p)] > 1} {
4552 set l [lindex $commitinfo($p) 0]
4553 }
4554 return "$p ($l)\n"
4555}
4556
4557# append some text to the ctext widget, and make any SHA1 ID
4558# that we know about be a clickable link.
4559proc appendwithlinks {text tags} {
4560 global ctext commitrow linknum curview pendinglinks
4561
4562 set start [$ctext index "end - 1c"]
4563 $ctext insert end $text $tags
4564 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4565 foreach l $links {
4566 set s [lindex $l 0]
4567 set e [lindex $l 1]
4568 set linkid [string range $text $s $e]
4569 incr e
4570 $ctext tag delete link$linknum
4571 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4572 setlink $linkid link$linknum
4573 incr linknum
4574 }
4575}
4576
4577proc setlink {id lk} {
4578 global curview commitrow ctext pendinglinks commitinterest
4579
4580 if {[info exists commitrow($curview,$id)]} {
4581 $ctext tag conf $lk -foreground blue -underline 1
4582 $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4583 $ctext tag bind $lk <Enter> {linkcursor %W 1}
4584 $ctext tag bind $lk <Leave> {linkcursor %W -1}
4585 } else {
4586 lappend pendinglinks($id) $lk
4587 lappend commitinterest($id) {makelink %I}
4588 }
4589}
4590
4591proc makelink {id} {
4592 global pendinglinks
4593
4594 if {![info exists pendinglinks($id)]} return
4595 foreach lk $pendinglinks($id) {
4596 setlink $id $lk
4597 }
4598 unset pendinglinks($id)
4599}
4600
4601proc linkcursor {w inc} {
4602 global linkentercount curtextcursor
4603
4604 if {[incr linkentercount $inc] > 0} {
4605 $w configure -cursor hand2
4606 } else {
4607 $w configure -cursor $curtextcursor
4608 if {$linkentercount < 0} {
4609 set linkentercount 0
4610 }
4611 }
4612}
4613
4614proc viewnextline {dir} {
4615 global canv linespc
4616
4617 $canv delete hover
4618 set ymax [lindex [$canv cget -scrollregion] 3]
4619 set wnow [$canv yview]
4620 set wtop [expr {[lindex $wnow 0] * $ymax}]
4621 set newtop [expr {$wtop + $dir * $linespc}]
4622 if {$newtop < 0} {
4623 set newtop 0
4624 } elseif {$newtop > $ymax} {
4625 set newtop $ymax
4626 }
4627 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4628}
4629
4630# add a list of tag or branch names at position pos
4631# returns the number of names inserted
4632proc appendrefs {pos ids var} {
4633 global ctext commitrow linknum curview $var maxrefs
4634
4635 if {[catch {$ctext index $pos}]} {
4636 return 0
4637 }
4638 $ctext conf -state normal
4639 $ctext delete $pos "$pos lineend"
4640 set tags {}
4641 foreach id $ids {
4642 foreach tag [set $var\($id\)] {
4643 lappend tags [list $tag $id]
4644 }
4645 }
4646 if {[llength $tags] > $maxrefs} {
4647 $ctext insert $pos "many ([llength $tags])"
4648 } else {
4649 set tags [lsort -index 0 -decreasing $tags]
4650 set sep {}
4651 foreach ti $tags {
4652 set id [lindex $ti 1]
4653 set lk link$linknum
4654 incr linknum
4655 $ctext tag delete $lk
4656 $ctext insert $pos $sep
4657 $ctext insert $pos [lindex $ti 0] $lk
4658 setlink $id $lk
4659 set sep ", "
4660 }
4661 }
4662 $ctext conf -state disabled
4663 return [llength $tags]
4664}
4665
4666# called when we have finished computing the nearby tags
4667proc dispneartags {delay} {
4668 global selectedline currentid showneartags tagphase
4669
4670 if {![info exists selectedline] || !$showneartags} return
4671 after cancel dispnexttag
4672 if {$delay} {
4673 after 200 dispnexttag
4674 set tagphase -1
4675 } else {
4676 after idle dispnexttag
4677 set tagphase 0
4678 }
4679}
4680
4681proc dispnexttag {} {
4682 global selectedline currentid showneartags tagphase ctext
4683
4684 if {![info exists selectedline] || !$showneartags} return
4685 switch -- $tagphase {
4686 0 {
4687 set dtags [desctags $currentid]
4688 if {$dtags ne {}} {
4689 appendrefs precedes $dtags idtags
4690 }
4691 }
4692 1 {
4693 set atags [anctags $currentid]
4694 if {$atags ne {}} {
4695 appendrefs follows $atags idtags
4696 }
4697 }
4698 2 {
4699 set dheads [descheads $currentid]
4700 if {$dheads ne {}} {
4701 if {[appendrefs branch $dheads idheads] > 1
4702 && [$ctext get "branch -3c"] eq "h"} {
4703 # turn "Branch" into "Branches"
4704 $ctext conf -state normal
4705 $ctext insert "branch -2c" "es"
4706 $ctext conf -state disabled
4707 }
4708 }
4709 }
4710 }
4711 if {[incr tagphase] <= 2} {
4712 after idle dispnexttag
4713 }
4714}
4715
4716proc make_secsel {l} {
4717 global linehtag linentag linedtag canv canv2 canv3
4718
4719 if {![info exists linehtag($l)]} return
4720 $canv delete secsel
4721 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4722 -tags secsel -fill [$canv cget -selectbackground]]
4723 $canv lower $t
4724 $canv2 delete secsel
4725 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4726 -tags secsel -fill [$canv2 cget -selectbackground]]
4727 $canv2 lower $t
4728 $canv3 delete secsel
4729 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4730 -tags secsel -fill [$canv3 cget -selectbackground]]
4731 $canv3 lower $t
4732}
4733
4734proc selectline {l isnew} {
4735 global canv ctext commitinfo selectedline
4736 global displayorder
4737 global canvy0 linespc parentlist children curview
4738 global currentid sha1entry
4739 global commentend idtags linknum
4740 global mergemax numcommits pending_select
4741 global cmitmode showneartags allcommits
4742
4743 catch {unset pending_select}
4744 $canv delete hover
4745 normalline
4746 unsel_reflist
4747 stopfinding
4748 if {$l < 0 || $l >= $numcommits} return
4749 set y [expr {$canvy0 + $l * $linespc}]
4750 set ymax [lindex [$canv cget -scrollregion] 3]
4751 set ytop [expr {$y - $linespc - 1}]
4752 set ybot [expr {$y + $linespc + 1}]
4753 set wnow [$canv yview]
4754 set wtop [expr {[lindex $wnow 0] * $ymax}]
4755 set wbot [expr {[lindex $wnow 1] * $ymax}]
4756 set wh [expr {$wbot - $wtop}]
4757 set newtop $wtop
4758 if {$ytop < $wtop} {
4759 if {$ybot < $wtop} {
4760 set newtop [expr {$y - $wh / 2.0}]
4761 } else {
4762 set newtop $ytop
4763 if {$newtop > $wtop - $linespc} {
4764 set newtop [expr {$wtop - $linespc}]
4765 }
4766 }
4767 } elseif {$ybot > $wbot} {
4768 if {$ytop > $wbot} {
4769 set newtop [expr {$y - $wh / 2.0}]
4770 } else {
4771 set newtop [expr {$ybot - $wh}]
4772 if {$newtop < $wtop + $linespc} {
4773 set newtop [expr {$wtop + $linespc}]
4774 }
4775 }
4776 }
4777 if {$newtop != $wtop} {
4778 if {$newtop < 0} {
4779 set newtop 0
4780 }
4781 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4782 drawvisible
4783 }
4784
4785 make_secsel $l
4786
4787 if {$isnew} {
4788 addtohistory [list selectline $l 0]
4789 }
4790
4791 set selectedline $l
4792
4793 set id [lindex $displayorder $l]
4794 set currentid $id
4795 $sha1entry delete 0 end
4796 $sha1entry insert 0 $id
4797 $sha1entry selection from 0
4798 $sha1entry selection to end
4799 rhighlight_sel $id
4800
4801 $ctext conf -state normal
4802 clear_ctext
4803 set linknum 0
4804 set info $commitinfo($id)
4805 set date [formatdate [lindex $info 2]]
4806 $ctext insert end "Author: [lindex $info 1] $date\n"
4807 set date [formatdate [lindex $info 4]]
4808 $ctext insert end "Committer: [lindex $info 3] $date\n"
4809 if {[info exists idtags($id)]} {
4810 $ctext insert end "Tags:"
4811 foreach tag $idtags($id) {
4812 $ctext insert end " $tag"
4813 }
4814 $ctext insert end "\n"
4815 }
4816
4817 set headers {}
4818 set olds [lindex $parentlist $l]
4819 if {[llength $olds] > 1} {
4820 set np 0
4821 foreach p $olds {
4822 if {$np >= $mergemax} {
4823 set tag mmax
4824 } else {
4825 set tag m$np
4826 }
4827 $ctext insert end "Parent: " $tag
4828 appendwithlinks [commit_descriptor $p] {}
4829 incr np
4830 }
4831 } else {
4832 foreach p $olds {
4833 append headers "Parent: [commit_descriptor $p]"
4834 }
4835 }
4836
4837 foreach c $children($curview,$id) {
4838 append headers "Child: [commit_descriptor $c]"
4839 }
4840
4841 # make anything that looks like a SHA1 ID be a clickable link
4842 appendwithlinks $headers {}
4843 if {$showneartags} {
4844 if {![info exists allcommits]} {
4845 getallcommits
4846 }
4847 $ctext insert end "Branch: "
4848 $ctext mark set branch "end -1c"
4849 $ctext mark gravity branch left
4850 $ctext insert end "\nFollows: "
4851 $ctext mark set follows "end -1c"
4852 $ctext mark gravity follows left
4853 $ctext insert end "\nPrecedes: "
4854 $ctext mark set precedes "end -1c"
4855 $ctext mark gravity precedes left
4856 $ctext insert end "\n"
4857 dispneartags 1
4858 }
4859 $ctext insert end "\n"
4860 set comment [lindex $info 5]
4861 if {[string first "\r" $comment] >= 0} {
4862 set comment [string map {"\r" "\n "} $comment]
4863 }
4864 appendwithlinks $comment {comment}
4865
4866 $ctext tag remove found 1.0 end
4867 $ctext conf -state disabled
4868 set commentend [$ctext index "end - 1c"]
4869
4870 init_flist "Comments"
4871 if {$cmitmode eq "tree"} {
4872 gettree $id
4873 } elseif {[llength $olds] <= 1} {
4874 startdiff $id
4875 } else {
4876 mergediff $id $l
4877 }
4878}
4879
4880proc selfirstline {} {
4881 unmarkmatches
4882 selectline 0 1
4883}
4884
4885proc sellastline {} {
4886 global numcommits
4887 unmarkmatches
4888 set l [expr {$numcommits - 1}]
4889 selectline $l 1
4890}
4891
4892proc selnextline {dir} {
4893 global selectedline
4894 focus .
4895 if {![info exists selectedline]} return
4896 set l [expr {$selectedline + $dir}]
4897 unmarkmatches
4898 selectline $l 1
4899}
4900
4901proc selnextpage {dir} {
4902 global canv linespc selectedline numcommits
4903
4904 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4905 if {$lpp < 1} {
4906 set lpp 1
4907 }
4908 allcanvs yview scroll [expr {$dir * $lpp}] units
4909 drawvisible
4910 if {![info exists selectedline]} return
4911 set l [expr {$selectedline + $dir * $lpp}]
4912 if {$l < 0} {
4913 set l 0
4914 } elseif {$l >= $numcommits} {
4915 set l [expr $numcommits - 1]
4916 }
4917 unmarkmatches
4918 selectline $l 1
4919}
4920
4921proc unselectline {} {
4922 global selectedline currentid
4923
4924 catch {unset selectedline}
4925 catch {unset currentid}
4926 allcanvs delete secsel
4927 rhighlight_none
4928}
4929
4930proc reselectline {} {
4931 global selectedline
4932
4933 if {[info exists selectedline]} {
4934 selectline $selectedline 0
4935 }
4936}
4937
4938proc addtohistory {cmd} {
4939 global history historyindex curview
4940
4941 set elt [list $curview $cmd]
4942 if {$historyindex > 0
4943 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4944 return
4945 }
4946
4947 if {$historyindex < [llength $history]} {
4948 set history [lreplace $history $historyindex end $elt]
4949 } else {
4950 lappend history $elt
4951 }
4952 incr historyindex
4953 if {$historyindex > 1} {
4954 .tf.bar.leftbut conf -state normal
4955 } else {
4956 .tf.bar.leftbut conf -state disabled
4957 }
4958 .tf.bar.rightbut conf -state disabled
4959}
4960
4961proc godo {elt} {
4962 global curview
4963
4964 set view [lindex $elt 0]
4965 set cmd [lindex $elt 1]
4966 if {$curview != $view} {
4967 showview $view
4968 }
4969 eval $cmd
4970}
4971
4972proc goback {} {
4973 global history historyindex
4974 focus .
4975
4976 if {$historyindex > 1} {
4977 incr historyindex -1
4978 godo [lindex $history [expr {$historyindex - 1}]]
4979 .tf.bar.rightbut conf -state normal
4980 }
4981 if {$historyindex <= 1} {
4982 .tf.bar.leftbut conf -state disabled
4983 }
4984}
4985
4986proc goforw {} {
4987 global history historyindex
4988 focus .
4989
4990 if {$historyindex < [llength $history]} {
4991 set cmd [lindex $history $historyindex]
4992 incr historyindex
4993 godo $cmd
4994 .tf.bar.leftbut conf -state normal
4995 }
4996 if {$historyindex >= [llength $history]} {
4997 .tf.bar.rightbut conf -state disabled
4998 }
4999}
5000
5001proc gettree {id} {
5002 global treefilelist treeidlist diffids diffmergeid treepending
5003 global nullid nullid2
5004
5005 set diffids $id
5006 catch {unset diffmergeid}
5007 if {![info exists treefilelist($id)]} {
5008 if {![info exists treepending]} {
5009 if {$id eq $nullid} {
5010 set cmd [list | git ls-files]
5011 } elseif {$id eq $nullid2} {
5012 set cmd [list | git ls-files --stage -t]
5013 } else {
5014 set cmd [list | git ls-tree -r $id]
5015 }
5016 if {[catch {set gtf [open $cmd r]}]} {
5017 return
5018 }
5019 set treepending $id
5020 set treefilelist($id) {}
5021 set treeidlist($id) {}
5022 fconfigure $gtf -blocking 0
5023 filerun $gtf [list gettreeline $gtf $id]
5024 }
5025 } else {
5026 setfilelist $id
5027 }
5028}
5029
5030proc gettreeline {gtf id} {
5031 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
5032
5033 set nl 0
5034 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
5035 if {$diffids eq $nullid} {
5036 set fname $line
5037 } else {
5038 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
5039 set i [string first "\t" $line]
5040 if {$i < 0} continue
5041 set sha1 [lindex $line 2]
5042 set fname [string range $line [expr {$i+1}] end]
5043 if {[string index $fname 0] eq "\""} {
5044 set fname [lindex $fname 0]
5045 }
5046 lappend treeidlist($id) $sha1
5047 }
5048 lappend treefilelist($id) $fname
5049 }
5050 if {![eof $gtf]} {
5051 return [expr {$nl >= 1000? 2: 1}]
5052 }
5053 close $gtf
5054 unset treepending
5055 if {$cmitmode ne "tree"} {
5056 if {![info exists diffmergeid]} {
5057 gettreediffs $diffids
5058 }
5059 } elseif {$id ne $diffids} {
5060 gettree $diffids
5061 } else {
5062 setfilelist $id
5063 }
5064 return 0
5065}
5066
5067proc showfile {f} {
5068 global treefilelist treeidlist diffids nullid nullid2
5069 global ctext commentend
5070
5071 set i [lsearch -exact $treefilelist($diffids) $f]
5072 if {$i < 0} {
5073 puts "oops, $f not in list for id $diffids"
5074 return
5075 }
5076 if {$diffids eq $nullid} {
5077 if {[catch {set bf [open $f r]} err]} {
5078 puts "oops, can't read $f: $err"
5079 return
5080 }
5081 } else {
5082 set blob [lindex $treeidlist($diffids) $i]
5083 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
5084 puts "oops, error reading blob $blob: $err"
5085 return
5086 }
5087 }
5088 fconfigure $bf -blocking 0
5089 filerun $bf [list getblobline $bf $diffids]
5090 $ctext config -state normal
5091 clear_ctext $commentend
5092 $ctext insert end "\n"
5093 $ctext insert end "$f\n" filesep
5094 $ctext config -state disabled
5095 $ctext yview $commentend
5096 settabs 0
5097}
5098
5099proc getblobline {bf id} {
5100 global diffids cmitmode ctext
5101
5102 if {$id ne $diffids || $cmitmode ne "tree"} {
5103 catch {close $bf}
5104 return 0
5105 }
5106 $ctext config -state normal
5107 set nl 0
5108 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5109 $ctext insert end "$line\n"
5110 }
5111 if {[eof $bf]} {
5112 # delete last newline
5113 $ctext delete "end - 2c" "end - 1c"
5114 close $bf
5115 return 0
5116 }
5117 $ctext config -state disabled
5118 return [expr {$nl >= 1000? 2: 1}]
5119}
5120
5121proc mergediff {id l} {
5122 global diffmergeid mdifffd
5123 global diffids
5124 global parentlist
5125
5126 set diffmergeid $id
5127 set diffids $id
5128 # this doesn't seem to actually affect anything...
5129 set cmd [concat | git diff-tree --no-commit-id --cc $id]
5130 if {[catch {set mdf [open $cmd r]} err]} {
5131 error_popup "Error getting merge diffs: $err"
5132 return
5133 }
5134 fconfigure $mdf -blocking 0
5135 set mdifffd($id) $mdf
5136 set np [llength [lindex $parentlist $l]]
5137 settabs $np
5138 filerun $mdf [list getmergediffline $mdf $id $np]
5139}
5140
5141proc getmergediffline {mdf id np} {
5142 global diffmergeid ctext cflist mergemax
5143 global difffilestart mdifffd
5144
5145 $ctext conf -state normal
5146 set nr 0
5147 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5148 if {![info exists diffmergeid] || $id != $diffmergeid
5149 || $mdf != $mdifffd($id)} {
5150 close $mdf
5151 return 0
5152 }
5153 if {[regexp {^diff --cc (.*)} $line match fname]} {
5154 # start of a new file
5155 $ctext insert end "\n"
5156 set here [$ctext index "end - 1c"]
5157 lappend difffilestart $here
5158 add_flist [list $fname]
5159 set l [expr {(78 - [string length $fname]) / 2}]
5160 set pad [string range "----------------------------------------" 1 $l]
5161 $ctext insert end "$pad $fname $pad\n" filesep
5162 } elseif {[regexp {^@@} $line]} {
5163 $ctext insert end "$line\n" hunksep
5164 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5165 # do nothing
5166 } else {
5167 # parse the prefix - one ' ', '-' or '+' for each parent
5168 set spaces {}
5169 set minuses {}
5170 set pluses {}
5171 set isbad 0
5172 for {set j 0} {$j < $np} {incr j} {
5173 set c [string range $line $j $j]
5174 if {$c == " "} {
5175 lappend spaces $j
5176 } elseif {$c == "-"} {
5177 lappend minuses $j
5178 } elseif {$c == "+"} {
5179 lappend pluses $j
5180 } else {
5181 set isbad 1
5182 break
5183 }
5184 }
5185 set tags {}
5186 set num {}
5187 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5188 # line doesn't appear in result, parents in $minuses have the line
5189 set num [lindex $minuses 0]
5190 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5191 # line appears in result, parents in $pluses don't have the line
5192 lappend tags mresult
5193 set num [lindex $spaces 0]
5194 }
5195 if {$num ne {}} {
5196 if {$num >= $mergemax} {
5197 set num "max"
5198 }
5199 lappend tags m$num
5200 }
5201 $ctext insert end "$line\n" $tags
5202 }
5203 }
5204 $ctext conf -state disabled
5205 if {[eof $mdf]} {
5206 close $mdf
5207 return 0
5208 }
5209 return [expr {$nr >= 1000? 2: 1}]
5210}
5211
5212proc startdiff {ids} {
5213 global treediffs diffids treepending diffmergeid nullid nullid2
5214
5215 settabs 1
5216 set diffids $ids
5217 catch {unset diffmergeid}
5218 if {![info exists treediffs($ids)] ||
5219 [lsearch -exact $ids $nullid] >= 0 ||
5220 [lsearch -exact $ids $nullid2] >= 0} {
5221 if {![info exists treepending]} {
5222 gettreediffs $ids
5223 }
5224 } else {
5225 addtocflist $ids
5226 }
5227}
5228
5229proc addtocflist {ids} {
5230 global treediffs cflist
5231 add_flist $treediffs($ids)
5232 getblobdiffs $ids
5233}
5234
5235proc diffcmd {ids flags} {
5236 global nullid nullid2
5237
5238 set i [lsearch -exact $ids $nullid]
5239 set j [lsearch -exact $ids $nullid2]
5240 if {$i >= 0} {
5241 if {[llength $ids] > 1 && $j < 0} {
5242 # comparing working directory with some specific revision
5243 set cmd [concat | git diff-index $flags]
5244 if {$i == 0} {
5245 lappend cmd -R [lindex $ids 1]
5246 } else {
5247 lappend cmd [lindex $ids 0]
5248 }
5249 } else {
5250 # comparing working directory with index
5251 set cmd [concat | git diff-files $flags]
5252 if {$j == 1} {
5253 lappend cmd -R
5254 }
5255 }
5256 } elseif {$j >= 0} {
5257 set cmd [concat | git diff-index --cached $flags]
5258 if {[llength $ids] > 1} {
5259 # comparing index with specific revision
5260 if {$i == 0} {
5261 lappend cmd -R [lindex $ids 1]
5262 } else {
5263 lappend cmd [lindex $ids 0]
5264 }
5265 } else {
5266 # comparing index with HEAD
5267 lappend cmd HEAD
5268 }
5269 } else {
5270 set cmd [concat | git diff-tree -r $flags $ids]
5271 }
5272 return $cmd
5273}
5274
5275proc gettreediffs {ids} {
5276 global treediff treepending
5277
5278 set treepending $ids
5279 set treediff {}
5280 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5281 fconfigure $gdtf -blocking 0
5282 filerun $gdtf [list gettreediffline $gdtf $ids]
5283}
5284
5285proc gettreediffline {gdtf ids} {
5286 global treediff treediffs treepending diffids diffmergeid
5287 global cmitmode
5288
5289 set nr 0
5290 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5291 set i [string first "\t" $line]
5292 if {$i >= 0} {
5293 set file [string range $line [expr {$i+1}] end]
5294 if {[string index $file 0] eq "\""} {
5295 set file [lindex $file 0]
5296 }
5297 lappend treediff $file
5298 }
5299 }
5300 if {![eof $gdtf]} {
5301 return [expr {$nr >= 1000? 2: 1}]
5302 }
5303 close $gdtf
5304 set treediffs($ids) $treediff
5305 unset treepending
5306 if {$cmitmode eq "tree"} {
5307 gettree $diffids
5308 } elseif {$ids != $diffids} {
5309 if {![info exists diffmergeid]} {
5310 gettreediffs $diffids
5311 }
5312 } else {
5313 addtocflist $ids
5314 }
5315 return 0
5316}
5317
5318# empty string or positive integer
5319proc diffcontextvalidate {v} {
5320 return [regexp {^(|[1-9][0-9]*)$} $v]
5321}
5322
5323proc diffcontextchange {n1 n2 op} {
5324 global diffcontextstring diffcontext
5325
5326 if {[string is integer -strict $diffcontextstring]} {
5327 if {$diffcontextstring > 0} {
5328 set diffcontext $diffcontextstring
5329 reselectline
5330 }
5331 }
5332}
5333
5334proc getblobdiffs {ids} {
5335 global blobdifffd diffids env
5336 global diffinhdr treediffs
5337 global diffcontext
5338
5339 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5340 puts "error getting diffs: $err"
5341 return
5342 }
5343 set diffinhdr 0
5344 fconfigure $bdf -blocking 0
5345 set blobdifffd($ids) $bdf
5346 filerun $bdf [list getblobdiffline $bdf $diffids]
5347}
5348
5349proc setinlist {var i val} {
5350 global $var
5351
5352 while {[llength [set $var]] < $i} {
5353 lappend $var {}
5354 }
5355 if {[llength [set $var]] == $i} {
5356 lappend $var $val
5357 } else {
5358 lset $var $i $val
5359 }
5360}
5361
5362proc makediffhdr {fname ids} {
5363 global ctext curdiffstart treediffs
5364
5365 set i [lsearch -exact $treediffs($ids) $fname]
5366 if {$i >= 0} {
5367 setinlist difffilestart $i $curdiffstart
5368 }
5369 set l [expr {(78 - [string length $fname]) / 2}]
5370 set pad [string range "----------------------------------------" 1 $l]
5371 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5372}
5373
5374proc getblobdiffline {bdf ids} {
5375 global diffids blobdifffd ctext curdiffstart
5376 global diffnexthead diffnextnote difffilestart
5377 global diffinhdr treediffs
5378
5379 set nr 0
5380 $ctext conf -state normal
5381 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5382 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5383 close $bdf
5384 return 0
5385 }
5386 if {![string compare -length 11 "diff --git " $line]} {
5387 # trim off "diff --git "
5388 set line [string range $line 11 end]
5389 set diffinhdr 1
5390 # start of a new file
5391 $ctext insert end "\n"
5392 set curdiffstart [$ctext index "end - 1c"]
5393 $ctext insert end "\n" filesep
5394 # If the name hasn't changed the length will be odd,
5395 # the middle char will be a space, and the two bits either
5396 # side will be a/name and b/name, or "a/name" and "b/name".
5397 # If the name has changed we'll get "rename from" and
5398 # "rename to" or "copy from" and "copy to" lines following this,
5399 # and we'll use them to get the filenames.
5400 # This complexity is necessary because spaces in the filename(s)
5401 # don't get escaped.
5402 set l [string length $line]
5403 set i [expr {$l / 2}]
5404 if {!(($l & 1) && [string index $line $i] eq " " &&
5405 [string range $line 2 [expr {$i - 1}]] eq \
5406 [string range $line [expr {$i + 3}] end])} {
5407 continue
5408 }
5409 # unescape if quoted and chop off the a/ from the front
5410 if {[string index $line 0] eq "\""} {
5411 set fname [string range [lindex $line 0] 2 end]
5412 } else {
5413 set fname [string range $line 2 [expr {$i - 1}]]
5414 }
5415 makediffhdr $fname $ids
5416
5417 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5418 $line match f1l f1c f2l f2c rest]} {
5419 $ctext insert end "$line\n" hunksep
5420 set diffinhdr 0
5421
5422 } elseif {$diffinhdr} {
5423 if {![string compare -length 12 "rename from " $line] ||
5424 ![string compare -length 10 "copy from " $line]} {
5425 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5426 if {[string index $fname 0] eq "\""} {
5427 set fname [lindex $fname 0]
5428 }
5429 set i [lsearch -exact $treediffs($ids) $fname]
5430 if {$i >= 0} {
5431 setinlist difffilestart $i $curdiffstart
5432 }
5433 } elseif {![string compare -length 10 $line "rename to "] ||
5434 ![string compare -length 8 $line "copy to "]} {
5435 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5436 if {[string index $fname 0] eq "\""} {
5437 set fname [lindex $fname 0]
5438 }
5439 makediffhdr $fname $ids
5440 } elseif {[string compare -length 3 $line "---"] == 0} {
5441 # do nothing
5442 continue
5443 } elseif {[string compare -length 3 $line "+++"] == 0} {
5444 set diffinhdr 0
5445 continue
5446 }
5447 $ctext insert end "$line\n" filesep
5448
5449 } else {
5450 set x [string range $line 0 0]
5451 if {$x == "-" || $x == "+"} {
5452 set tag [expr {$x == "+"}]
5453 $ctext insert end "$line\n" d$tag
5454 } elseif {$x == " "} {
5455 $ctext insert end "$line\n"
5456 } else {
5457 # "\ No newline at end of file",
5458 # or something else we don't recognize
5459 $ctext insert end "$line\n" hunksep
5460 }
5461 }
5462 }
5463 $ctext conf -state disabled
5464 if {[eof $bdf]} {
5465 close $bdf
5466 return 0
5467 }
5468 return [expr {$nr >= 1000? 2: 1}]
5469}
5470
5471proc changediffdisp {} {
5472 global ctext diffelide
5473
5474 $ctext tag conf d0 -elide [lindex $diffelide 0]
5475 $ctext tag conf d1 -elide [lindex $diffelide 1]
5476}
5477
5478proc prevfile {} {
5479 global difffilestart ctext
5480 set prev [lindex $difffilestart 0]
5481 set here [$ctext index @0,0]
5482 foreach loc $difffilestart {
5483 if {[$ctext compare $loc >= $here]} {
5484 $ctext yview $prev
5485 return
5486 }
5487 set prev $loc
5488 }
5489 $ctext yview $prev
5490}
5491
5492proc nextfile {} {
5493 global difffilestart ctext
5494 set here [$ctext index @0,0]
5495 foreach loc $difffilestart {
5496 if {[$ctext compare $loc > $here]} {
5497 $ctext yview $loc
5498 return
5499 }
5500 }
5501}
5502
5503proc clear_ctext {{first 1.0}} {
5504 global ctext smarktop smarkbot
5505 global pendinglinks
5506
5507 set l [lindex [split $first .] 0]
5508 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5509 set smarktop $l
5510 }
5511 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5512 set smarkbot $l
5513 }
5514 $ctext delete $first end
5515 if {$first eq "1.0"} {
5516 catch {unset pendinglinks}
5517 }
5518}
5519
5520proc settabs {{firstab {}}} {
5521 global firsttabstop tabstop ctext have_tk85
5522
5523 if {$firstab ne {} && $have_tk85} {
5524 set firsttabstop $firstab
5525 }
5526 set w [font measure textfont "0"]
5527 if {$firsttabstop != 0} {
5528 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5529 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5530 } elseif {$have_tk85 || $tabstop != 8} {
5531 $ctext conf -tabs [expr {$tabstop * $w}]
5532 } else {
5533 $ctext conf -tabs {}
5534 }
5535}
5536
5537proc incrsearch {name ix op} {
5538 global ctext searchstring searchdirn
5539
5540 $ctext tag remove found 1.0 end
5541 if {[catch {$ctext index anchor}]} {
5542 # no anchor set, use start of selection, or of visible area
5543 set sel [$ctext tag ranges sel]
5544 if {$sel ne {}} {
5545 $ctext mark set anchor [lindex $sel 0]
5546 } elseif {$searchdirn eq "-forwards"} {
5547 $ctext mark set anchor @0,0
5548 } else {
5549 $ctext mark set anchor @0,[winfo height $ctext]
5550 }
5551 }
5552 if {$searchstring ne {}} {
5553 set here [$ctext search $searchdirn -- $searchstring anchor]
5554 if {$here ne {}} {
5555 $ctext see $here
5556 }
5557 searchmarkvisible 1
5558 }
5559}
5560
5561proc dosearch {} {
5562 global sstring ctext searchstring searchdirn
5563
5564 focus $sstring
5565 $sstring icursor end
5566 set searchdirn -forwards
5567 if {$searchstring ne {}} {
5568 set sel [$ctext tag ranges sel]
5569 if {$sel ne {}} {
5570 set start "[lindex $sel 0] + 1c"
5571 } elseif {[catch {set start [$ctext index anchor]}]} {
5572 set start "@0,0"
5573 }
5574 set match [$ctext search -count mlen -- $searchstring $start]
5575 $ctext tag remove sel 1.0 end
5576 if {$match eq {}} {
5577 bell
5578 return
5579 }
5580 $ctext see $match
5581 set mend "$match + $mlen c"
5582 $ctext tag add sel $match $mend
5583 $ctext mark unset anchor
5584 }
5585}
5586
5587proc dosearchback {} {
5588 global sstring ctext searchstring searchdirn
5589
5590 focus $sstring
5591 $sstring icursor end
5592 set searchdirn -backwards
5593 if {$searchstring ne {}} {
5594 set sel [$ctext tag ranges sel]
5595 if {$sel ne {}} {
5596 set start [lindex $sel 0]
5597 } elseif {[catch {set start [$ctext index anchor]}]} {
5598 set start @0,[winfo height $ctext]
5599 }
5600 set match [$ctext search -backwards -count ml -- $searchstring $start]
5601 $ctext tag remove sel 1.0 end
5602 if {$match eq {}} {
5603 bell
5604 return
5605 }
5606 $ctext see $match
5607 set mend "$match + $ml c"
5608 $ctext tag add sel $match $mend
5609 $ctext mark unset anchor
5610 }
5611}
5612
5613proc searchmark {first last} {
5614 global ctext searchstring
5615
5616 set mend $first.0
5617 while {1} {
5618 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5619 if {$match eq {}} break
5620 set mend "$match + $mlen c"
5621 $ctext tag add found $match $mend
5622 }
5623}
5624
5625proc searchmarkvisible {doall} {
5626 global ctext smarktop smarkbot
5627
5628 set topline [lindex [split [$ctext index @0,0] .] 0]
5629 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5630 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5631 # no overlap with previous
5632 searchmark $topline $botline
5633 set smarktop $topline
5634 set smarkbot $botline
5635 } else {
5636 if {$topline < $smarktop} {
5637 searchmark $topline [expr {$smarktop-1}]
5638 set smarktop $topline
5639 }
5640 if {$botline > $smarkbot} {
5641 searchmark [expr {$smarkbot+1}] $botline
5642 set smarkbot $botline
5643 }
5644 }
5645}
5646
5647proc scrolltext {f0 f1} {
5648 global searchstring
5649
5650 .bleft.sb set $f0 $f1
5651 if {$searchstring ne {}} {
5652 searchmarkvisible 0
5653 }
5654}
5655
5656proc setcoords {} {
5657 global linespc charspc canvx0 canvy0
5658 global xspc1 xspc2 lthickness
5659
5660 set linespc [font metrics mainfont -linespace]
5661 set charspc [font measure mainfont "m"]
5662 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5663 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5664 set lthickness [expr {int($linespc / 9) + 1}]
5665 set xspc1(0) $linespc
5666 set xspc2 $linespc
5667}
5668
5669proc redisplay {} {
5670 global canv
5671 global selectedline
5672
5673 set ymax [lindex [$canv cget -scrollregion] 3]
5674 if {$ymax eq {} || $ymax == 0} return
5675 set span [$canv yview]
5676 clear_display
5677 setcanvscroll
5678 allcanvs yview moveto [lindex $span 0]
5679 drawvisible
5680 if {[info exists selectedline]} {
5681 selectline $selectedline 0
5682 allcanvs yview moveto [lindex $span 0]
5683 }
5684}
5685
5686proc parsefont {f n} {
5687 global fontattr
5688
5689 set fontattr($f,family) [lindex $n 0]
5690 set s [lindex $n 1]
5691 if {$s eq {} || $s == 0} {
5692 set s 10
5693 } elseif {$s < 0} {
5694 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5695 }
5696 set fontattr($f,size) $s
5697 set fontattr($f,weight) normal
5698 set fontattr($f,slant) roman
5699 foreach style [lrange $n 2 end] {
5700 switch -- $style {
5701 "normal" -
5702 "bold" {set fontattr($f,weight) $style}
5703 "roman" -
5704 "italic" {set fontattr($f,slant) $style}
5705 }
5706 }
5707}
5708
5709proc fontflags {f {isbold 0}} {
5710 global fontattr
5711
5712 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5713 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5714 -slant $fontattr($f,slant)]
5715}
5716
5717proc fontname {f} {
5718 global fontattr
5719
5720 set n [list $fontattr($f,family) $fontattr($f,size)]
5721 if {$fontattr($f,weight) eq "bold"} {
5722 lappend n "bold"
5723 }
5724 if {$fontattr($f,slant) eq "italic"} {
5725 lappend n "italic"
5726 }
5727 return $n
5728}
5729
5730proc incrfont {inc} {
5731 global mainfont textfont ctext canv phase cflist showrefstop
5732 global stopped entries fontattr
5733
5734 unmarkmatches
5735 set s $fontattr(mainfont,size)
5736 incr s $inc
5737 if {$s < 1} {
5738 set s 1
5739 }
5740 set fontattr(mainfont,size) $s
5741 font config mainfont -size $s
5742 font config mainfontbold -size $s
5743 set mainfont [fontname mainfont]
5744 set s $fontattr(textfont,size)
5745 incr s $inc
5746 if {$s < 1} {
5747 set s 1
5748 }
5749 set fontattr(textfont,size) $s
5750 font config textfont -size $s
5751 font config textfontbold -size $s
5752 set textfont [fontname textfont]
5753 setcoords
5754 settabs
5755 redisplay
5756}
5757
5758proc clearsha1 {} {
5759 global sha1entry sha1string
5760 if {[string length $sha1string] == 40} {
5761 $sha1entry delete 0 end
5762 }
5763}
5764
5765proc sha1change {n1 n2 op} {
5766 global sha1string currentid sha1but
5767 if {$sha1string == {}
5768 || ([info exists currentid] && $sha1string == $currentid)} {
5769 set state disabled
5770 } else {
5771 set state normal
5772 }
5773 if {[$sha1but cget -state] == $state} return
5774 if {$state == "normal"} {
5775 $sha1but conf -state normal -relief raised -text "Goto: "
5776 } else {
5777 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5778 }
5779}
5780
5781proc gotocommit {} {
5782 global sha1string currentid commitrow tagids headids
5783 global displayorder numcommits curview
5784
5785 if {$sha1string == {}
5786 || ([info exists currentid] && $sha1string == $currentid)} return
5787 if {[info exists tagids($sha1string)]} {
5788 set id $tagids($sha1string)
5789 } elseif {[info exists headids($sha1string)]} {
5790 set id $headids($sha1string)
5791 } else {
5792 set id [string tolower $sha1string]
5793 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5794 set matches {}
5795 foreach i $displayorder {
5796 if {[string match $id* $i]} {
5797 lappend matches $i
5798 }
5799 }
5800 if {$matches ne {}} {
5801 if {[llength $matches] > 1} {
5802 error_popup "Short SHA1 id $id is ambiguous"
5803 return
5804 }
5805 set id [lindex $matches 0]
5806 }
5807 }
5808 }
5809 if {[info exists commitrow($curview,$id)]} {
5810 selectline $commitrow($curview,$id) 1
5811 return
5812 }
5813 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5814 set type "SHA1 id"
5815 } else {
5816 set type "Tag/Head"
5817 }
5818 error_popup "$type $sha1string is not known"
5819}
5820
5821proc lineenter {x y id} {
5822 global hoverx hovery hoverid hovertimer
5823 global commitinfo canv
5824
5825 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5826 set hoverx $x
5827 set hovery $y
5828 set hoverid $id
5829 if {[info exists hovertimer]} {
5830 after cancel $hovertimer
5831 }
5832 set hovertimer [after 500 linehover]
5833 $canv delete hover
5834}
5835
5836proc linemotion {x y id} {
5837 global hoverx hovery hoverid hovertimer
5838
5839 if {[info exists hoverid] && $id == $hoverid} {
5840 set hoverx $x
5841 set hovery $y
5842 if {[info exists hovertimer]} {
5843 after cancel $hovertimer
5844 }
5845 set hovertimer [after 500 linehover]
5846 }
5847}
5848
5849proc lineleave {id} {
5850 global hoverid hovertimer canv
5851
5852 if {[info exists hoverid] && $id == $hoverid} {
5853 $canv delete hover
5854 if {[info exists hovertimer]} {
5855 after cancel $hovertimer
5856 unset hovertimer
5857 }
5858 unset hoverid
5859 }
5860}
5861
5862proc linehover {} {
5863 global hoverx hovery hoverid hovertimer
5864 global canv linespc lthickness
5865 global commitinfo
5866
5867 set text [lindex $commitinfo($hoverid) 0]
5868 set ymax [lindex [$canv cget -scrollregion] 3]
5869 if {$ymax == {}} return
5870 set yfrac [lindex [$canv yview] 0]
5871 set x [expr {$hoverx + 2 * $linespc}]
5872 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5873 set x0 [expr {$x - 2 * $lthickness}]
5874 set y0 [expr {$y - 2 * $lthickness}]
5875 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5876 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5877 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5878 -fill \#ffff80 -outline black -width 1 -tags hover]
5879 $canv raise $t
5880 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5881 -font mainfont]
5882 $canv raise $t
5883}
5884
5885proc clickisonarrow {id y} {
5886 global lthickness
5887
5888 set ranges [rowranges $id]
5889 set thresh [expr {2 * $lthickness + 6}]
5890 set n [expr {[llength $ranges] - 1}]
5891 for {set i 1} {$i < $n} {incr i} {
5892 set row [lindex $ranges $i]
5893 if {abs([yc $row] - $y) < $thresh} {
5894 return $i
5895 }
5896 }
5897 return {}
5898}
5899
5900proc arrowjump {id n y} {
5901 global canv
5902
5903 # 1 <-> 2, 3 <-> 4, etc...
5904 set n [expr {(($n - 1) ^ 1) + 1}]
5905 set row [lindex [rowranges $id] $n]
5906 set yt [yc $row]
5907 set ymax [lindex [$canv cget -scrollregion] 3]
5908 if {$ymax eq {} || $ymax <= 0} return
5909 set view [$canv yview]
5910 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5911 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5912 if {$yfrac < 0} {
5913 set yfrac 0
5914 }
5915 allcanvs yview moveto $yfrac
5916}
5917
5918proc lineclick {x y id isnew} {
5919 global ctext commitinfo children canv thickerline curview commitrow
5920
5921 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5922 unmarkmatches
5923 unselectline
5924 normalline
5925 $canv delete hover
5926 # draw this line thicker than normal
5927 set thickerline $id
5928 drawlines $id
5929 if {$isnew} {
5930 set ymax [lindex [$canv cget -scrollregion] 3]
5931 if {$ymax eq {}} return
5932 set yfrac [lindex [$canv yview] 0]
5933 set y [expr {$y + $yfrac * $ymax}]
5934 }
5935 set dirn [clickisonarrow $id $y]
5936 if {$dirn ne {}} {
5937 arrowjump $id $dirn $y
5938 return
5939 }
5940
5941 if {$isnew} {
5942 addtohistory [list lineclick $x $y $id 0]
5943 }
5944 # fill the details pane with info about this line
5945 $ctext conf -state normal
5946 clear_ctext
5947 settabs 0
5948 $ctext insert end "Parent:\t"
5949 $ctext insert end $id link0
5950 setlink $id link0
5951 set info $commitinfo($id)
5952 $ctext insert end "\n\t[lindex $info 0]\n"
5953 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5954 set date [formatdate [lindex $info 2]]
5955 $ctext insert end "\tDate:\t$date\n"
5956 set kids $children($curview,$id)
5957 if {$kids ne {}} {
5958 $ctext insert end "\nChildren:"
5959 set i 0
5960 foreach child $kids {
5961 incr i
5962 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5963 set info $commitinfo($child)
5964 $ctext insert end "\n\t"
5965 $ctext insert end $child link$i
5966 setlink $child link$i
5967 $ctext insert end "\n\t[lindex $info 0]"
5968 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5969 set date [formatdate [lindex $info 2]]
5970 $ctext insert end "\n\tDate:\t$date\n"
5971 }
5972 }
5973 $ctext conf -state disabled
5974 init_flist {}
5975}
5976
5977proc normalline {} {
5978 global thickerline
5979 if {[info exists thickerline]} {
5980 set id $thickerline
5981 unset thickerline
5982 drawlines $id
5983 }
5984}
5985
5986proc selbyid {id} {
5987 global commitrow curview
5988 if {[info exists commitrow($curview,$id)]} {
5989 selectline $commitrow($curview,$id) 1
5990 }
5991}
5992
5993proc mstime {} {
5994 global startmstime
5995 if {![info exists startmstime]} {
5996 set startmstime [clock clicks -milliseconds]
5997 }
5998 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5999}
6000
6001proc rowmenu {x y id} {
6002 global rowctxmenu commitrow selectedline rowmenuid curview
6003 global nullid nullid2 fakerowmenu mainhead
6004
6005 stopfinding
6006 set rowmenuid $id
6007 if {![info exists selectedline]
6008 || $commitrow($curview,$id) eq $selectedline} {
6009 set state disabled
6010 } else {
6011 set state normal
6012 }
6013 if {$id ne $nullid && $id ne $nullid2} {
6014 set menu $rowctxmenu
6015 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
6016 } else {
6017 set menu $fakerowmenu
6018 }
6019 $menu entryconfigure "Diff this*" -state $state
6020 $menu entryconfigure "Diff selected*" -state $state
6021 $menu entryconfigure "Make patch" -state $state
6022 tk_popup $menu $x $y
6023}
6024
6025proc diffvssel {dirn} {
6026 global rowmenuid selectedline displayorder
6027
6028 if {![info exists selectedline]} return
6029 if {$dirn} {
6030 set oldid [lindex $displayorder $selectedline]
6031 set newid $rowmenuid
6032 } else {
6033 set oldid $rowmenuid
6034 set newid [lindex $displayorder $selectedline]
6035 }
6036 addtohistory [list doseldiff $oldid $newid]
6037 doseldiff $oldid $newid
6038}
6039
6040proc doseldiff {oldid newid} {
6041 global ctext
6042 global commitinfo
6043
6044 $ctext conf -state normal
6045 clear_ctext
6046 init_flist "Top"
6047 $ctext insert end "From "
6048 $ctext insert end $oldid link0
6049 setlink $oldid link0
6050 $ctext insert end "\n "
6051 $ctext insert end [lindex $commitinfo($oldid) 0]
6052 $ctext insert end "\n\nTo "
6053 $ctext insert end $newid link1
6054 setlink $newid link1
6055 $ctext insert end "\n "
6056 $ctext insert end [lindex $commitinfo($newid) 0]
6057 $ctext insert end "\n"
6058 $ctext conf -state disabled
6059 $ctext tag remove found 1.0 end
6060 startdiff [list $oldid $newid]
6061}
6062
6063proc mkpatch {} {
6064 global rowmenuid currentid commitinfo patchtop patchnum
6065
6066 if {![info exists currentid]} return
6067 set oldid $currentid
6068 set oldhead [lindex $commitinfo($oldid) 0]
6069 set newid $rowmenuid
6070 set newhead [lindex $commitinfo($newid) 0]
6071 set top .patch
6072 set patchtop $top
6073 catch {destroy $top}
6074 toplevel $top
6075 label $top.title -text "Generate patch"
6076 grid $top.title - -pady 10
6077 label $top.from -text "From:"
6078 entry $top.fromsha1 -width 40 -relief flat
6079 $top.fromsha1 insert 0 $oldid
6080 $top.fromsha1 conf -state readonly
6081 grid $top.from $top.fromsha1 -sticky w
6082 entry $top.fromhead -width 60 -relief flat
6083 $top.fromhead insert 0 $oldhead
6084 $top.fromhead conf -state readonly
6085 grid x $top.fromhead -sticky w
6086 label $top.to -text "To:"
6087 entry $top.tosha1 -width 40 -relief flat
6088 $top.tosha1 insert 0 $newid
6089 $top.tosha1 conf -state readonly
6090 grid $top.to $top.tosha1 -sticky w
6091 entry $top.tohead -width 60 -relief flat
6092 $top.tohead insert 0 $newhead
6093 $top.tohead conf -state readonly
6094 grid x $top.tohead -sticky w
6095 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6096 grid $top.rev x -pady 10
6097 label $top.flab -text "Output file:"
6098 entry $top.fname -width 60
6099 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6100 incr patchnum
6101 grid $top.flab $top.fname -sticky w
6102 frame $top.buts
6103 button $top.buts.gen -text "Generate" -command mkpatchgo
6104 button $top.buts.can -text "Cancel" -command mkpatchcan
6105 grid $top.buts.gen $top.buts.can
6106 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6107 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6108 grid $top.buts - -pady 10 -sticky ew
6109 focus $top.fname
6110}
6111
6112proc mkpatchrev {} {
6113 global patchtop
6114
6115 set oldid [$patchtop.fromsha1 get]
6116 set oldhead [$patchtop.fromhead get]
6117 set newid [$patchtop.tosha1 get]
6118 set newhead [$patchtop.tohead get]
6119 foreach e [list fromsha1 fromhead tosha1 tohead] \
6120 v [list $newid $newhead $oldid $oldhead] {
6121 $patchtop.$e conf -state normal
6122 $patchtop.$e delete 0 end
6123 $patchtop.$e insert 0 $v
6124 $patchtop.$e conf -state readonly
6125 }
6126}
6127
6128proc mkpatchgo {} {
6129 global patchtop nullid nullid2
6130
6131 set oldid [$patchtop.fromsha1 get]
6132 set newid [$patchtop.tosha1 get]
6133 set fname [$patchtop.fname get]
6134 set cmd [diffcmd [list $oldid $newid] -p]
6135 # trim off the initial "|"
6136 set cmd [lrange $cmd 1 end]
6137 lappend cmd >$fname &
6138 if {[catch {eval exec $cmd} err]} {
6139 error_popup "Error creating patch: $err"
6140 }
6141 catch {destroy $patchtop}
6142 unset patchtop
6143}
6144
6145proc mkpatchcan {} {
6146 global patchtop
6147
6148 catch {destroy $patchtop}
6149 unset patchtop
6150}
6151
6152proc mktag {} {
6153 global rowmenuid mktagtop commitinfo
6154
6155 set top .maketag
6156 set mktagtop $top
6157 catch {destroy $top}
6158 toplevel $top
6159 label $top.title -text "Create tag"
6160 grid $top.title - -pady 10
6161 label $top.id -text "ID:"
6162 entry $top.sha1 -width 40 -relief flat
6163 $top.sha1 insert 0 $rowmenuid
6164 $top.sha1 conf -state readonly
6165 grid $top.id $top.sha1 -sticky w
6166 entry $top.head -width 60 -relief flat
6167 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6168 $top.head conf -state readonly
6169 grid x $top.head -sticky w
6170 label $top.tlab -text "Tag name:"
6171 entry $top.tag -width 60
6172 grid $top.tlab $top.tag -sticky w
6173 frame $top.buts
6174 button $top.buts.gen -text "Create" -command mktaggo
6175 button $top.buts.can -text "Cancel" -command mktagcan
6176 grid $top.buts.gen $top.buts.can
6177 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6178 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6179 grid $top.buts - -pady 10 -sticky ew
6180 focus $top.tag
6181}
6182
6183proc domktag {} {
6184 global mktagtop env tagids idtags
6185
6186 set id [$mktagtop.sha1 get]
6187 set tag [$mktagtop.tag get]
6188 if {$tag == {}} {
6189 error_popup "No tag name specified"
6190 return
6191 }
6192 if {[info exists tagids($tag)]} {
6193 error_popup "Tag \"$tag\" already exists"
6194 return
6195 }
6196 if {[catch {
6197 set dir [gitdir]
6198 set fname [file join $dir "refs/tags" $tag]
6199 set f [open $fname w]
6200 puts $f $id
6201 close $f
6202 } err]} {
6203 error_popup "Error creating tag: $err"
6204 return
6205 }
6206
6207 set tagids($tag) $id
6208 lappend idtags($id) $tag
6209 redrawtags $id
6210 addedtag $id
6211 dispneartags 0
6212 run refill_reflist
6213}
6214
6215proc redrawtags {id} {
6216 global canv linehtag commitrow idpos selectedline curview
6217 global canvxmax iddrawn
6218
6219 if {![info exists commitrow($curview,$id)]} return
6220 if {![info exists iddrawn($id)]} return
6221 drawcommits $commitrow($curview,$id)
6222 $canv delete tag.$id
6223 set xt [eval drawtags $id $idpos($id)]
6224 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6225 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6226 set xr [expr {$xt + [font measure mainfont $text]}]
6227 if {$xr > $canvxmax} {
6228 set canvxmax $xr
6229 setcanvscroll
6230 }
6231 if {[info exists selectedline]
6232 && $selectedline == $commitrow($curview,$id)} {
6233 selectline $selectedline 0
6234 }
6235}
6236
6237proc mktagcan {} {
6238 global mktagtop
6239
6240 catch {destroy $mktagtop}
6241 unset mktagtop
6242}
6243
6244proc mktaggo {} {
6245 domktag
6246 mktagcan
6247}
6248
6249proc writecommit {} {
6250 global rowmenuid wrcomtop commitinfo wrcomcmd
6251
6252 set top .writecommit
6253 set wrcomtop $top
6254 catch {destroy $top}
6255 toplevel $top
6256 label $top.title -text "Write commit to file"
6257 grid $top.title - -pady 10
6258 label $top.id -text "ID:"
6259 entry $top.sha1 -width 40 -relief flat
6260 $top.sha1 insert 0 $rowmenuid
6261 $top.sha1 conf -state readonly
6262 grid $top.id $top.sha1 -sticky w
6263 entry $top.head -width 60 -relief flat
6264 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6265 $top.head conf -state readonly
6266 grid x $top.head -sticky w
6267 label $top.clab -text "Command:"
6268 entry $top.cmd -width 60 -textvariable wrcomcmd
6269 grid $top.clab $top.cmd -sticky w -pady 10
6270 label $top.flab -text "Output file:"
6271 entry $top.fname -width 60
6272 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6273 grid $top.flab $top.fname -sticky w
6274 frame $top.buts
6275 button $top.buts.gen -text "Write" -command wrcomgo
6276 button $top.buts.can -text "Cancel" -command wrcomcan
6277 grid $top.buts.gen $top.buts.can
6278 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6279 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6280 grid $top.buts - -pady 10 -sticky ew
6281 focus $top.fname
6282}
6283
6284proc wrcomgo {} {
6285 global wrcomtop
6286
6287 set id [$wrcomtop.sha1 get]
6288 set cmd "echo $id | [$wrcomtop.cmd get]"
6289 set fname [$wrcomtop.fname get]
6290 if {[catch {exec sh -c $cmd >$fname &} err]} {
6291 error_popup "Error writing commit: $err"
6292 }
6293 catch {destroy $wrcomtop}
6294 unset wrcomtop
6295}
6296
6297proc wrcomcan {} {
6298 global wrcomtop
6299
6300 catch {destroy $wrcomtop}
6301 unset wrcomtop
6302}
6303
6304proc mkbranch {} {
6305 global rowmenuid mkbrtop
6306
6307 set top .makebranch
6308 catch {destroy $top}
6309 toplevel $top
6310 label $top.title -text "Create new branch"
6311 grid $top.title - -pady 10
6312 label $top.id -text "ID:"
6313 entry $top.sha1 -width 40 -relief flat
6314 $top.sha1 insert 0 $rowmenuid
6315 $top.sha1 conf -state readonly
6316 grid $top.id $top.sha1 -sticky w
6317 label $top.nlab -text "Name:"
6318 entry $top.name -width 40
6319 grid $top.nlab $top.name -sticky w
6320 frame $top.buts
6321 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6322 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6323 grid $top.buts.go $top.buts.can
6324 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6325 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6326 grid $top.buts - -pady 10 -sticky ew
6327 focus $top.name
6328}
6329
6330proc mkbrgo {top} {
6331 global headids idheads
6332
6333 set name [$top.name get]
6334 set id [$top.sha1 get]
6335 if {$name eq {}} {
6336 error_popup "Please specify a name for the new branch"
6337 return
6338 }
6339 catch {destroy $top}
6340 nowbusy newbranch
6341 update
6342 if {[catch {
6343 exec git branch $name $id
6344 } err]} {
6345 notbusy newbranch
6346 error_popup $err
6347 } else {
6348 set headids($name) $id
6349 lappend idheads($id) $name
6350 addedhead $id $name
6351 notbusy newbranch
6352 redrawtags $id
6353 dispneartags 0
6354 run refill_reflist
6355 }
6356}
6357
6358proc cherrypick {} {
6359 global rowmenuid curview commitrow
6360 global mainhead
6361
6362 set oldhead [exec git rev-parse HEAD]
6363 set dheads [descheads $rowmenuid]
6364 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6365 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6366 included in branch $mainhead -- really re-apply it?"]
6367 if {!$ok} return
6368 }
6369 nowbusy cherrypick
6370 update
6371 # Unfortunately git-cherry-pick writes stuff to stderr even when
6372 # no error occurs, and exec takes that as an indication of error...
6373 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6374 notbusy cherrypick
6375 error_popup $err
6376 return
6377 }
6378 set newhead [exec git rev-parse HEAD]
6379 if {$newhead eq $oldhead} {
6380 notbusy cherrypick
6381 error_popup "No changes committed"
6382 return
6383 }
6384 addnewchild $newhead $oldhead
6385 if {[info exists commitrow($curview,$oldhead)]} {
6386 insertrow $commitrow($curview,$oldhead) $newhead
6387 if {$mainhead ne {}} {
6388 movehead $newhead $mainhead
6389 movedhead $newhead $mainhead
6390 }
6391 redrawtags $oldhead
6392 redrawtags $newhead
6393 }
6394 notbusy cherrypick
6395}
6396
6397proc resethead {} {
6398 global mainheadid mainhead rowmenuid confirm_ok resettype
6399
6400 set confirm_ok 0
6401 set w ".confirmreset"
6402 toplevel $w
6403 wm transient $w .
6404 wm title $w "Confirm reset"
6405 message $w.m -text \
6406 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6407 -justify center -aspect 1000
6408 pack $w.m -side top -fill x -padx 20 -pady 20
6409 frame $w.f -relief sunken -border 2
6410 message $w.f.rt -text "Reset type:" -aspect 1000
6411 grid $w.f.rt -sticky w
6412 set resettype mixed
6413 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6414 -text "Soft: Leave working tree and index untouched"
6415 grid $w.f.soft -sticky w
6416 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6417 -text "Mixed: Leave working tree untouched, reset index"
6418 grid $w.f.mixed -sticky w
6419 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6420 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6421 grid $w.f.hard -sticky w
6422 pack $w.f -side top -fill x
6423 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6424 pack $w.ok -side left -fill x -padx 20 -pady 20
6425 button $w.cancel -text Cancel -command "destroy $w"
6426 pack $w.cancel -side right -fill x -padx 20 -pady 20
6427 bind $w <Visibility> "grab $w; focus $w"
6428 tkwait window $w
6429 if {!$confirm_ok} return
6430 if {[catch {set fd [open \
6431 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6432 error_popup $err
6433 } else {
6434 dohidelocalchanges
6435 set w ".resetprogress"
6436 filerun $fd [list readresetstat $fd $w]
6437 toplevel $w
6438 wm transient $w
6439 wm title $w "Reset progress"
6440 message $w.m -text "Reset in progress, please wait..." \
6441 -justify center -aspect 1000
6442 pack $w.m -side top -fill x -padx 20 -pady 5
6443 canvas $w.c -width 150 -height 20 -bg white
6444 $w.c create rect 0 0 0 20 -fill green -tags rect
6445 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6446 nowbusy reset
6447 }
6448}
6449
6450proc readresetstat {fd w} {
6451 global mainhead mainheadid showlocalchanges
6452
6453 if {[gets $fd line] >= 0} {
6454 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6455 set x [expr {($m * 150) / $n}]
6456 $w.c coords rect 0 0 $x 20
6457 }
6458 return 1
6459 }
6460 destroy $w
6461 notbusy reset
6462 if {[catch {close $fd} err]} {
6463 error_popup $err
6464 }
6465 set oldhead $mainheadid
6466 set newhead [exec git rev-parse HEAD]
6467 if {$newhead ne $oldhead} {
6468 movehead $newhead $mainhead
6469 movedhead $newhead $mainhead
6470 set mainheadid $newhead
6471 redrawtags $oldhead
6472 redrawtags $newhead
6473 }
6474 if {$showlocalchanges} {
6475 doshowlocalchanges
6476 }
6477 return 0
6478}
6479
6480# context menu for a head
6481proc headmenu {x y id head} {
6482 global headmenuid headmenuhead headctxmenu mainhead
6483
6484 stopfinding
6485 set headmenuid $id
6486 set headmenuhead $head
6487 set state normal
6488 if {$head eq $mainhead} {
6489 set state disabled
6490 }
6491 $headctxmenu entryconfigure 0 -state $state
6492 $headctxmenu entryconfigure 1 -state $state
6493 tk_popup $headctxmenu $x $y
6494}
6495
6496proc cobranch {} {
6497 global headmenuid headmenuhead mainhead headids
6498 global showlocalchanges mainheadid
6499
6500 # check the tree is clean first??
6501 set oldmainhead $mainhead
6502 nowbusy checkout
6503 update
6504 dohidelocalchanges
6505 if {[catch {
6506 exec git checkout -q $headmenuhead
6507 } err]} {
6508 notbusy checkout
6509 error_popup $err
6510 } else {
6511 notbusy checkout
6512 set mainhead $headmenuhead
6513 set mainheadid $headmenuid
6514 if {[info exists headids($oldmainhead)]} {
6515 redrawtags $headids($oldmainhead)
6516 }
6517 redrawtags $headmenuid
6518 }
6519 if {$showlocalchanges} {
6520 dodiffindex
6521 }
6522}
6523
6524proc rmbranch {} {
6525 global headmenuid headmenuhead mainhead
6526 global idheads
6527
6528 set head $headmenuhead
6529 set id $headmenuid
6530 # this check shouldn't be needed any more...
6531 if {$head eq $mainhead} {
6532 error_popup "Cannot delete the currently checked-out branch"
6533 return
6534 }
6535 set dheads [descheads $id]
6536 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6537 # the stuff on this branch isn't on any other branch
6538 if {![confirm_popup "The commits on branch $head aren't on any other\
6539 branch.\nReally delete branch $head?"]} return
6540 }
6541 nowbusy rmbranch
6542 update
6543 if {[catch {exec git branch -D $head} err]} {
6544 notbusy rmbranch
6545 error_popup $err
6546 return
6547 }
6548 removehead $id $head
6549 removedhead $id $head
6550 redrawtags $id
6551 notbusy rmbranch
6552 dispneartags 0
6553 run refill_reflist
6554}
6555
6556# Display a list of tags and heads
6557proc showrefs {} {
6558 global showrefstop bgcolor fgcolor selectbgcolor
6559 global bglist fglist reflistfilter reflist maincursor
6560
6561 set top .showrefs
6562 set showrefstop $top
6563 if {[winfo exists $top]} {
6564 raise $top
6565 refill_reflist
6566 return
6567 }
6568 toplevel $top
6569 wm title $top "Tags and heads: [file tail [pwd]]"
6570 text $top.list -background $bgcolor -foreground $fgcolor \
6571 -selectbackground $selectbgcolor -font mainfont \
6572 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6573 -width 30 -height 20 -cursor $maincursor \
6574 -spacing1 1 -spacing3 1 -state disabled
6575 $top.list tag configure highlight -background $selectbgcolor
6576 lappend bglist $top.list
6577 lappend fglist $top.list
6578 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6579 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6580 grid $top.list $top.ysb -sticky nsew
6581 grid $top.xsb x -sticky ew
6582 frame $top.f
6583 label $top.f.l -text "Filter: " -font uifont
6584 entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6585 set reflistfilter "*"
6586 trace add variable reflistfilter write reflistfilter_change
6587 pack $top.f.e -side right -fill x -expand 1
6588 pack $top.f.l -side left
6589 grid $top.f - -sticky ew -pady 2
6590 button $top.close -command [list destroy $top] -text "Close" \
6591 -font uifont
6592 grid $top.close -
6593 grid columnconfigure $top 0 -weight 1
6594 grid rowconfigure $top 0 -weight 1
6595 bind $top.list <1> {break}
6596 bind $top.list <B1-Motion> {break}
6597 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6598 set reflist {}
6599 refill_reflist
6600}
6601
6602proc sel_reflist {w x y} {
6603 global showrefstop reflist headids tagids otherrefids
6604
6605 if {![winfo exists $showrefstop]} return
6606 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6607 set ref [lindex $reflist [expr {$l-1}]]
6608 set n [lindex $ref 0]
6609 switch -- [lindex $ref 1] {
6610 "H" {selbyid $headids($n)}
6611 "T" {selbyid $tagids($n)}
6612 "o" {selbyid $otherrefids($n)}
6613 }
6614 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6615}
6616
6617proc unsel_reflist {} {
6618 global showrefstop
6619
6620 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6621 $showrefstop.list tag remove highlight 0.0 end
6622}
6623
6624proc reflistfilter_change {n1 n2 op} {
6625 global reflistfilter
6626
6627 after cancel refill_reflist
6628 after 200 refill_reflist
6629}
6630
6631proc refill_reflist {} {
6632 global reflist reflistfilter showrefstop headids tagids otherrefids
6633 global commitrow curview commitinterest
6634
6635 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6636 set refs {}
6637 foreach n [array names headids] {
6638 if {[string match $reflistfilter $n]} {
6639 if {[info exists commitrow($curview,$headids($n))]} {
6640 lappend refs [list $n H]
6641 } else {
6642 set commitinterest($headids($n)) {run refill_reflist}
6643 }
6644 }
6645 }
6646 foreach n [array names tagids] {
6647 if {[string match $reflistfilter $n]} {
6648 if {[info exists commitrow($curview,$tagids($n))]} {
6649 lappend refs [list $n T]
6650 } else {
6651 set commitinterest($tagids($n)) {run refill_reflist}
6652 }
6653 }
6654 }
6655 foreach n [array names otherrefids] {
6656 if {[string match $reflistfilter $n]} {
6657 if {[info exists commitrow($curview,$otherrefids($n))]} {
6658 lappend refs [list $n o]
6659 } else {
6660 set commitinterest($otherrefids($n)) {run refill_reflist}
6661 }
6662 }
6663 }
6664 set refs [lsort -index 0 $refs]
6665 if {$refs eq $reflist} return
6666
6667 # Update the contents of $showrefstop.list according to the
6668 # differences between $reflist (old) and $refs (new)
6669 $showrefstop.list conf -state normal
6670 $showrefstop.list insert end "\n"
6671 set i 0
6672 set j 0
6673 while {$i < [llength $reflist] || $j < [llength $refs]} {
6674 if {$i < [llength $reflist]} {
6675 if {$j < [llength $refs]} {
6676 set cmp [string compare [lindex $reflist $i 0] \
6677 [lindex $refs $j 0]]
6678 if {$cmp == 0} {
6679 set cmp [string compare [lindex $reflist $i 1] \
6680 [lindex $refs $j 1]]
6681 }
6682 } else {
6683 set cmp -1
6684 }
6685 } else {
6686 set cmp 1
6687 }
6688 switch -- $cmp {
6689 -1 {
6690 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6691 incr i
6692 }
6693 0 {
6694 incr i
6695 incr j
6696 }
6697 1 {
6698 set l [expr {$j + 1}]
6699 $showrefstop.list image create $l.0 -align baseline \
6700 -image reficon-[lindex $refs $j 1] -padx 2
6701 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6702 incr j
6703 }
6704 }
6705 }
6706 set reflist $refs
6707 # delete last newline
6708 $showrefstop.list delete end-2c end-1c
6709 $showrefstop.list conf -state disabled
6710}
6711
6712# Stuff for finding nearby tags
6713proc getallcommits {} {
6714 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6715 global idheads idtags idotherrefs allparents tagobjid
6716
6717 if {![info exists allcommits]} {
6718 set nextarc 0
6719 set allcommits 0
6720 set seeds {}
6721 set allcwait 0
6722 set cachedarcs 0
6723 set allccache [file join [gitdir] "gitk.cache"]
6724 if {![catch {
6725 set f [open $allccache r]
6726 set allcwait 1
6727 getcache $f
6728 }]} return
6729 }
6730
6731 if {$allcwait} {
6732 return
6733 }
6734 set cmd [list | git rev-list --parents]
6735 set allcupdate [expr {$seeds ne {}}]
6736 if {!$allcupdate} {
6737 set ids "--all"
6738 } else {
6739 set refs [concat [array names idheads] [array names idtags] \
6740 [array names idotherrefs]]
6741 set ids {}
6742 set tagobjs {}
6743 foreach name [array names tagobjid] {
6744 lappend tagobjs $tagobjid($name)
6745 }
6746 foreach id [lsort -unique $refs] {
6747 if {![info exists allparents($id)] &&
6748 [lsearch -exact $tagobjs $id] < 0} {
6749 lappend ids $id
6750 }
6751 }
6752 if {$ids ne {}} {
6753 foreach id $seeds {
6754 lappend ids "^$id"
6755 }
6756 }
6757 }
6758 if {$ids ne {}} {
6759 set fd [open [concat $cmd $ids] r]
6760 fconfigure $fd -blocking 0
6761 incr allcommits
6762 nowbusy allcommits
6763 filerun $fd [list getallclines $fd]
6764 } else {
6765 dispneartags 0
6766 }
6767}
6768
6769# Since most commits have 1 parent and 1 child, we group strings of
6770# such commits into "arcs" joining branch/merge points (BMPs), which
6771# are commits that either don't have 1 parent or don't have 1 child.
6772#
6773# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6774# arcout(id) - outgoing arcs for BMP
6775# arcids(a) - list of IDs on arc including end but not start
6776# arcstart(a) - BMP ID at start of arc
6777# arcend(a) - BMP ID at end of arc
6778# growing(a) - arc a is still growing
6779# arctags(a) - IDs out of arcids (excluding end) that have tags
6780# archeads(a) - IDs out of arcids (excluding end) that have heads
6781# The start of an arc is at the descendent end, so "incoming" means
6782# coming from descendents, and "outgoing" means going towards ancestors.
6783
6784proc getallclines {fd} {
6785 global allparents allchildren idtags idheads nextarc
6786 global arcnos arcids arctags arcout arcend arcstart archeads growing
6787 global seeds allcommits cachedarcs allcupdate
6788
6789 set nid 0
6790 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6791 set id [lindex $line 0]
6792 if {[info exists allparents($id)]} {
6793 # seen it already
6794 continue
6795 }
6796 set cachedarcs 0
6797 set olds [lrange $line 1 end]
6798 set allparents($id) $olds
6799 if {![info exists allchildren($id)]} {
6800 set allchildren($id) {}
6801 set arcnos($id) {}
6802 lappend seeds $id
6803 } else {
6804 set a $arcnos($id)
6805 if {[llength $olds] == 1 && [llength $a] == 1} {
6806 lappend arcids($a) $id
6807 if {[info exists idtags($id)]} {
6808 lappend arctags($a) $id
6809 }
6810 if {[info exists idheads($id)]} {
6811 lappend archeads($a) $id
6812 }
6813 if {[info exists allparents($olds)]} {
6814 # seen parent already
6815 if {![info exists arcout($olds)]} {
6816 splitarc $olds
6817 }
6818 lappend arcids($a) $olds
6819 set arcend($a) $olds
6820 unset growing($a)
6821 }
6822 lappend allchildren($olds) $id
6823 lappend arcnos($olds) $a
6824 continue
6825 }
6826 }
6827 foreach a $arcnos($id) {
6828 lappend arcids($a) $id
6829 set arcend($a) $id
6830 unset growing($a)
6831 }
6832
6833 set ao {}
6834 foreach p $olds {
6835 lappend allchildren($p) $id
6836 set a [incr nextarc]
6837 set arcstart($a) $id
6838 set archeads($a) {}
6839 set arctags($a) {}
6840 set archeads($a) {}
6841 set arcids($a) {}
6842 lappend ao $a
6843 set growing($a) 1
6844 if {[info exists allparents($p)]} {
6845 # seen it already, may need to make a new branch
6846 if {![info exists arcout($p)]} {
6847 splitarc $p
6848 }
6849 lappend arcids($a) $p
6850 set arcend($a) $p
6851 unset growing($a)
6852 }
6853 lappend arcnos($p) $a
6854 }
6855 set arcout($id) $ao
6856 }
6857 if {$nid > 0} {
6858 global cached_dheads cached_dtags cached_atags
6859 catch {unset cached_dheads}
6860 catch {unset cached_dtags}
6861 catch {unset cached_atags}
6862 }
6863 if {![eof $fd]} {
6864 return [expr {$nid >= 1000? 2: 1}]
6865 }
6866 set cacheok 1
6867 if {[catch {
6868 fconfigure $fd -blocking 1
6869 close $fd
6870 } err]} {
6871 # got an error reading the list of commits
6872 # if we were updating, try rereading the whole thing again
6873 if {$allcupdate} {
6874 incr allcommits -1
6875 dropcache $err
6876 return
6877 }
6878 error_popup "Error reading commit topology information;\
6879 branch and preceding/following tag information\
6880 will be incomplete.\n($err)"
6881 set cacheok 0
6882 }
6883 if {[incr allcommits -1] == 0} {
6884 notbusy allcommits
6885 if {$cacheok} {
6886 run savecache
6887 }
6888 }
6889 dispneartags 0
6890 return 0
6891}
6892
6893proc recalcarc {a} {
6894 global arctags archeads arcids idtags idheads
6895
6896 set at {}
6897 set ah {}
6898 foreach id [lrange $arcids($a) 0 end-1] {
6899 if {[info exists idtags($id)]} {
6900 lappend at $id
6901 }
6902 if {[info exists idheads($id)]} {
6903 lappend ah $id
6904 }
6905 }
6906 set arctags($a) $at
6907 set archeads($a) $ah
6908}
6909
6910proc splitarc {p} {
6911 global arcnos arcids nextarc arctags archeads idtags idheads
6912 global arcstart arcend arcout allparents growing
6913
6914 set a $arcnos($p)
6915 if {[llength $a] != 1} {
6916 puts "oops splitarc called but [llength $a] arcs already"
6917 return
6918 }
6919 set a [lindex $a 0]
6920 set i [lsearch -exact $arcids($a) $p]
6921 if {$i < 0} {
6922 puts "oops splitarc $p not in arc $a"
6923 return
6924 }
6925 set na [incr nextarc]
6926 if {[info exists arcend($a)]} {
6927 set arcend($na) $arcend($a)
6928 } else {
6929 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6930 set j [lsearch -exact $arcnos($l) $a]
6931 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6932 }
6933 set tail [lrange $arcids($a) [expr {$i+1}] end]
6934 set arcids($a) [lrange $arcids($a) 0 $i]
6935 set arcend($a) $p
6936 set arcstart($na) $p
6937 set arcout($p) $na
6938 set arcids($na) $tail
6939 if {[info exists growing($a)]} {
6940 set growing($na) 1
6941 unset growing($a)
6942 }
6943
6944 foreach id $tail {
6945 if {[llength $arcnos($id)] == 1} {
6946 set arcnos($id) $na
6947 } else {
6948 set j [lsearch -exact $arcnos($id) $a]
6949 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6950 }
6951 }
6952
6953 # reconstruct tags and heads lists
6954 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6955 recalcarc $a
6956 recalcarc $na
6957 } else {
6958 set arctags($na) {}
6959 set archeads($na) {}
6960 }
6961}
6962
6963# Update things for a new commit added that is a child of one
6964# existing commit. Used when cherry-picking.
6965proc addnewchild {id p} {
6966 global allparents allchildren idtags nextarc
6967 global arcnos arcids arctags arcout arcend arcstart archeads growing
6968 global seeds allcommits
6969
6970 if {![info exists allcommits]} return
6971 set allparents($id) [list $p]
6972 set allchildren($id) {}
6973 set arcnos($id) {}
6974 lappend seeds $id
6975 lappend allchildren($p) $id
6976 set a [incr nextarc]
6977 set arcstart($a) $id
6978 set archeads($a) {}
6979 set arctags($a) {}
6980 set arcids($a) [list $p]
6981 set arcend($a) $p
6982 if {![info exists arcout($p)]} {
6983 splitarc $p
6984 }
6985 lappend arcnos($p) $a
6986 set arcout($id) [list $a]
6987}
6988
6989# This implements a cache for the topology information.
6990# The cache saves, for each arc, the start and end of the arc,
6991# the ids on the arc, and the outgoing arcs from the end.
6992proc readcache {f} {
6993 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6994 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6995 global allcwait
6996
6997 set a $nextarc
6998 set lim $cachedarcs
6999 if {$lim - $a > 500} {
7000 set lim [expr {$a + 500}]
7001 }
7002 if {[catch {
7003 if {$a == $lim} {
7004 # finish reading the cache and setting up arctags, etc.
7005 set line [gets $f]
7006 if {$line ne "1"} {error "bad final version"}
7007 close $f
7008 foreach id [array names idtags] {
7009 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7010 [llength $allparents($id)] == 1} {
7011 set a [lindex $arcnos($id) 0]
7012 if {$arctags($a) eq {}} {
7013 recalcarc $a
7014 }
7015 }
7016 }
7017 foreach id [array names idheads] {
7018 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7019 [llength $allparents($id)] == 1} {
7020 set a [lindex $arcnos($id) 0]
7021 if {$archeads($a) eq {}} {
7022 recalcarc $a
7023 }
7024 }
7025 }
7026 foreach id [lsort -unique $possible_seeds] {
7027 if {$arcnos($id) eq {}} {
7028 lappend seeds $id
7029 }
7030 }
7031 set allcwait 0
7032 } else {
7033 while {[incr a] <= $lim} {
7034 set line [gets $f]
7035 if {[llength $line] != 3} {error "bad line"}
7036 set s [lindex $line 0]
7037 set arcstart($a) $s
7038 lappend arcout($s) $a
7039 if {![info exists arcnos($s)]} {
7040 lappend possible_seeds $s
7041 set arcnos($s) {}
7042 }
7043 set e [lindex $line 1]
7044 if {$e eq {}} {
7045 set growing($a) 1
7046 } else {
7047 set arcend($a) $e
7048 if {![info exists arcout($e)]} {
7049 set arcout($e) {}
7050 }
7051 }
7052 set arcids($a) [lindex $line 2]
7053 foreach id $arcids($a) {
7054 lappend allparents($s) $id
7055 set s $id
7056 lappend arcnos($id) $a
7057 }
7058 if {![info exists allparents($s)]} {
7059 set allparents($s) {}
7060 }
7061 set arctags($a) {}
7062 set archeads($a) {}
7063 }
7064 set nextarc [expr {$a - 1}]
7065 }
7066 } err]} {
7067 dropcache $err
7068 return 0
7069 }
7070 if {!$allcwait} {
7071 getallcommits
7072 }
7073 return $allcwait
7074}
7075
7076proc getcache {f} {
7077 global nextarc cachedarcs possible_seeds
7078
7079 if {[catch {
7080 set line [gets $f]
7081 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7082 # make sure it's an integer
7083 set cachedarcs [expr {int([lindex $line 1])}]
7084 if {$cachedarcs < 0} {error "bad number of arcs"}
7085 set nextarc 0
7086 set possible_seeds {}
7087 run readcache $f
7088 } err]} {
7089 dropcache $err
7090 }
7091 return 0
7092}
7093
7094proc dropcache {err} {
7095 global allcwait nextarc cachedarcs seeds
7096
7097 #puts "dropping cache ($err)"
7098 foreach v {arcnos arcout arcids arcstart arcend growing \
7099 arctags archeads allparents allchildren} {
7100 global $v
7101 catch {unset $v}
7102 }
7103 set allcwait 0
7104 set nextarc 0
7105 set cachedarcs 0
7106 set seeds {}
7107 getallcommits
7108}
7109
7110proc writecache {f} {
7111 global cachearc cachedarcs allccache
7112 global arcstart arcend arcnos arcids arcout
7113
7114 set a $cachearc
7115 set lim $cachedarcs
7116 if {$lim - $a > 1000} {
7117 set lim [expr {$a + 1000}]
7118 }
7119 if {[catch {
7120 while {[incr a] <= $lim} {
7121 if {[info exists arcend($a)]} {
7122 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7123 } else {
7124 puts $f [list $arcstart($a) {} $arcids($a)]
7125 }
7126 }
7127 } err]} {
7128 catch {close $f}
7129 catch {file delete $allccache}
7130 #puts "writing cache failed ($err)"
7131 return 0
7132 }
7133 set cachearc [expr {$a - 1}]
7134 if {$a > $cachedarcs} {
7135 puts $f "1"
7136 close $f
7137 return 0
7138 }
7139 return 1
7140}
7141
7142proc savecache {} {
7143 global nextarc cachedarcs cachearc allccache
7144
7145 if {$nextarc == $cachedarcs} return
7146 set cachearc 0
7147 set cachedarcs $nextarc
7148 catch {
7149 set f [open $allccache w]
7150 puts $f [list 1 $cachedarcs]
7151 run writecache $f
7152 }
7153}
7154
7155# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7156# or 0 if neither is true.
7157proc anc_or_desc {a b} {
7158 global arcout arcstart arcend arcnos cached_isanc
7159
7160 if {$arcnos($a) eq $arcnos($b)} {
7161 # Both are on the same arc(s); either both are the same BMP,
7162 # or if one is not a BMP, the other is also not a BMP or is
7163 # the BMP at end of the arc (and it only has 1 incoming arc).
7164 # Or both can be BMPs with no incoming arcs.
7165 if {$a eq $b || $arcnos($a) eq {}} {
7166 return 0
7167 }
7168 # assert {[llength $arcnos($a)] == 1}
7169 set arc [lindex $arcnos($a) 0]
7170 set i [lsearch -exact $arcids($arc) $a]
7171 set j [lsearch -exact $arcids($arc) $b]
7172 if {$i < 0 || $i > $j} {
7173 return 1
7174 } else {
7175 return -1
7176 }
7177 }
7178
7179 if {![info exists arcout($a)]} {
7180 set arc [lindex $arcnos($a) 0]
7181 if {[info exists arcend($arc)]} {
7182 set aend $arcend($arc)
7183 } else {
7184 set aend {}
7185 }
7186 set a $arcstart($arc)
7187 } else {
7188 set aend $a
7189 }
7190 if {![info exists arcout($b)]} {
7191 set arc [lindex $arcnos($b) 0]
7192 if {[info exists arcend($arc)]} {
7193 set bend $arcend($arc)
7194 } else {
7195 set bend {}
7196 }
7197 set b $arcstart($arc)
7198 } else {
7199 set bend $b
7200 }
7201 if {$a eq $bend} {
7202 return 1
7203 }
7204 if {$b eq $aend} {
7205 return -1
7206 }
7207 if {[info exists cached_isanc($a,$bend)]} {
7208 if {$cached_isanc($a,$bend)} {
7209 return 1
7210 }
7211 }
7212 if {[info exists cached_isanc($b,$aend)]} {
7213 if {$cached_isanc($b,$aend)} {
7214 return -1
7215 }
7216 if {[info exists cached_isanc($a,$bend)]} {
7217 return 0
7218 }
7219 }
7220
7221 set todo [list $a $b]
7222 set anc($a) a
7223 set anc($b) b
7224 for {set i 0} {$i < [llength $todo]} {incr i} {
7225 set x [lindex $todo $i]
7226 if {$anc($x) eq {}} {
7227 continue
7228 }
7229 foreach arc $arcnos($x) {
7230 set xd $arcstart($arc)
7231 if {$xd eq $bend} {
7232 set cached_isanc($a,$bend) 1
7233 set cached_isanc($b,$aend) 0
7234 return 1
7235 } elseif {$xd eq $aend} {
7236 set cached_isanc($b,$aend) 1
7237 set cached_isanc($a,$bend) 0
7238 return -1
7239 }
7240 if {![info exists anc($xd)]} {
7241 set anc($xd) $anc($x)
7242 lappend todo $xd
7243 } elseif {$anc($xd) ne $anc($x)} {
7244 set anc($xd) {}
7245 }
7246 }
7247 }
7248 set cached_isanc($a,$bend) 0
7249 set cached_isanc($b,$aend) 0
7250 return 0
7251}
7252
7253# This identifies whether $desc has an ancestor that is
7254# a growing tip of the graph and which is not an ancestor of $anc
7255# and returns 0 if so and 1 if not.
7256# If we subsequently discover a tag on such a growing tip, and that
7257# turns out to be a descendent of $anc (which it could, since we
7258# don't necessarily see children before parents), then $desc
7259# isn't a good choice to display as a descendent tag of
7260# $anc (since it is the descendent of another tag which is
7261# a descendent of $anc). Similarly, $anc isn't a good choice to
7262# display as a ancestor tag of $desc.
7263#
7264proc is_certain {desc anc} {
7265 global arcnos arcout arcstart arcend growing problems
7266
7267 set certain {}
7268 if {[llength $arcnos($anc)] == 1} {
7269 # tags on the same arc are certain
7270 if {$arcnos($desc) eq $arcnos($anc)} {
7271 return 1
7272 }
7273 if {![info exists arcout($anc)]} {
7274 # if $anc is partway along an arc, use the start of the arc instead
7275 set a [lindex $arcnos($anc) 0]
7276 set anc $arcstart($a)
7277 }
7278 }
7279 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7280 set x $desc
7281 } else {
7282 set a [lindex $arcnos($desc) 0]
7283 set x $arcend($a)
7284 }
7285 if {$x == $anc} {
7286 return 1
7287 }
7288 set anclist [list $x]
7289 set dl($x) 1
7290 set nnh 1
7291 set ngrowanc 0
7292 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7293 set x [lindex $anclist $i]
7294 if {$dl($x)} {
7295 incr nnh -1
7296 }
7297 set done($x) 1
7298 foreach a $arcout($x) {
7299 if {[info exists growing($a)]} {
7300 if {![info exists growanc($x)] && $dl($x)} {
7301 set growanc($x) 1
7302 incr ngrowanc
7303 }
7304 } else {
7305 set y $arcend($a)
7306 if {[info exists dl($y)]} {
7307 if {$dl($y)} {
7308 if {!$dl($x)} {
7309 set dl($y) 0
7310 if {![info exists done($y)]} {
7311 incr nnh -1
7312 }
7313 if {[info exists growanc($x)]} {
7314 incr ngrowanc -1
7315 }
7316 set xl [list $y]
7317 for {set k 0} {$k < [llength $xl]} {incr k} {
7318 set z [lindex $xl $k]
7319 foreach c $arcout($z) {
7320 if {[info exists arcend($c)]} {
7321 set v $arcend($c)
7322 if {[info exists dl($v)] && $dl($v)} {
7323 set dl($v) 0
7324 if {![info exists done($v)]} {
7325 incr nnh -1
7326 }
7327 if {[info exists growanc($v)]} {
7328 incr ngrowanc -1
7329 }
7330 lappend xl $v
7331 }
7332 }
7333 }
7334 }
7335 }
7336 }
7337 } elseif {$y eq $anc || !$dl($x)} {
7338 set dl($y) 0
7339 lappend anclist $y
7340 } else {
7341 set dl($y) 1
7342 lappend anclist $y
7343 incr nnh
7344 }
7345 }
7346 }
7347 }
7348 foreach x [array names growanc] {
7349 if {$dl($x)} {
7350 return 0
7351 }
7352 return 0
7353 }
7354 return 1
7355}
7356
7357proc validate_arctags {a} {
7358 global arctags idtags
7359
7360 set i -1
7361 set na $arctags($a)
7362 foreach id $arctags($a) {
7363 incr i
7364 if {![info exists idtags($id)]} {
7365 set na [lreplace $na $i $i]
7366 incr i -1
7367 }
7368 }
7369 set arctags($a) $na
7370}
7371
7372proc validate_archeads {a} {
7373 global archeads idheads
7374
7375 set i -1
7376 set na $archeads($a)
7377 foreach id $archeads($a) {
7378 incr i
7379 if {![info exists idheads($id)]} {
7380 set na [lreplace $na $i $i]
7381 incr i -1
7382 }
7383 }
7384 set archeads($a) $na
7385}
7386
7387# Return the list of IDs that have tags that are descendents of id,
7388# ignoring IDs that are descendents of IDs already reported.
7389proc desctags {id} {
7390 global arcnos arcstart arcids arctags idtags allparents
7391 global growing cached_dtags
7392
7393 if {![info exists allparents($id)]} {
7394 return {}
7395 }
7396 set t1 [clock clicks -milliseconds]
7397 set argid $id
7398 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7399 # part-way along an arc; check that arc first
7400 set a [lindex $arcnos($id) 0]
7401 if {$arctags($a) ne {}} {
7402 validate_arctags $a
7403 set i [lsearch -exact $arcids($a) $id]
7404 set tid {}
7405 foreach t $arctags($a) {
7406 set j [lsearch -exact $arcids($a) $t]
7407 if {$j >= $i} break
7408 set tid $t
7409 }
7410 if {$tid ne {}} {
7411 return $tid
7412 }
7413 }
7414 set id $arcstart($a)
7415 if {[info exists idtags($id)]} {
7416 return $id
7417 }
7418 }
7419 if {[info exists cached_dtags($id)]} {
7420 return $cached_dtags($id)
7421 }
7422
7423 set origid $id
7424 set todo [list $id]
7425 set queued($id) 1
7426 set nc 1
7427 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7428 set id [lindex $todo $i]
7429 set done($id) 1
7430 set ta [info exists hastaggedancestor($id)]
7431 if {!$ta} {
7432 incr nc -1
7433 }
7434 # ignore tags on starting node
7435 if {!$ta && $i > 0} {
7436 if {[info exists idtags($id)]} {
7437 set tagloc($id) $id
7438 set ta 1
7439 } elseif {[info exists cached_dtags($id)]} {
7440 set tagloc($id) $cached_dtags($id)
7441 set ta 1
7442 }
7443 }
7444 foreach a $arcnos($id) {
7445 set d $arcstart($a)
7446 if {!$ta && $arctags($a) ne {}} {
7447 validate_arctags $a
7448 if {$arctags($a) ne {}} {
7449 lappend tagloc($id) [lindex $arctags($a) end]
7450 }
7451 }
7452 if {$ta || $arctags($a) ne {}} {
7453 set tomark [list $d]
7454 for {set j 0} {$j < [llength $tomark]} {incr j} {
7455 set dd [lindex $tomark $j]
7456 if {![info exists hastaggedancestor($dd)]} {
7457 if {[info exists done($dd)]} {
7458 foreach b $arcnos($dd) {
7459 lappend tomark $arcstart($b)
7460 }
7461 if {[info exists tagloc($dd)]} {
7462 unset tagloc($dd)
7463 }
7464 } elseif {[info exists queued($dd)]} {
7465 incr nc -1
7466 }
7467 set hastaggedancestor($dd) 1
7468 }
7469 }
7470 }
7471 if {![info exists queued($d)]} {
7472 lappend todo $d
7473 set queued($d) 1
7474 if {![info exists hastaggedancestor($d)]} {
7475 incr nc
7476 }
7477 }
7478 }
7479 }
7480 set tags {}
7481 foreach id [array names tagloc] {
7482 if {![info exists hastaggedancestor($id)]} {
7483 foreach t $tagloc($id) {
7484 if {[lsearch -exact $tags $t] < 0} {
7485 lappend tags $t
7486 }
7487 }
7488 }
7489 }
7490 set t2 [clock clicks -milliseconds]
7491 set loopix $i
7492
7493 # remove tags that are descendents of other tags
7494 for {set i 0} {$i < [llength $tags]} {incr i} {
7495 set a [lindex $tags $i]
7496 for {set j 0} {$j < $i} {incr j} {
7497 set b [lindex $tags $j]
7498 set r [anc_or_desc $a $b]
7499 if {$r == 1} {
7500 set tags [lreplace $tags $j $j]
7501 incr j -1
7502 incr i -1
7503 } elseif {$r == -1} {
7504 set tags [lreplace $tags $i $i]
7505 incr i -1
7506 break
7507 }
7508 }
7509 }
7510
7511 if {[array names growing] ne {}} {
7512 # graph isn't finished, need to check if any tag could get
7513 # eclipsed by another tag coming later. Simply ignore any
7514 # tags that could later get eclipsed.
7515 set ctags {}
7516 foreach t $tags {
7517 if {[is_certain $t $origid]} {
7518 lappend ctags $t
7519 }
7520 }
7521 if {$tags eq $ctags} {
7522 set cached_dtags($origid) $tags
7523 } else {
7524 set tags $ctags
7525 }
7526 } else {
7527 set cached_dtags($origid) $tags
7528 }
7529 set t3 [clock clicks -milliseconds]
7530 if {0 && $t3 - $t1 >= 100} {
7531 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7532 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7533 }
7534 return $tags
7535}
7536
7537proc anctags {id} {
7538 global arcnos arcids arcout arcend arctags idtags allparents
7539 global growing cached_atags
7540
7541 if {![info exists allparents($id)]} {
7542 return {}
7543 }
7544 set t1 [clock clicks -milliseconds]
7545 set argid $id
7546 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7547 # part-way along an arc; check that arc first
7548 set a [lindex $arcnos($id) 0]
7549 if {$arctags($a) ne {}} {
7550 validate_arctags $a
7551 set i [lsearch -exact $arcids($a) $id]
7552 foreach t $arctags($a) {
7553 set j [lsearch -exact $arcids($a) $t]
7554 if {$j > $i} {
7555 return $t
7556 }
7557 }
7558 }
7559 if {![info exists arcend($a)]} {
7560 return {}
7561 }
7562 set id $arcend($a)
7563 if {[info exists idtags($id)]} {
7564 return $id
7565 }
7566 }
7567 if {[info exists cached_atags($id)]} {
7568 return $cached_atags($id)
7569 }
7570
7571 set origid $id
7572 set todo [list $id]
7573 set queued($id) 1
7574 set taglist {}
7575 set nc 1
7576 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7577 set id [lindex $todo $i]
7578 set done($id) 1
7579 set td [info exists hastaggeddescendent($id)]
7580 if {!$td} {
7581 incr nc -1
7582 }
7583 # ignore tags on starting node
7584 if {!$td && $i > 0} {
7585 if {[info exists idtags($id)]} {
7586 set tagloc($id) $id
7587 set td 1
7588 } elseif {[info exists cached_atags($id)]} {
7589 set tagloc($id) $cached_atags($id)
7590 set td 1
7591 }
7592 }
7593 foreach a $arcout($id) {
7594 if {!$td && $arctags($a) ne {}} {
7595 validate_arctags $a
7596 if {$arctags($a) ne {}} {
7597 lappend tagloc($id) [lindex $arctags($a) 0]
7598 }
7599 }
7600 if {![info exists arcend($a)]} continue
7601 set d $arcend($a)
7602 if {$td || $arctags($a) ne {}} {
7603 set tomark [list $d]
7604 for {set j 0} {$j < [llength $tomark]} {incr j} {
7605 set dd [lindex $tomark $j]
7606 if {![info exists hastaggeddescendent($dd)]} {
7607 if {[info exists done($dd)]} {
7608 foreach b $arcout($dd) {
7609 if {[info exists arcend($b)]} {
7610 lappend tomark $arcend($b)
7611 }
7612 }
7613 if {[info exists tagloc($dd)]} {
7614 unset tagloc($dd)
7615 }
7616 } elseif {[info exists queued($dd)]} {
7617 incr nc -1
7618 }
7619 set hastaggeddescendent($dd) 1
7620 }
7621 }
7622 }
7623 if {![info exists queued($d)]} {
7624 lappend todo $d
7625 set queued($d) 1
7626 if {![info exists hastaggeddescendent($d)]} {
7627 incr nc
7628 }
7629 }
7630 }
7631 }
7632 set t2 [clock clicks -milliseconds]
7633 set loopix $i
7634 set tags {}
7635 foreach id [array names tagloc] {
7636 if {![info exists hastaggeddescendent($id)]} {
7637 foreach t $tagloc($id) {
7638 if {[lsearch -exact $tags $t] < 0} {
7639 lappend tags $t
7640 }
7641 }
7642 }
7643 }
7644
7645 # remove tags that are ancestors of other tags
7646 for {set i 0} {$i < [llength $tags]} {incr i} {
7647 set a [lindex $tags $i]
7648 for {set j 0} {$j < $i} {incr j} {
7649 set b [lindex $tags $j]
7650 set r [anc_or_desc $a $b]
7651 if {$r == -1} {
7652 set tags [lreplace $tags $j $j]
7653 incr j -1
7654 incr i -1
7655 } elseif {$r == 1} {
7656 set tags [lreplace $tags $i $i]
7657 incr i -1
7658 break
7659 }
7660 }
7661 }
7662
7663 if {[array names growing] ne {}} {
7664 # graph isn't finished, need to check if any tag could get
7665 # eclipsed by another tag coming later. Simply ignore any
7666 # tags that could later get eclipsed.
7667 set ctags {}
7668 foreach t $tags {
7669 if {[is_certain $origid $t]} {
7670 lappend ctags $t
7671 }
7672 }
7673 if {$tags eq $ctags} {
7674 set cached_atags($origid) $tags
7675 } else {
7676 set tags $ctags
7677 }
7678 } else {
7679 set cached_atags($origid) $tags
7680 }
7681 set t3 [clock clicks -milliseconds]
7682 if {0 && $t3 - $t1 >= 100} {
7683 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7684 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7685 }
7686 return $tags
7687}
7688
7689# Return the list of IDs that have heads that are descendents of id,
7690# including id itself if it has a head.
7691proc descheads {id} {
7692 global arcnos arcstart arcids archeads idheads cached_dheads
7693 global allparents
7694
7695 if {![info exists allparents($id)]} {
7696 return {}
7697 }
7698 set aret {}
7699 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7700 # part-way along an arc; check it first
7701 set a [lindex $arcnos($id) 0]
7702 if {$archeads($a) ne {}} {
7703 validate_archeads $a
7704 set i [lsearch -exact $arcids($a) $id]
7705 foreach t $archeads($a) {
7706 set j [lsearch -exact $arcids($a) $t]
7707 if {$j > $i} break
7708 lappend aret $t
7709 }
7710 }
7711 set id $arcstart($a)
7712 }
7713 set origid $id
7714 set todo [list $id]
7715 set seen($id) 1
7716 set ret {}
7717 for {set i 0} {$i < [llength $todo]} {incr i} {
7718 set id [lindex $todo $i]
7719 if {[info exists cached_dheads($id)]} {
7720 set ret [concat $ret $cached_dheads($id)]
7721 } else {
7722 if {[info exists idheads($id)]} {
7723 lappend ret $id
7724 }
7725 foreach a $arcnos($id) {
7726 if {$archeads($a) ne {}} {
7727 validate_archeads $a
7728 if {$archeads($a) ne {}} {
7729 set ret [concat $ret $archeads($a)]
7730 }
7731 }
7732 set d $arcstart($a)
7733 if {![info exists seen($d)]} {
7734 lappend todo $d
7735 set seen($d) 1
7736 }
7737 }
7738 }
7739 }
7740 set ret [lsort -unique $ret]
7741 set cached_dheads($origid) $ret
7742 return [concat $ret $aret]
7743}
7744
7745proc addedtag {id} {
7746 global arcnos arcout cached_dtags cached_atags
7747
7748 if {![info exists arcnos($id)]} return
7749 if {![info exists arcout($id)]} {
7750 recalcarc [lindex $arcnos($id) 0]
7751 }
7752 catch {unset cached_dtags}
7753 catch {unset cached_atags}
7754}
7755
7756proc addedhead {hid head} {
7757 global arcnos arcout cached_dheads
7758
7759 if {![info exists arcnos($hid)]} return
7760 if {![info exists arcout($hid)]} {
7761 recalcarc [lindex $arcnos($hid) 0]
7762 }
7763 catch {unset cached_dheads}
7764}
7765
7766proc removedhead {hid head} {
7767 global cached_dheads
7768
7769 catch {unset cached_dheads}
7770}
7771
7772proc movedhead {hid head} {
7773 global arcnos arcout cached_dheads
7774
7775 if {![info exists arcnos($hid)]} return
7776 if {![info exists arcout($hid)]} {
7777 recalcarc [lindex $arcnos($hid) 0]
7778 }
7779 catch {unset cached_dheads}
7780}
7781
7782proc changedrefs {} {
7783 global cached_dheads cached_dtags cached_atags
7784 global arctags archeads arcnos arcout idheads idtags
7785
7786 foreach id [concat [array names idheads] [array names idtags]] {
7787 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7788 set a [lindex $arcnos($id) 0]
7789 if {![info exists donearc($a)]} {
7790 recalcarc $a
7791 set donearc($a) 1
7792 }
7793 }
7794 }
7795 catch {unset cached_dtags}
7796 catch {unset cached_atags}
7797 catch {unset cached_dheads}
7798}
7799
7800proc rereadrefs {} {
7801 global idtags idheads idotherrefs mainhead
7802
7803 set refids [concat [array names idtags] \
7804 [array names idheads] [array names idotherrefs]]
7805 foreach id $refids {
7806 if {![info exists ref($id)]} {
7807 set ref($id) [listrefs $id]
7808 }
7809 }
7810 set oldmainhead $mainhead
7811 readrefs
7812 changedrefs
7813 set refids [lsort -unique [concat $refids [array names idtags] \
7814 [array names idheads] [array names idotherrefs]]]
7815 foreach id $refids {
7816 set v [listrefs $id]
7817 if {![info exists ref($id)] || $ref($id) != $v ||
7818 ($id eq $oldmainhead && $id ne $mainhead) ||
7819 ($id eq $mainhead && $id ne $oldmainhead)} {
7820 redrawtags $id
7821 }
7822 }
7823 run refill_reflist
7824}
7825
7826proc listrefs {id} {
7827 global idtags idheads idotherrefs
7828
7829 set x {}
7830 if {[info exists idtags($id)]} {
7831 set x $idtags($id)
7832 }
7833 set y {}
7834 if {[info exists idheads($id)]} {
7835 set y $idheads($id)
7836 }
7837 set z {}
7838 if {[info exists idotherrefs($id)]} {
7839 set z $idotherrefs($id)
7840 }
7841 return [list $x $y $z]
7842}
7843
7844proc showtag {tag isnew} {
7845 global ctext tagcontents tagids linknum tagobjid
7846
7847 if {$isnew} {
7848 addtohistory [list showtag $tag 0]
7849 }
7850 $ctext conf -state normal
7851 clear_ctext
7852 settabs 0
7853 set linknum 0
7854 if {![info exists tagcontents($tag)]} {
7855 catch {
7856 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7857 }
7858 }
7859 if {[info exists tagcontents($tag)]} {
7860 set text $tagcontents($tag)
7861 } else {
7862 set text "Tag: $tag\nId: $tagids($tag)"
7863 }
7864 appendwithlinks $text {}
7865 $ctext conf -state disabled
7866 init_flist {}
7867}
7868
7869proc doquit {} {
7870 global stopped
7871 set stopped 100
7872 savestuff .
7873 destroy .
7874}
7875
7876proc mkfontdisp {font top which} {
7877 global fontattr fontpref $font
7878
7879 set fontpref($font) [set $font]
7880 button $top.${font}but -text $which -font optionfont \
7881 -command [list choosefont $font $which]
7882 label $top.$font -relief flat -font $font \
7883 -text $fontattr($font,family) -justify left
7884 grid x $top.${font}but $top.$font -sticky w
7885}
7886
7887proc choosefont {font which} {
7888 global fontparam fontlist fonttop fontattr
7889
7890 set fontparam(which) $which
7891 set fontparam(font) $font
7892 set fontparam(family) [font actual $font -family]
7893 set fontparam(size) $fontattr($font,size)
7894 set fontparam(weight) $fontattr($font,weight)
7895 set fontparam(slant) $fontattr($font,slant)
7896 set top .gitkfont
7897 set fonttop $top
7898 if {![winfo exists $top]} {
7899 font create sample
7900 eval font config sample [font actual $font]
7901 toplevel $top
7902 wm title $top "Gitk font chooser"
7903 label $top.l -textvariable fontparam(which) -font uifont
7904 pack $top.l -side top
7905 set fontlist [lsort [font families]]
7906 frame $top.f
7907 listbox $top.f.fam -listvariable fontlist \
7908 -yscrollcommand [list $top.f.sb set]
7909 bind $top.f.fam <<ListboxSelect>> selfontfam
7910 scrollbar $top.f.sb -command [list $top.f.fam yview]
7911 pack $top.f.sb -side right -fill y
7912 pack $top.f.fam -side left -fill both -expand 1
7913 pack $top.f -side top -fill both -expand 1
7914 frame $top.g
7915 spinbox $top.g.size -from 4 -to 40 -width 4 \
7916 -textvariable fontparam(size) \
7917 -validatecommand {string is integer -strict %s}
7918 checkbutton $top.g.bold -padx 5 \
7919 -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7920 -variable fontparam(weight) -onvalue bold -offvalue normal
7921 checkbutton $top.g.ital -padx 5 \
7922 -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0 \
7923 -variable fontparam(slant) -onvalue italic -offvalue roman
7924 pack $top.g.size $top.g.bold $top.g.ital -side left
7925 pack $top.g -side top
7926 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7927 -background white
7928 $top.c create text 100 25 -anchor center -text $which -font sample \
7929 -fill black -tags text
7930 bind $top.c <Configure> [list centertext $top.c]
7931 pack $top.c -side top -fill x
7932 frame $top.buts
7933 button $top.buts.ok -text "OK" -command fontok -default active \
7934 -font uifont
7935 button $top.buts.can -text "Cancel" -command fontcan -default normal \
7936 -font uifont
7937 grid $top.buts.ok $top.buts.can
7938 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7939 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7940 pack $top.buts -side bottom -fill x
7941 trace add variable fontparam write chg_fontparam
7942 } else {
7943 raise $top
7944 $top.c itemconf text -text $which
7945 }
7946 set i [lsearch -exact $fontlist $fontparam(family)]
7947 if {$i >= 0} {
7948 $top.f.fam selection set $i
7949 $top.f.fam see $i
7950 }
7951}
7952
7953proc centertext {w} {
7954 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7955}
7956
7957proc fontok {} {
7958 global fontparam fontpref prefstop
7959
7960 set f $fontparam(font)
7961 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7962 if {$fontparam(weight) eq "bold"} {
7963 lappend fontpref($f) "bold"
7964 }
7965 if {$fontparam(slant) eq "italic"} {
7966 lappend fontpref($f) "italic"
7967 }
7968 set w $prefstop.$f
7969 $w conf -text $fontparam(family) -font $fontpref($f)
7970
7971 fontcan
7972}
7973
7974proc fontcan {} {
7975 global fonttop fontparam
7976
7977 if {[info exists fonttop]} {
7978 catch {destroy $fonttop}
7979 catch {font delete sample}
7980 unset fonttop
7981 unset fontparam
7982 }
7983}
7984
7985proc selfontfam {} {
7986 global fonttop fontparam
7987
7988 set i [$fonttop.f.fam curselection]
7989 if {$i ne {}} {
7990 set fontparam(family) [$fonttop.f.fam get $i]
7991 }
7992}
7993
7994proc chg_fontparam {v sub op} {
7995 global fontparam
7996
7997 font config sample -$sub $fontparam($sub)
7998}
7999
8000proc doprefs {} {
8001 global maxwidth maxgraphpct
8002 global oldprefs prefstop showneartags showlocalchanges
8003 global bgcolor fgcolor ctext diffcolors selectbgcolor
8004 global uifont tabstop
8005
8006 set top .gitkprefs
8007 set prefstop $top
8008 if {[winfo exists $top]} {
8009 raise $top
8010 return
8011 }
8012 foreach v {maxwidth maxgraphpct showneartags showlocalchanges} {
8013 set oldprefs($v) [set $v]
8014 }
8015 toplevel $top
8016 wm title $top "Gitk preferences"
8017 label $top.ldisp -text "Commit list display options"
8018 $top.ldisp configure -font uifont
8019 grid $top.ldisp - -sticky w -pady 10
8020 label $top.spacer -text " "
8021 label $top.maxwidthl -text "Maximum graph width (lines)" \
8022 -font optionfont
8023 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8024 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8025 label $top.maxpctl -text "Maximum graph width (% of pane)" \
8026 -font optionfont
8027 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8028 grid x $top.maxpctl $top.maxpct -sticky w
8029 frame $top.showlocal
8030 label $top.showlocal.l -text "Show local changes" -font optionfont
8031 checkbutton $top.showlocal.b -variable showlocalchanges
8032 pack $top.showlocal.b $top.showlocal.l -side left
8033 grid x $top.showlocal -sticky w
8034
8035 label $top.ddisp -text "Diff display options"
8036 $top.ddisp configure -font uifont
8037 grid $top.ddisp - -sticky w -pady 10
8038 frame $top.ntag
8039 label $top.ntag.l -text "Display nearby tags" -font optionfont
8040 checkbutton $top.ntag.b -variable showneartags
8041 pack $top.ntag.b $top.ntag.l -side left
8042 grid x $top.ntag -sticky w
8043 label $top.tabstopl -text "tabstop" -font optionfont
8044 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8045 grid x $top.tabstopl $top.tabstop -sticky w
8046
8047 label $top.cdisp -text "Colors: press to choose"
8048 $top.cdisp configure -font uifont
8049 grid $top.cdisp - -sticky w -pady 10
8050 label $top.bg -padx 40 -relief sunk -background $bgcolor
8051 button $top.bgbut -text "Background" -font optionfont \
8052 -command [list choosecolor bgcolor 0 $top.bg background setbg]
8053 grid x $top.bgbut $top.bg -sticky w
8054 label $top.fg -padx 40 -relief sunk -background $fgcolor
8055 button $top.fgbut -text "Foreground" -font optionfont \
8056 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8057 grid x $top.fgbut $top.fg -sticky w
8058 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8059 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8060 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8061 [list $ctext tag conf d0 -foreground]]
8062 grid x $top.diffoldbut $top.diffold -sticky w
8063 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8064 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8065 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8066 [list $ctext tag conf d1 -foreground]]
8067 grid x $top.diffnewbut $top.diffnew -sticky w
8068 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8069 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8070 -command [list choosecolor diffcolors 2 $top.hunksep \
8071 "diff hunk header" \
8072 [list $ctext tag conf hunksep -foreground]]
8073 grid x $top.hunksepbut $top.hunksep -sticky w
8074 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8075 button $top.selbgbut -text "Select bg" -font optionfont \
8076 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8077 grid x $top.selbgbut $top.selbgsep -sticky w
8078
8079 label $top.cfont -text "Fonts: press to choose"
8080 $top.cfont configure -font uifont
8081 grid $top.cfont - -sticky w -pady 10
8082 mkfontdisp mainfont $top "Main font"
8083 mkfontdisp textfont $top "Diff display font"
8084 mkfontdisp uifont $top "User interface font"
8085
8086 frame $top.buts
8087 button $top.buts.ok -text "OK" -command prefsok -default active
8088 $top.buts.ok configure -font uifont
8089 button $top.buts.can -text "Cancel" -command prefscan -default normal
8090 $top.buts.can configure -font uifont
8091 grid $top.buts.ok $top.buts.can
8092 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8093 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8094 grid $top.buts - - -pady 10 -sticky ew
8095 bind $top <Visibility> "focus $top.buts.ok"
8096}
8097
8098proc choosecolor {v vi w x cmd} {
8099 global $v
8100
8101 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8102 -title "Gitk: choose color for $x"]
8103 if {$c eq {}} return
8104 $w conf -background $c
8105 lset $v $vi $c
8106 eval $cmd $c
8107}
8108
8109proc setselbg {c} {
8110 global bglist cflist
8111 foreach w $bglist {
8112 $w configure -selectbackground $c
8113 }
8114 $cflist tag configure highlight \
8115 -background [$cflist cget -selectbackground]
8116 allcanvs itemconf secsel -fill $c
8117}
8118
8119proc setbg {c} {
8120 global bglist
8121
8122 foreach w $bglist {
8123 $w conf -background $c
8124 }
8125}
8126
8127proc setfg {c} {
8128 global fglist canv
8129
8130 foreach w $fglist {
8131 $w conf -foreground $c
8132 }
8133 allcanvs itemconf text -fill $c
8134 $canv itemconf circle -outline $c
8135}
8136
8137proc prefscan {} {
8138 global maxwidth maxgraphpct
8139 global oldprefs prefstop showneartags showlocalchanges
8140
8141 foreach v {maxwidth maxgraphpct showneartags showlocalchanges} {
8142 set $v $oldprefs($v)
8143 }
8144 catch {destroy $prefstop}
8145 unset prefstop
8146 fontcan
8147}
8148
8149proc prefsok {} {
8150 global maxwidth maxgraphpct
8151 global oldprefs prefstop showneartags showlocalchanges
8152 global fontpref mainfont textfont uifont
8153
8154 catch {destroy $prefstop}
8155 unset prefstop
8156 fontcan
8157 set fontchanged 0
8158 if {$mainfont ne $fontpref(mainfont)} {
8159 set mainfont $fontpref(mainfont)
8160 parsefont mainfont $mainfont
8161 eval font configure mainfont [fontflags mainfont]
8162 eval font configure mainfontbold [fontflags mainfont 1]
8163 setcoords
8164 set fontchanged 1
8165 }
8166 if {$textfont ne $fontpref(textfont)} {
8167 set textfont $fontpref(textfont)
8168 parsefont textfont $textfont
8169 eval font configure textfont [fontflags textfont]
8170 eval font configure textfontbold [fontflags textfont 1]
8171 }
8172 if {$uifont ne $fontpref(uifont)} {
8173 set uifont $fontpref(uifont)
8174 parsefont uifont $uifont
8175 eval font configure uifont [fontflags uifont]
8176 }
8177 settabs
8178 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8179 if {$showlocalchanges} {
8180 doshowlocalchanges
8181 } else {
8182 dohidelocalchanges
8183 }
8184 }
8185 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8186 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8187 redisplay
8188 } elseif {$showneartags != $oldprefs(showneartags)} {
8189 reselectline
8190 }
8191}
8192
8193proc formatdate {d} {
8194 global datetimeformat
8195 if {$d ne {}} {
8196 set d [clock format $d -format $datetimeformat]
8197 }
8198 return $d
8199}
8200
8201# This list of encoding names and aliases is distilled from
8202# http://www.iana.org/assignments/character-sets.
8203# Not all of them are supported by Tcl.
8204set encoding_aliases {
8205 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8206 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8207 { ISO-10646-UTF-1 csISO10646UTF1 }
8208 { ISO_646.basic:1983 ref csISO646basic1983 }
8209 { INVARIANT csINVARIANT }
8210 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8211 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8212 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8213 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8214 { NATS-DANO iso-ir-9-1 csNATSDANO }
8215 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8216 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8217 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8218 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8219 { ISO-2022-KR csISO2022KR }
8220 { EUC-KR csEUCKR }
8221 { ISO-2022-JP csISO2022JP }
8222 { ISO-2022-JP-2 csISO2022JP2 }
8223 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8224 csISO13JISC6220jp }
8225 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8226 { IT iso-ir-15 ISO646-IT csISO15Italian }
8227 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8228 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8229 { greek7-old iso-ir-18 csISO18Greek7Old }
8230 { latin-greek iso-ir-19 csISO19LatinGreek }
8231 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8232 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8233 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8234 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8235 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8236 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8237 { INIS iso-ir-49 csISO49INIS }
8238 { INIS-8 iso-ir-50 csISO50INIS8 }
8239 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8240 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8241 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8242 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8243 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8244 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8245 csISO60Norwegian1 }
8246 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8247 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8248 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8249 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8250 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8251 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8252 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8253 { greek7 iso-ir-88 csISO88Greek7 }
8254 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8255 { iso-ir-90 csISO90 }
8256 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8257 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8258 csISO92JISC62991984b }
8259 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8260 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8261 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8262 csISO95JIS62291984handadd }
8263 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8264 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8265 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8266 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8267 CP819 csISOLatin1 }
8268 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8269 { T.61-7bit iso-ir-102 csISO102T617bit }
8270 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8271 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8272 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8273 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8274 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8275 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8276 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8277 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8278 arabic csISOLatinArabic }
8279 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8280 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8281 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8282 greek greek8 csISOLatinGreek }
8283 { T.101-G2 iso-ir-128 csISO128T101G2 }
8284 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8285 csISOLatinHebrew }
8286 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8287 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8288 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8289 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8290 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8291 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8292 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8293 csISOLatinCyrillic }
8294 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8295 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8296 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8297 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8298 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8299 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8300 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8301 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8302 { ISO_10367-box iso-ir-155 csISO10367Box }
8303 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8304 { latin-lap lap iso-ir-158 csISO158Lap }
8305 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8306 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8307 { us-dk csUSDK }
8308 { dk-us csDKUS }
8309 { JIS_X0201 X0201 csHalfWidthKatakana }
8310 { KSC5636 ISO646-KR csKSC5636 }
8311 { ISO-10646-UCS-2 csUnicode }
8312 { ISO-10646-UCS-4 csUCS4 }
8313 { DEC-MCS dec csDECMCS }
8314 { hp-roman8 roman8 r8 csHPRoman8 }
8315 { macintosh mac csMacintosh }
8316 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8317 csIBM037 }
8318 { IBM038 EBCDIC-INT cp038 csIBM038 }
8319 { IBM273 CP273 csIBM273 }
8320 { IBM274 EBCDIC-BE CP274 csIBM274 }
8321 { IBM275 EBCDIC-BR cp275 csIBM275 }
8322 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8323 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8324 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8325 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8326 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8327 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8328 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8329 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8330 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8331 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8332 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8333 { IBM437 cp437 437 csPC8CodePage437 }
8334 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8335 { IBM775 cp775 csPC775Baltic }
8336 { IBM850 cp850 850 csPC850Multilingual }
8337 { IBM851 cp851 851 csIBM851 }
8338 { IBM852 cp852 852 csPCp852 }
8339 { IBM855 cp855 855 csIBM855 }
8340 { IBM857 cp857 857 csIBM857 }
8341 { IBM860 cp860 860 csIBM860 }
8342 { IBM861 cp861 861 cp-is csIBM861 }
8343 { IBM862 cp862 862 csPC862LatinHebrew }
8344 { IBM863 cp863 863 csIBM863 }
8345 { IBM864 cp864 csIBM864 }
8346 { IBM865 cp865 865 csIBM865 }
8347 { IBM866 cp866 866 csIBM866 }
8348 { IBM868 CP868 cp-ar csIBM868 }
8349 { IBM869 cp869 869 cp-gr csIBM869 }
8350 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8351 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8352 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8353 { IBM891 cp891 csIBM891 }
8354 { IBM903 cp903 csIBM903 }
8355 { IBM904 cp904 904 csIBBM904 }
8356 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8357 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8358 { IBM1026 CP1026 csIBM1026 }
8359 { EBCDIC-AT-DE csIBMEBCDICATDE }
8360 { EBCDIC-AT-DE-A csEBCDICATDEA }
8361 { EBCDIC-CA-FR csEBCDICCAFR }
8362 { EBCDIC-DK-NO csEBCDICDKNO }
8363 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8364 { EBCDIC-FI-SE csEBCDICFISE }
8365 { EBCDIC-FI-SE-A csEBCDICFISEA }
8366 { EBCDIC-FR csEBCDICFR }
8367 { EBCDIC-IT csEBCDICIT }
8368 { EBCDIC-PT csEBCDICPT }
8369 { EBCDIC-ES csEBCDICES }
8370 { EBCDIC-ES-A csEBCDICESA }
8371 { EBCDIC-ES-S csEBCDICESS }
8372 { EBCDIC-UK csEBCDICUK }
8373 { EBCDIC-US csEBCDICUS }
8374 { UNKNOWN-8BIT csUnknown8BiT }
8375 { MNEMONIC csMnemonic }
8376 { MNEM csMnem }
8377 { VISCII csVISCII }
8378 { VIQR csVIQR }
8379 { KOI8-R csKOI8R }
8380 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8381 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8382 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8383 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8384 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8385 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8386 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8387 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8388 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8389 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8390 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8391 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8392 { IBM1047 IBM-1047 }
8393 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8394 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8395 { UNICODE-1-1 csUnicode11 }
8396 { CESU-8 csCESU-8 }
8397 { BOCU-1 csBOCU-1 }
8398 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8399 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8400 l8 }
8401 { ISO-8859-15 ISO_8859-15 Latin-9 }
8402 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8403 { GBK CP936 MS936 windows-936 }
8404 { JIS_Encoding csJISEncoding }
8405 { Shift_JIS MS_Kanji csShiftJIS }
8406 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8407 EUC-JP }
8408 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8409 { ISO-10646-UCS-Basic csUnicodeASCII }
8410 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8411 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8412 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8413 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8414 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8415 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8416 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8417 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8418 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8419 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8420 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8421 { Ventura-US csVenturaUS }
8422 { Ventura-International csVenturaInternational }
8423 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8424 { PC8-Turkish csPC8Turkish }
8425 { IBM-Symbols csIBMSymbols }
8426 { IBM-Thai csIBMThai }
8427 { HP-Legal csHPLegal }
8428 { HP-Pi-font csHPPiFont }
8429 { HP-Math8 csHPMath8 }
8430 { Adobe-Symbol-Encoding csHPPSMath }
8431 { HP-DeskTop csHPDesktop }
8432 { Ventura-Math csVenturaMath }
8433 { Microsoft-Publishing csMicrosoftPublishing }
8434 { Windows-31J csWindows31J }
8435 { GB2312 csGB2312 }
8436 { Big5 csBig5 }
8437}
8438
8439proc tcl_encoding {enc} {
8440 global encoding_aliases
8441 set names [encoding names]
8442 set lcnames [string tolower $names]
8443 set enc [string tolower $enc]
8444 set i [lsearch -exact $lcnames $enc]
8445 if {$i < 0} {
8446 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8447 if {[regsub {^iso[-_]} $enc iso encx]} {
8448 set i [lsearch -exact $lcnames $encx]
8449 }
8450 }
8451 if {$i < 0} {
8452 foreach l $encoding_aliases {
8453 set ll [string tolower $l]
8454 if {[lsearch -exact $ll $enc] < 0} continue
8455 # look through the aliases for one that tcl knows about
8456 foreach e $ll {
8457 set i [lsearch -exact $lcnames $e]
8458 if {$i < 0} {
8459 if {[regsub {^iso[-_]} $e iso ex]} {
8460 set i [lsearch -exact $lcnames $ex]
8461 }
8462 }
8463 if {$i >= 0} break
8464 }
8465 break
8466 }
8467 }
8468 if {$i >= 0} {
8469 return [lindex $names $i]
8470 }
8471 return {}
8472}
8473
8474# defaults...
8475set datemode 0
8476set wrcomcmd "git diff-tree --stdin -p --pretty"
8477
8478set gitencoding {}
8479catch {
8480 set gitencoding [exec git config --get i18n.commitencoding]
8481}
8482if {$gitencoding == ""} {
8483 set gitencoding "utf-8"
8484}
8485set tclencoding [tcl_encoding $gitencoding]
8486if {$tclencoding == {}} {
8487 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8488}
8489
8490set mainfont {Helvetica 9}
8491set textfont {Courier 9}
8492set uifont {Helvetica 9 bold}
8493set tabstop 8
8494set findmergefiles 0
8495set maxgraphpct 50
8496set maxwidth 16
8497set revlistorder 0
8498set fastdate 0
8499set uparrowlen 5
8500set downarrowlen 5
8501set mingaplen 100
8502set cmitmode "patch"
8503set wrapcomment "none"
8504set showneartags 1
8505set maxrefs 20
8506set maxlinelen 200
8507set showlocalchanges 1
8508set datetimeformat "%Y-%m-%d %H:%M:%S"
8509
8510set colors {green red blue magenta darkgrey brown orange}
8511set bgcolor white
8512set fgcolor black
8513set diffcolors {red "#00a000" blue}
8514set diffcontext 3
8515set selectbgcolor gray85
8516
8517catch {source ~/.gitk}
8518
8519font create optionfont -family sans-serif -size -12
8520
8521parsefont mainfont $mainfont
8522eval font create mainfont [fontflags mainfont]
8523eval font create mainfontbold [fontflags mainfont 1]
8524
8525parsefont textfont $textfont
8526eval font create textfont [fontflags textfont]
8527eval font create textfontbold [fontflags textfont 1]
8528
8529parsefont uifont $uifont
8530eval font create uifont [fontflags uifont]
8531
8532# check that we can find a .git directory somewhere...
8533if {[catch {set gitdir [gitdir]}]} {
8534 show_error {} . "Cannot find a git repository here."
8535 exit 1
8536}
8537if {![file isdirectory $gitdir]} {
8538 show_error {} . "Cannot find the git directory \"$gitdir\"."
8539 exit 1
8540}
8541
8542set revtreeargs {}
8543set cmdline_files {}
8544set i 0
8545foreach arg $argv {
8546 switch -- $arg {
8547 "" { }
8548 "-d" { set datemode 1 }
8549 "--" {
8550 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8551 break
8552 }
8553 default {
8554 lappend revtreeargs $arg
8555 }
8556 }
8557 incr i
8558}
8559
8560if {$i >= [llength $argv] && $revtreeargs ne {}} {
8561 # no -- on command line, but some arguments (other than -d)
8562 if {[catch {
8563 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8564 set cmdline_files [split $f "\n"]
8565 set n [llength $cmdline_files]
8566 set revtreeargs [lrange $revtreeargs 0 end-$n]
8567 # Unfortunately git rev-parse doesn't produce an error when
8568 # something is both a revision and a filename. To be consistent
8569 # with git log and git rev-list, check revtreeargs for filenames.
8570 foreach arg $revtreeargs {
8571 if {[file exists $arg]} {
8572 show_error {} . "Ambiguous argument '$arg': both revision\
8573 and filename"
8574 exit 1
8575 }
8576 }
8577 } err]} {
8578 # unfortunately we get both stdout and stderr in $err,
8579 # so look for "fatal:".
8580 set i [string first "fatal:" $err]
8581 if {$i > 0} {
8582 set err [string range $err [expr {$i + 6}] end]
8583 }
8584 show_error {} . "Bad arguments to gitk:\n$err"
8585 exit 1
8586 }
8587}
8588
8589set nullid "0000000000000000000000000000000000000000"
8590set nullid2 "0000000000000000000000000000000000000001"
8591
8592set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8593
8594set runq {}
8595set history {}
8596set historyindex 0
8597set fh_serial 0
8598set nhl_names {}
8599set highlight_paths {}
8600set findpattern {}
8601set searchdirn -forwards
8602set boldrows {}
8603set boldnamerows {}
8604set diffelide {0 0}
8605set markingmatches 0
8606set linkentercount 0
8607set need_redisplay 0
8608set nrows_drawn 0
8609set firsttabstop 0
8610
8611set nextviewnum 1
8612set curview 0
8613set selectedview 0
8614set selectedhlview None
8615set highlight_related None
8616set highlight_files {}
8617set viewfiles(0) {}
8618set viewperm(0) 0
8619set viewargs(0) {}
8620
8621set cmdlineok 0
8622set stopped 0
8623set stuffsaved 0
8624set patchnum 0
8625set localirow -1
8626set localfrow -1
8627set lserial 0
8628setcoords
8629makewindow
8630# wait for the window to become visible
8631tkwait visibility .
8632wm title . "[file tail $argv0]: [file tail [pwd]]"
8633readrefs
8634
8635if {$cmdline_files ne {} || $revtreeargs ne {}} {
8636 # create a view for the files/dirs specified on the command line
8637 set curview 1
8638 set selectedview 1
8639 set nextviewnum 2
8640 set viewname(1) "Command line"
8641 set viewfiles(1) $cmdline_files
8642 set viewargs(1) $revtreeargs
8643 set viewperm(1) 0
8644 addviewmenu 1
8645 .bar.view entryconf Edit* -state normal
8646 .bar.view entryconf Delete* -state normal
8647}
8648
8649if {[info exists permviews]} {
8650 foreach v $permviews {
8651 set n $nextviewnum
8652 incr nextviewnum
8653 set viewname($n) [lindex $v 0]
8654 set viewfiles($n) [lindex $v 1]
8655 set viewargs($n) [lindex $v 2]
8656 set viewperm($n) 1
8657 addviewmenu $n
8658 }
8659}
8660getcommits