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