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 diffcontext
5036 global parentlist
5037 global limitdiffs viewfiles curview
5038
5039 set diffmergeid $id
5040 set diffids $id
5041 # this doesn't seem to actually affect anything...
5042 set cmd [concat | git diff-tree --no-commit-id --cc -U$diffcontext $id]
5043 if {$limitdiffs && $viewfiles($curview) ne {}} {
5044 set cmd [concat $cmd -- $viewfiles($curview)]
5045 }
5046 if {[catch {set mdf [open $cmd r]} err]} {
5047 error_popup "[mc "Error getting merge diffs:"] $err"
5048 return
5049 }
5050 fconfigure $mdf -blocking 0
5051 set mdifffd($id) $mdf
5052 set np [llength [lindex $parentlist $l]]
5053 settabs $np
5054 filerun $mdf [list getmergediffline $mdf $id $np]
5055}
5056
5057proc getmergediffline {mdf id np} {
5058 global diffmergeid ctext cflist mergemax
5059 global difffilestart mdifffd
5060
5061 $ctext conf -state normal
5062 set nr 0
5063 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5064 if {![info exists diffmergeid] || $id != $diffmergeid
5065 || $mdf != $mdifffd($id)} {
5066 close $mdf
5067 return 0
5068 }
5069 if {[regexp {^diff --cc (.*)} $line match fname]} {
5070 # start of a new file
5071 $ctext insert end "\n"
5072 set here [$ctext index "end - 1c"]
5073 lappend difffilestart $here
5074 add_flist [list $fname]
5075 set l [expr {(78 - [string length $fname]) / 2}]
5076 set pad [string range "----------------------------------------" 1 $l]
5077 $ctext insert end "$pad $fname $pad\n" filesep
5078 } elseif {[regexp {^@@} $line]} {
5079 $ctext insert end "$line\n" hunksep
5080 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5081 # do nothing
5082 } else {
5083 # parse the prefix - one ' ', '-' or '+' for each parent
5084 set spaces {}
5085 set minuses {}
5086 set pluses {}
5087 set isbad 0
5088 for {set j 0} {$j < $np} {incr j} {
5089 set c [string range $line $j $j]
5090 if {$c == " "} {
5091 lappend spaces $j
5092 } elseif {$c == "-"} {
5093 lappend minuses $j
5094 } elseif {$c == "+"} {
5095 lappend pluses $j
5096 } else {
5097 set isbad 1
5098 break
5099 }
5100 }
5101 set tags {}
5102 set num {}
5103 if {!$isbad && $minuses ne {} && $pluses eq {}} {
5104 # line doesn't appear in result, parents in $minuses have the line
5105 set num [lindex $minuses 0]
5106 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5107 # line appears in result, parents in $pluses don't have the line
5108 lappend tags mresult
5109 set num [lindex $spaces 0]
5110 }
5111 if {$num ne {}} {
5112 if {$num >= $mergemax} {
5113 set num "max"
5114 }
5115 lappend tags m$num
5116 }
5117 $ctext insert end "$line\n" $tags
5118 }
5119 }
5120 $ctext conf -state disabled
5121 if {[eof $mdf]} {
5122 close $mdf
5123 return 0
5124 }
5125 return [expr {$nr >= 1000? 2: 1}]
5126}
5127
5128proc startdiff {ids} {
5129 global treediffs diffids treepending diffmergeid nullid nullid2
5130
5131 settabs 1
5132 set diffids $ids
5133 catch {unset diffmergeid}
5134 if {![info exists treediffs($ids)] ||
5135 [lsearch -exact $ids $nullid] >= 0 ||
5136 [lsearch -exact $ids $nullid2] >= 0} {
5137 if {![info exists treepending]} {
5138 gettreediffs $ids
5139 }
5140 } else {
5141 addtocflist $ids
5142 }
5143}
5144
5145proc path_filter {filter name} {
5146 foreach p $filter {
5147 set l [string length $p]
5148 if {[string index $p end] eq "/"} {
5149 if {[string compare -length $l $p $name] == 0} {
5150 return 1
5151 }
5152 } else {
5153 if {[string compare -length $l $p $name] == 0 &&
5154 ([string length $name] == $l ||
5155 [string index $name $l] eq "/")} {
5156 return 1
5157 }
5158 }
5159 }
5160 return 0
5161}
5162
5163proc addtocflist {ids} {
5164 global treediffs
5165
5166 add_flist $treediffs($ids)
5167 getblobdiffs $ids
5168}
5169
5170proc diffcmd {ids flags} {
5171 global nullid nullid2
5172
5173 set i [lsearch -exact $ids $nullid]
5174 set j [lsearch -exact $ids $nullid2]
5175 if {$i >= 0} {
5176 if {[llength $ids] > 1 && $j < 0} {
5177 # comparing working directory with some specific revision
5178 set cmd [concat | git diff-index $flags]
5179 if {$i == 0} {
5180 lappend cmd -R [lindex $ids 1]
5181 } else {
5182 lappend cmd [lindex $ids 0]
5183 }
5184 } else {
5185 # comparing working directory with index
5186 set cmd [concat | git diff-files $flags]
5187 if {$j == 1} {
5188 lappend cmd -R
5189 }
5190 }
5191 } elseif {$j >= 0} {
5192 set cmd [concat | git diff-index --cached $flags]
5193 if {[llength $ids] > 1} {
5194 # comparing index with specific revision
5195 if {$i == 0} {
5196 lappend cmd -R [lindex $ids 1]
5197 } else {
5198 lappend cmd [lindex $ids 0]
5199 }
5200 } else {
5201 # comparing index with HEAD
5202 lappend cmd HEAD
5203 }
5204 } else {
5205 set cmd [concat | git diff-tree -r $flags $ids]
5206 }
5207 return $cmd
5208}
5209
5210proc gettreediffs {ids} {
5211 global treediff treepending
5212
5213 set treepending $ids
5214 set treediff {}
5215 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5216 fconfigure $gdtf -blocking 0
5217 filerun $gdtf [list gettreediffline $gdtf $ids]
5218}
5219
5220proc gettreediffline {gdtf ids} {
5221 global treediff treediffs treepending diffids diffmergeid
5222 global cmitmode viewfiles curview limitdiffs
5223
5224 set nr 0
5225 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5226 set i [string first "\t" $line]
5227 if {$i >= 0} {
5228 set file [string range $line [expr {$i+1}] end]
5229 if {[string index $file 0] eq "\""} {
5230 set file [lindex $file 0]
5231 }
5232 lappend treediff $file
5233 }
5234 }
5235 if {![eof $gdtf]} {
5236 return [expr {$nr >= 1000? 2: 1}]
5237 }
5238 close $gdtf
5239 if {$limitdiffs && $viewfiles($curview) ne {}} {
5240 set flist {}
5241 foreach f $treediff {
5242 if {[path_filter $viewfiles($curview) $f]} {
5243 lappend flist $f
5244 }
5245 }
5246 set treediffs($ids) $flist
5247 } else {
5248 set treediffs($ids) $treediff
5249 }
5250 unset treepending
5251 if {$cmitmode eq "tree"} {
5252 gettree $diffids
5253 } elseif {$ids != $diffids} {
5254 if {![info exists diffmergeid]} {
5255 gettreediffs $diffids
5256 }
5257 } else {
5258 addtocflist $ids
5259 }
5260 return 0
5261}
5262
5263# empty string or positive integer
5264proc diffcontextvalidate {v} {
5265 return [regexp {^(|[1-9][0-9]*)$} $v]
5266}
5267
5268proc diffcontextchange {n1 n2 op} {
5269 global diffcontextstring diffcontext
5270
5271 if {[string is integer -strict $diffcontextstring]} {
5272 if {$diffcontextstring > 0} {
5273 set diffcontext $diffcontextstring
5274 reselectline
5275 }
5276 }
5277}
5278
5279proc changeignorespace {} {
5280 reselectline
5281}
5282
5283proc getblobdiffs {ids} {
5284 global blobdifffd diffids env
5285 global diffinhdr treediffs
5286 global diffcontext
5287 global ignorespace
5288 global limitdiffs viewfiles curview
5289
5290 set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5291 if {$ignorespace} {
5292 append cmd " -w"
5293 }
5294 if {$limitdiffs && $viewfiles($curview) ne {}} {
5295 set cmd [concat $cmd -- $viewfiles($curview)]
5296 }
5297 if {[catch {set bdf [open $cmd r]} err]} {
5298 puts "error getting diffs: $err"
5299 return
5300 }
5301 set diffinhdr 0
5302 fconfigure $bdf -blocking 0
5303 set blobdifffd($ids) $bdf
5304 filerun $bdf [list getblobdiffline $bdf $diffids]
5305}
5306
5307proc setinlist {var i val} {
5308 global $var
5309
5310 while {[llength [set $var]] < $i} {
5311 lappend $var {}
5312 }
5313 if {[llength [set $var]] == $i} {
5314 lappend $var $val
5315 } else {
5316 lset $var $i $val
5317 }
5318}
5319
5320proc makediffhdr {fname ids} {
5321 global ctext curdiffstart treediffs
5322
5323 set i [lsearch -exact $treediffs($ids) $fname]
5324 if {$i >= 0} {
5325 setinlist difffilestart $i $curdiffstart
5326 }
5327 set l [expr {(78 - [string length $fname]) / 2}]
5328 set pad [string range "----------------------------------------" 1 $l]
5329 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5330}
5331
5332proc getblobdiffline {bdf ids} {
5333 global diffids blobdifffd ctext curdiffstart
5334 global diffnexthead diffnextnote difffilestart
5335 global diffinhdr treediffs
5336
5337 set nr 0
5338 $ctext conf -state normal
5339 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5340 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5341 close $bdf
5342 return 0
5343 }
5344 if {![string compare -length 11 "diff --git " $line]} {
5345 # trim off "diff --git "
5346 set line [string range $line 11 end]
5347 set diffinhdr 1
5348 # start of a new file
5349 $ctext insert end "\n"
5350 set curdiffstart [$ctext index "end - 1c"]
5351 $ctext insert end "\n" filesep
5352 # If the name hasn't changed the length will be odd,
5353 # the middle char will be a space, and the two bits either
5354 # side will be a/name and b/name, or "a/name" and "b/name".
5355 # If the name has changed we'll get "rename from" and
5356 # "rename to" or "copy from" and "copy to" lines following this,
5357 # and we'll use them to get the filenames.
5358 # This complexity is necessary because spaces in the filename(s)
5359 # don't get escaped.
5360 set l [string length $line]
5361 set i [expr {$l / 2}]
5362 if {!(($l & 1) && [string index $line $i] eq " " &&
5363 [string range $line 2 [expr {$i - 1}]] eq \
5364 [string range $line [expr {$i + 3}] end])} {
5365 continue
5366 }
5367 # unescape if quoted and chop off the a/ from the front
5368 if {[string index $line 0] eq "\""} {
5369 set fname [string range [lindex $line 0] 2 end]
5370 } else {
5371 set fname [string range $line 2 [expr {$i - 1}]]
5372 }
5373 makediffhdr $fname $ids
5374
5375 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5376 $line match f1l f1c f2l f2c rest]} {
5377 $ctext insert end "$line\n" hunksep
5378 set diffinhdr 0
5379
5380 } elseif {$diffinhdr} {
5381 if {![string compare -length 12 "rename from " $line]} {
5382 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5383 if {[string index $fname 0] eq "\""} {
5384 set fname [lindex $fname 0]
5385 }
5386 set i [lsearch -exact $treediffs($ids) $fname]
5387 if {$i >= 0} {
5388 setinlist difffilestart $i $curdiffstart
5389 }
5390 } elseif {![string compare -length 10 $line "rename to "] ||
5391 ![string compare -length 8 $line "copy to "]} {
5392 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5393 if {[string index $fname 0] eq "\""} {
5394 set fname [lindex $fname 0]
5395 }
5396 makediffhdr $fname $ids
5397 } elseif {[string compare -length 3 $line "---"] == 0} {
5398 # do nothing
5399 continue
5400 } elseif {[string compare -length 3 $line "+++"] == 0} {
5401 set diffinhdr 0
5402 continue
5403 }
5404 $ctext insert end "$line\n" filesep
5405
5406 } else {
5407 set x [string range $line 0 0]
5408 if {$x == "-" || $x == "+"} {
5409 set tag [expr {$x == "+"}]
5410 $ctext insert end "$line\n" d$tag
5411 } elseif {$x == " "} {
5412 $ctext insert end "$line\n"
5413 } else {
5414 # "\ No newline at end of file",
5415 # or something else we don't recognize
5416 $ctext insert end "$line\n" hunksep
5417 }
5418 }
5419 }
5420 $ctext conf -state disabled
5421 if {[eof $bdf]} {
5422 close $bdf
5423 return 0
5424 }
5425 return [expr {$nr >= 1000? 2: 1}]
5426}
5427
5428proc changediffdisp {} {
5429 global ctext diffelide
5430
5431 $ctext tag conf d0 -elide [lindex $diffelide 0]
5432 $ctext tag conf d1 -elide [lindex $diffelide 1]
5433}
5434
5435proc prevfile {} {
5436 global difffilestart ctext
5437 set prev [lindex $difffilestart 0]
5438 set here [$ctext index @0,0]
5439 foreach loc $difffilestart {
5440 if {[$ctext compare $loc >= $here]} {
5441 $ctext yview $prev
5442 return
5443 }
5444 set prev $loc
5445 }
5446 $ctext yview $prev
5447}
5448
5449proc nextfile {} {
5450 global difffilestart ctext
5451 set here [$ctext index @0,0]
5452 foreach loc $difffilestart {
5453 if {[$ctext compare $loc > $here]} {
5454 $ctext yview $loc
5455 return
5456 }
5457 }
5458}
5459
5460proc clear_ctext {{first 1.0}} {
5461 global ctext smarktop smarkbot
5462 global pendinglinks
5463
5464 set l [lindex [split $first .] 0]
5465 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5466 set smarktop $l
5467 }
5468 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5469 set smarkbot $l
5470 }
5471 $ctext delete $first end
5472 if {$first eq "1.0"} {
5473 catch {unset pendinglinks}
5474 }
5475}
5476
5477proc settabs {{firstab {}}} {
5478 global firsttabstop tabstop ctext have_tk85
5479
5480 if {$firstab ne {} && $have_tk85} {
5481 set firsttabstop $firstab
5482 }
5483 set w [font measure textfont "0"]
5484 if {$firsttabstop != 0} {
5485 $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5486 [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5487 } elseif {$have_tk85 || $tabstop != 8} {
5488 $ctext conf -tabs [expr {$tabstop * $w}]
5489 } else {
5490 $ctext conf -tabs {}
5491 }
5492}
5493
5494proc incrsearch {name ix op} {
5495 global ctext searchstring searchdirn
5496
5497 $ctext tag remove found 1.0 end
5498 if {[catch {$ctext index anchor}]} {
5499 # no anchor set, use start of selection, or of visible area
5500 set sel [$ctext tag ranges sel]
5501 if {$sel ne {}} {
5502 $ctext mark set anchor [lindex $sel 0]
5503 } elseif {$searchdirn eq "-forwards"} {
5504 $ctext mark set anchor @0,0
5505 } else {
5506 $ctext mark set anchor @0,[winfo height $ctext]
5507 }
5508 }
5509 if {$searchstring ne {}} {
5510 set here [$ctext search $searchdirn -- $searchstring anchor]
5511 if {$here ne {}} {
5512 $ctext see $here
5513 }
5514 searchmarkvisible 1
5515 }
5516}
5517
5518proc dosearch {} {
5519 global sstring ctext searchstring searchdirn
5520
5521 focus $sstring
5522 $sstring icursor end
5523 set searchdirn -forwards
5524 if {$searchstring ne {}} {
5525 set sel [$ctext tag ranges sel]
5526 if {$sel ne {}} {
5527 set start "[lindex $sel 0] + 1c"
5528 } elseif {[catch {set start [$ctext index anchor]}]} {
5529 set start "@0,0"
5530 }
5531 set match [$ctext search -count mlen -- $searchstring $start]
5532 $ctext tag remove sel 1.0 end
5533 if {$match eq {}} {
5534 bell
5535 return
5536 }
5537 $ctext see $match
5538 set mend "$match + $mlen c"
5539 $ctext tag add sel $match $mend
5540 $ctext mark unset anchor
5541 }
5542}
5543
5544proc dosearchback {} {
5545 global sstring ctext searchstring searchdirn
5546
5547 focus $sstring
5548 $sstring icursor end
5549 set searchdirn -backwards
5550 if {$searchstring ne {}} {
5551 set sel [$ctext tag ranges sel]
5552 if {$sel ne {}} {
5553 set start [lindex $sel 0]
5554 } elseif {[catch {set start [$ctext index anchor]}]} {
5555 set start @0,[winfo height $ctext]
5556 }
5557 set match [$ctext search -backwards -count ml -- $searchstring $start]
5558 $ctext tag remove sel 1.0 end
5559 if {$match eq {}} {
5560 bell
5561 return
5562 }
5563 $ctext see $match
5564 set mend "$match + $ml c"
5565 $ctext tag add sel $match $mend
5566 $ctext mark unset anchor
5567 }
5568}
5569
5570proc searchmark {first last} {
5571 global ctext searchstring
5572
5573 set mend $first.0
5574 while {1} {
5575 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5576 if {$match eq {}} break
5577 set mend "$match + $mlen c"
5578 $ctext tag add found $match $mend
5579 }
5580}
5581
5582proc searchmarkvisible {doall} {
5583 global ctext smarktop smarkbot
5584
5585 set topline [lindex [split [$ctext index @0,0] .] 0]
5586 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5587 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5588 # no overlap with previous
5589 searchmark $topline $botline
5590 set smarktop $topline
5591 set smarkbot $botline
5592 } else {
5593 if {$topline < $smarktop} {
5594 searchmark $topline [expr {$smarktop-1}]
5595 set smarktop $topline
5596 }
5597 if {$botline > $smarkbot} {
5598 searchmark [expr {$smarkbot+1}] $botline
5599 set smarkbot $botline
5600 }
5601 }
5602}
5603
5604proc scrolltext {f0 f1} {
5605 global searchstring
5606
5607 .bleft.sb set $f0 $f1
5608 if {$searchstring ne {}} {
5609 searchmarkvisible 0
5610 }
5611}
5612
5613proc setcoords {} {
5614 global linespc charspc canvx0 canvy0
5615 global xspc1 xspc2 lthickness
5616
5617 set linespc [font metrics mainfont -linespace]
5618 set charspc [font measure mainfont "m"]
5619 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5620 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5621 set lthickness [expr {int($linespc / 9) + 1}]
5622 set xspc1(0) $linespc
5623 set xspc2 $linespc
5624}
5625
5626proc redisplay {} {
5627 global canv
5628 global selectedline
5629
5630 set ymax [lindex [$canv cget -scrollregion] 3]
5631 if {$ymax eq {} || $ymax == 0} return
5632 set span [$canv yview]
5633 clear_display
5634 setcanvscroll
5635 allcanvs yview moveto [lindex $span 0]
5636 drawvisible
5637 if {[info exists selectedline]} {
5638 selectline $selectedline 0
5639 allcanvs yview moveto [lindex $span 0]
5640 }
5641}
5642
5643proc parsefont {f n} {
5644 global fontattr
5645
5646 set fontattr($f,family) [lindex $n 0]
5647 set s [lindex $n 1]
5648 if {$s eq {} || $s == 0} {
5649 set s 10
5650 } elseif {$s < 0} {
5651 set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5652 }
5653 set fontattr($f,size) $s
5654 set fontattr($f,weight) normal
5655 set fontattr($f,slant) roman
5656 foreach style [lrange $n 2 end] {
5657 switch -- $style {
5658 "normal" -
5659 "bold" {set fontattr($f,weight) $style}
5660 "roman" -
5661 "italic" {set fontattr($f,slant) $style}
5662 }
5663 }
5664}
5665
5666proc fontflags {f {isbold 0}} {
5667 global fontattr
5668
5669 return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5670 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5671 -slant $fontattr($f,slant)]
5672}
5673
5674proc fontname {f} {
5675 global fontattr
5676
5677 set n [list $fontattr($f,family) $fontattr($f,size)]
5678 if {$fontattr($f,weight) eq "bold"} {
5679 lappend n "bold"
5680 }
5681 if {$fontattr($f,slant) eq "italic"} {
5682 lappend n "italic"
5683 }
5684 return $n
5685}
5686
5687proc incrfont {inc} {
5688 global mainfont textfont ctext canv phase cflist showrefstop
5689 global stopped entries fontattr
5690
5691 unmarkmatches
5692 set s $fontattr(mainfont,size)
5693 incr s $inc
5694 if {$s < 1} {
5695 set s 1
5696 }
5697 set fontattr(mainfont,size) $s
5698 font config mainfont -size $s
5699 font config mainfontbold -size $s
5700 set mainfont [fontname mainfont]
5701 set s $fontattr(textfont,size)
5702 incr s $inc
5703 if {$s < 1} {
5704 set s 1
5705 }
5706 set fontattr(textfont,size) $s
5707 font config textfont -size $s
5708 font config textfontbold -size $s
5709 set textfont [fontname textfont]
5710 setcoords
5711 settabs
5712 redisplay
5713}
5714
5715proc clearsha1 {} {
5716 global sha1entry sha1string
5717 if {[string length $sha1string] == 40} {
5718 $sha1entry delete 0 end
5719 }
5720}
5721
5722proc sha1change {n1 n2 op} {
5723 global sha1string currentid sha1but
5724 if {$sha1string == {}
5725 || ([info exists currentid] && $sha1string == $currentid)} {
5726 set state disabled
5727 } else {
5728 set state normal
5729 }
5730 if {[$sha1but cget -state] == $state} return
5731 if {$state == "normal"} {
5732 $sha1but conf -state normal -relief raised -text "[mc "Goto:"] "
5733 } else {
5734 $sha1but conf -state disabled -relief flat -text "[mc "SHA1 ID:"] "
5735 }
5736}
5737
5738proc gotocommit {} {
5739 global sha1string currentid commitrow tagids headids
5740 global displayorder numcommits curview
5741
5742 if {$sha1string == {}
5743 || ([info exists currentid] && $sha1string == $currentid)} return
5744 if {[info exists tagids($sha1string)]} {
5745 set id $tagids($sha1string)
5746 } elseif {[info exists headids($sha1string)]} {
5747 set id $headids($sha1string)
5748 } else {
5749 set id [string tolower $sha1string]
5750 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5751 set matches {}
5752 foreach i $displayorder {
5753 if {[string match $id* $i]} {
5754 lappend matches $i
5755 }
5756 }
5757 if {$matches ne {}} {
5758 if {[llength $matches] > 1} {
5759 error_popup [mc "Short SHA1 id %s is ambiguous" $id]
5760 return
5761 }
5762 set id [lindex $matches 0]
5763 }
5764 }
5765 }
5766 if {[info exists commitrow($curview,$id)]} {
5767 selectline $commitrow($curview,$id) 1
5768 return
5769 }
5770 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5771 set msg [mc "SHA1 id %s is not known" $sha1string]
5772 } else {
5773 set msg [mc "Tag/Head %s is not known" $sha1string]
5774 }
5775 error_popup $msg
5776}
5777
5778proc lineenter {x y id} {
5779 global hoverx hovery hoverid hovertimer
5780 global commitinfo canv
5781
5782 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5783 set hoverx $x
5784 set hovery $y
5785 set hoverid $id
5786 if {[info exists hovertimer]} {
5787 after cancel $hovertimer
5788 }
5789 set hovertimer [after 500 linehover]
5790 $canv delete hover
5791}
5792
5793proc linemotion {x y id} {
5794 global hoverx hovery hoverid hovertimer
5795
5796 if {[info exists hoverid] && $id == $hoverid} {
5797 set hoverx $x
5798 set hovery $y
5799 if {[info exists hovertimer]} {
5800 after cancel $hovertimer
5801 }
5802 set hovertimer [after 500 linehover]
5803 }
5804}
5805
5806proc lineleave {id} {
5807 global hoverid hovertimer canv
5808
5809 if {[info exists hoverid] && $id == $hoverid} {
5810 $canv delete hover
5811 if {[info exists hovertimer]} {
5812 after cancel $hovertimer
5813 unset hovertimer
5814 }
5815 unset hoverid
5816 }
5817}
5818
5819proc linehover {} {
5820 global hoverx hovery hoverid hovertimer
5821 global canv linespc lthickness
5822 global commitinfo
5823
5824 set text [lindex $commitinfo($hoverid) 0]
5825 set ymax [lindex [$canv cget -scrollregion] 3]
5826 if {$ymax == {}} return
5827 set yfrac [lindex [$canv yview] 0]
5828 set x [expr {$hoverx + 2 * $linespc}]
5829 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5830 set x0 [expr {$x - 2 * $lthickness}]
5831 set y0 [expr {$y - 2 * $lthickness}]
5832 set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5833 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5834 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5835 -fill \#ffff80 -outline black -width 1 -tags hover]
5836 $canv raise $t
5837 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5838 -font mainfont]
5839 $canv raise $t
5840}
5841
5842proc clickisonarrow {id y} {
5843 global lthickness
5844
5845 set ranges [rowranges $id]
5846 set thresh [expr {2 * $lthickness + 6}]
5847 set n [expr {[llength $ranges] - 1}]
5848 for {set i 1} {$i < $n} {incr i} {
5849 set row [lindex $ranges $i]
5850 if {abs([yc $row] - $y) < $thresh} {
5851 return $i
5852 }
5853 }
5854 return {}
5855}
5856
5857proc arrowjump {id n y} {
5858 global canv
5859
5860 # 1 <-> 2, 3 <-> 4, etc...
5861 set n [expr {(($n - 1) ^ 1) + 1}]
5862 set row [lindex [rowranges $id] $n]
5863 set yt [yc $row]
5864 set ymax [lindex [$canv cget -scrollregion] 3]
5865 if {$ymax eq {} || $ymax <= 0} return
5866 set view [$canv yview]
5867 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5868 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5869 if {$yfrac < 0} {
5870 set yfrac 0
5871 }
5872 allcanvs yview moveto $yfrac
5873}
5874
5875proc lineclick {x y id isnew} {
5876 global ctext commitinfo children canv thickerline curview commitrow
5877
5878 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5879 unmarkmatches
5880 unselectline
5881 normalline
5882 $canv delete hover
5883 # draw this line thicker than normal
5884 set thickerline $id
5885 drawlines $id
5886 if {$isnew} {
5887 set ymax [lindex [$canv cget -scrollregion] 3]
5888 if {$ymax eq {}} return
5889 set yfrac [lindex [$canv yview] 0]
5890 set y [expr {$y + $yfrac * $ymax}]
5891 }
5892 set dirn [clickisonarrow $id $y]
5893 if {$dirn ne {}} {
5894 arrowjump $id $dirn $y
5895 return
5896 }
5897
5898 if {$isnew} {
5899 addtohistory [list lineclick $x $y $id 0]
5900 }
5901 # fill the details pane with info about this line
5902 $ctext conf -state normal
5903 clear_ctext
5904 settabs 0
5905 $ctext insert end "[mc "Parent"]:\t"
5906 $ctext insert end $id link0
5907 setlink $id link0
5908 set info $commitinfo($id)
5909 $ctext insert end "\n\t[lindex $info 0]\n"
5910 $ctext insert end "\t[mc "Author"]:\t[lindex $info 1]\n"
5911 set date [formatdate [lindex $info 2]]
5912 $ctext insert end "\t[mc "Date"]:\t$date\n"
5913 set kids $children($curview,$id)
5914 if {$kids ne {}} {
5915 $ctext insert end "\n[mc "Children"]:"
5916 set i 0
5917 foreach child $kids {
5918 incr i
5919 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5920 set info $commitinfo($child)
5921 $ctext insert end "\n\t"
5922 $ctext insert end $child link$i
5923 setlink $child link$i
5924 $ctext insert end "\n\t[lindex $info 0]"
5925 $ctext insert end "\n\t[mc "Author"]:\t[lindex $info 1]"
5926 set date [formatdate [lindex $info 2]]
5927 $ctext insert end "\n\t[mc "Date"]:\t$date\n"
5928 }
5929 }
5930 $ctext conf -state disabled
5931 init_flist {}
5932}
5933
5934proc normalline {} {
5935 global thickerline
5936 if {[info exists thickerline]} {
5937 set id $thickerline
5938 unset thickerline
5939 drawlines $id
5940 }
5941}
5942
5943proc selbyid {id} {
5944 global commitrow curview
5945 if {[info exists commitrow($curview,$id)]} {
5946 selectline $commitrow($curview,$id) 1
5947 }
5948}
5949
5950proc mstime {} {
5951 global startmstime
5952 if {![info exists startmstime]} {
5953 set startmstime [clock clicks -milliseconds]
5954 }
5955 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5956}
5957
5958proc rowmenu {x y id} {
5959 global rowctxmenu commitrow selectedline rowmenuid curview
5960 global nullid nullid2 fakerowmenu mainhead
5961
5962 stopfinding
5963 set rowmenuid $id
5964 if {![info exists selectedline]
5965 || $commitrow($curview,$id) eq $selectedline} {
5966 set state disabled
5967 } else {
5968 set state normal
5969 }
5970 if {$id ne $nullid && $id ne $nullid2} {
5971 set menu $rowctxmenu
5972 $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
5973 } else {
5974 set menu $fakerowmenu
5975 }
5976 $menu entryconfigure [mc "Diff this -> selected"] -state $state
5977 $menu entryconfigure [mc "Diff selected -> this"] -state $state
5978 $menu entryconfigure [mc "Make patch"] -state $state
5979 tk_popup $menu $x $y
5980}
5981
5982proc diffvssel {dirn} {
5983 global rowmenuid selectedline displayorder
5984
5985 if {![info exists selectedline]} return
5986 if {$dirn} {
5987 set oldid [lindex $displayorder $selectedline]
5988 set newid $rowmenuid
5989 } else {
5990 set oldid $rowmenuid
5991 set newid [lindex $displayorder $selectedline]
5992 }
5993 addtohistory [list doseldiff $oldid $newid]
5994 doseldiff $oldid $newid
5995}
5996
5997proc doseldiff {oldid newid} {
5998 global ctext
5999 global commitinfo
6000
6001 $ctext conf -state normal
6002 clear_ctext
6003 init_flist [mc "Top"]
6004 $ctext insert end "[mc "From"] "
6005 $ctext insert end $oldid link0
6006 setlink $oldid link0
6007 $ctext insert end "\n "
6008 $ctext insert end [lindex $commitinfo($oldid) 0]
6009 $ctext insert end "\n\n[mc "To"] "
6010 $ctext insert end $newid link1
6011 setlink $newid link1
6012 $ctext insert end "\n "
6013 $ctext insert end [lindex $commitinfo($newid) 0]
6014 $ctext insert end "\n"
6015 $ctext conf -state disabled
6016 $ctext tag remove found 1.0 end
6017 startdiff [list $oldid $newid]
6018}
6019
6020proc mkpatch {} {
6021 global rowmenuid currentid commitinfo patchtop patchnum
6022
6023 if {![info exists currentid]} return
6024 set oldid $currentid
6025 set oldhead [lindex $commitinfo($oldid) 0]
6026 set newid $rowmenuid
6027 set newhead [lindex $commitinfo($newid) 0]
6028 set top .patch
6029 set patchtop $top
6030 catch {destroy $top}
6031 toplevel $top
6032 label $top.title -text [mc "Generate patch"]
6033 grid $top.title - -pady 10
6034 label $top.from -text [mc "From:"]
6035 entry $top.fromsha1 -width 40 -relief flat
6036 $top.fromsha1 insert 0 $oldid
6037 $top.fromsha1 conf -state readonly
6038 grid $top.from $top.fromsha1 -sticky w
6039 entry $top.fromhead -width 60 -relief flat
6040 $top.fromhead insert 0 $oldhead
6041 $top.fromhead conf -state readonly
6042 grid x $top.fromhead -sticky w
6043 label $top.to -text [mc "To:"]
6044 entry $top.tosha1 -width 40 -relief flat
6045 $top.tosha1 insert 0 $newid
6046 $top.tosha1 conf -state readonly
6047 grid $top.to $top.tosha1 -sticky w
6048 entry $top.tohead -width 60 -relief flat
6049 $top.tohead insert 0 $newhead
6050 $top.tohead conf -state readonly
6051 grid x $top.tohead -sticky w
6052 button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6053 grid $top.rev x -pady 10
6054 label $top.flab -text [mc "Output file:"]
6055 entry $top.fname -width 60
6056 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6057 incr patchnum
6058 grid $top.flab $top.fname -sticky w
6059 frame $top.buts
6060 button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6061 button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6062 grid $top.buts.gen $top.buts.can
6063 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6064 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6065 grid $top.buts - -pady 10 -sticky ew
6066 focus $top.fname
6067}
6068
6069proc mkpatchrev {} {
6070 global patchtop
6071
6072 set oldid [$patchtop.fromsha1 get]
6073 set oldhead [$patchtop.fromhead get]
6074 set newid [$patchtop.tosha1 get]
6075 set newhead [$patchtop.tohead get]
6076 foreach e [list fromsha1 fromhead tosha1 tohead] \
6077 v [list $newid $newhead $oldid $oldhead] {
6078 $patchtop.$e conf -state normal
6079 $patchtop.$e delete 0 end
6080 $patchtop.$e insert 0 $v
6081 $patchtop.$e conf -state readonly
6082 }
6083}
6084
6085proc mkpatchgo {} {
6086 global patchtop nullid nullid2
6087
6088 set oldid [$patchtop.fromsha1 get]
6089 set newid [$patchtop.tosha1 get]
6090 set fname [$patchtop.fname get]
6091 set cmd [diffcmd [list $oldid $newid] -p]
6092 # trim off the initial "|"
6093 set cmd [lrange $cmd 1 end]
6094 lappend cmd >$fname &
6095 if {[catch {eval exec $cmd} err]} {
6096 error_popup "[mc "Error creating patch:"] $err"
6097 }
6098 catch {destroy $patchtop}
6099 unset patchtop
6100}
6101
6102proc mkpatchcan {} {
6103 global patchtop
6104
6105 catch {destroy $patchtop}
6106 unset patchtop
6107}
6108
6109proc mktag {} {
6110 global rowmenuid mktagtop commitinfo
6111
6112 set top .maketag
6113 set mktagtop $top
6114 catch {destroy $top}
6115 toplevel $top
6116 label $top.title -text [mc "Create tag"]
6117 grid $top.title - -pady 10
6118 label $top.id -text [mc "ID:"]
6119 entry $top.sha1 -width 40 -relief flat
6120 $top.sha1 insert 0 $rowmenuid
6121 $top.sha1 conf -state readonly
6122 grid $top.id $top.sha1 -sticky w
6123 entry $top.head -width 60 -relief flat
6124 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6125 $top.head conf -state readonly
6126 grid x $top.head -sticky w
6127 label $top.tlab -text [mc "Tag name:"]
6128 entry $top.tag -width 60
6129 grid $top.tlab $top.tag -sticky w
6130 frame $top.buts
6131 button $top.buts.gen -text [mc "Create"] -command mktaggo
6132 button $top.buts.can -text [mc "Cancel"] -command mktagcan
6133 grid $top.buts.gen $top.buts.can
6134 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6135 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6136 grid $top.buts - -pady 10 -sticky ew
6137 focus $top.tag
6138}
6139
6140proc domktag {} {
6141 global mktagtop env tagids idtags
6142
6143 set id [$mktagtop.sha1 get]
6144 set tag [$mktagtop.tag get]
6145 if {$tag == {}} {
6146 error_popup [mc "No tag name specified"]
6147 return
6148 }
6149 if {[info exists tagids($tag)]} {
6150 error_popup [mc "Tag \"%s\" already exists" $tag]
6151 return
6152 }
6153 if {[catch {
6154 exec git tag $tag $id
6155 } err]} {
6156 error_popup "[mc "Error creating tag:"] $err"
6157 return
6158 }
6159
6160 set tagids($tag) $id
6161 lappend idtags($id) $tag
6162 redrawtags $id
6163 addedtag $id
6164 dispneartags 0
6165 run refill_reflist
6166}
6167
6168proc redrawtags {id} {
6169 global canv linehtag commitrow idpos selectedline curview
6170 global canvxmax iddrawn
6171
6172 if {![info exists commitrow($curview,$id)]} return
6173 if {![info exists iddrawn($id)]} return
6174 drawcommits $commitrow($curview,$id)
6175 $canv delete tag.$id
6176 set xt [eval drawtags $id $idpos($id)]
6177 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6178 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6179 set xr [expr {$xt + [font measure mainfont $text]}]
6180 if {$xr > $canvxmax} {
6181 set canvxmax $xr
6182 setcanvscroll
6183 }
6184 if {[info exists selectedline]
6185 && $selectedline == $commitrow($curview,$id)} {
6186 selectline $selectedline 0
6187 }
6188}
6189
6190proc mktagcan {} {
6191 global mktagtop
6192
6193 catch {destroy $mktagtop}
6194 unset mktagtop
6195}
6196
6197proc mktaggo {} {
6198 domktag
6199 mktagcan
6200}
6201
6202proc writecommit {} {
6203 global rowmenuid wrcomtop commitinfo wrcomcmd
6204
6205 set top .writecommit
6206 set wrcomtop $top
6207 catch {destroy $top}
6208 toplevel $top
6209 label $top.title -text [mc "Write commit to file"]
6210 grid $top.title - -pady 10
6211 label $top.id -text [mc "ID:"]
6212 entry $top.sha1 -width 40 -relief flat
6213 $top.sha1 insert 0 $rowmenuid
6214 $top.sha1 conf -state readonly
6215 grid $top.id $top.sha1 -sticky w
6216 entry $top.head -width 60 -relief flat
6217 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6218 $top.head conf -state readonly
6219 grid x $top.head -sticky w
6220 label $top.clab -text [mc "Command:"]
6221 entry $top.cmd -width 60 -textvariable wrcomcmd
6222 grid $top.clab $top.cmd -sticky w -pady 10
6223 label $top.flab -text [mc "Output file:"]
6224 entry $top.fname -width 60
6225 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6226 grid $top.flab $top.fname -sticky w
6227 frame $top.buts
6228 button $top.buts.gen -text [mc "Write"] -command wrcomgo
6229 button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6230 grid $top.buts.gen $top.buts.can
6231 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6232 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6233 grid $top.buts - -pady 10 -sticky ew
6234 focus $top.fname
6235}
6236
6237proc wrcomgo {} {
6238 global wrcomtop
6239
6240 set id [$wrcomtop.sha1 get]
6241 set cmd "echo $id | [$wrcomtop.cmd get]"
6242 set fname [$wrcomtop.fname get]
6243 if {[catch {exec sh -c $cmd >$fname &} err]} {
6244 error_popup "[mc "Error writing commit:"] $err"
6245 }
6246 catch {destroy $wrcomtop}
6247 unset wrcomtop
6248}
6249
6250proc wrcomcan {} {
6251 global wrcomtop
6252
6253 catch {destroy $wrcomtop}
6254 unset wrcomtop
6255}
6256
6257proc mkbranch {} {
6258 global rowmenuid mkbrtop
6259
6260 set top .makebranch
6261 catch {destroy $top}
6262 toplevel $top
6263 label $top.title -text [mc "Create new branch"]
6264 grid $top.title - -pady 10
6265 label $top.id -text [mc "ID:"]
6266 entry $top.sha1 -width 40 -relief flat
6267 $top.sha1 insert 0 $rowmenuid
6268 $top.sha1 conf -state readonly
6269 grid $top.id $top.sha1 -sticky w
6270 label $top.nlab -text [mc "Name:"]
6271 entry $top.name -width 40
6272 grid $top.nlab $top.name -sticky w
6273 frame $top.buts
6274 button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6275 button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6276 grid $top.buts.go $top.buts.can
6277 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6278 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6279 grid $top.buts - -pady 10 -sticky ew
6280 focus $top.name
6281}
6282
6283proc mkbrgo {top} {
6284 global headids idheads
6285
6286 set name [$top.name get]
6287 set id [$top.sha1 get]
6288 if {$name eq {}} {
6289 error_popup [mc "Please specify a name for the new branch"]
6290 return
6291 }
6292 catch {destroy $top}
6293 nowbusy newbranch
6294 update
6295 if {[catch {
6296 exec git branch $name $id
6297 } err]} {
6298 notbusy newbranch
6299 error_popup $err
6300 } else {
6301 set headids($name) $id
6302 lappend idheads($id) $name
6303 addedhead $id $name
6304 notbusy newbranch
6305 redrawtags $id
6306 dispneartags 0
6307 run refill_reflist
6308 }
6309}
6310
6311proc cherrypick {} {
6312 global rowmenuid curview commitrow
6313 global mainhead
6314
6315 set oldhead [exec git rev-parse HEAD]
6316 set dheads [descheads $rowmenuid]
6317 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6318 set ok [confirm_popup [mc "Commit %s is already\
6319 included in branch %s -- really re-apply it?" \
6320 [string range $rowmenuid 0 7] $mainhead]]
6321 if {!$ok} return
6322 }
6323 nowbusy cherrypick [mc "Cherry-picking"]
6324 update
6325 # Unfortunately git-cherry-pick writes stuff to stderr even when
6326 # no error occurs, and exec takes that as an indication of error...
6327 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6328 notbusy cherrypick
6329 error_popup $err
6330 return
6331 }
6332 set newhead [exec git rev-parse HEAD]
6333 if {$newhead eq $oldhead} {
6334 notbusy cherrypick
6335 error_popup [mc "No changes committed"]
6336 return
6337 }
6338 addnewchild $newhead $oldhead
6339 if {[info exists commitrow($curview,$oldhead)]} {
6340 insertrow $commitrow($curview,$oldhead) $newhead
6341 if {$mainhead ne {}} {
6342 movehead $newhead $mainhead
6343 movedhead $newhead $mainhead
6344 }
6345 redrawtags $oldhead
6346 redrawtags $newhead
6347 }
6348 notbusy cherrypick
6349}
6350
6351proc resethead {} {
6352 global mainheadid mainhead rowmenuid confirm_ok resettype
6353
6354 set confirm_ok 0
6355 set w ".confirmreset"
6356 toplevel $w
6357 wm transient $w .
6358 wm title $w [mc "Confirm reset"]
6359 message $w.m -text \
6360 [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
6361 -justify center -aspect 1000
6362 pack $w.m -side top -fill x -padx 20 -pady 20
6363 frame $w.f -relief sunken -border 2
6364 message $w.f.rt -text [mc "Reset type:"] -aspect 1000
6365 grid $w.f.rt -sticky w
6366 set resettype mixed
6367 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6368 -text [mc "Soft: Leave working tree and index untouched"]
6369 grid $w.f.soft -sticky w
6370 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6371 -text [mc "Mixed: Leave working tree untouched, reset index"]
6372 grid $w.f.mixed -sticky w
6373 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6374 -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
6375 grid $w.f.hard -sticky w
6376 pack $w.f -side top -fill x
6377 button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
6378 pack $w.ok -side left -fill x -padx 20 -pady 20
6379 button $w.cancel -text [mc Cancel] -command "destroy $w"
6380 pack $w.cancel -side right -fill x -padx 20 -pady 20
6381 bind $w <Visibility> "grab $w; focus $w"
6382 tkwait window $w
6383 if {!$confirm_ok} return
6384 if {[catch {set fd [open \
6385 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6386 error_popup $err
6387 } else {
6388 dohidelocalchanges
6389 filerun $fd [list readresetstat $fd]
6390 nowbusy reset [mc "Resetting"]
6391 }
6392}
6393
6394proc readresetstat {fd} {
6395 global mainhead mainheadid showlocalchanges rprogcoord
6396
6397 if {[gets $fd line] >= 0} {
6398 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6399 set rprogcoord [expr {1.0 * $m / $n}]
6400 adjustprogress
6401 }
6402 return 1
6403 }
6404 set rprogcoord 0
6405 adjustprogress
6406 notbusy reset
6407 if {[catch {close $fd} err]} {
6408 error_popup $err
6409 }
6410 set oldhead $mainheadid
6411 set newhead [exec git rev-parse HEAD]
6412 if {$newhead ne $oldhead} {
6413 movehead $newhead $mainhead
6414 movedhead $newhead $mainhead
6415 set mainheadid $newhead
6416 redrawtags $oldhead
6417 redrawtags $newhead
6418 }
6419 if {$showlocalchanges} {
6420 doshowlocalchanges
6421 }
6422 return 0
6423}
6424
6425# context menu for a head
6426proc headmenu {x y id head} {
6427 global headmenuid headmenuhead headctxmenu mainhead
6428
6429 stopfinding
6430 set headmenuid $id
6431 set headmenuhead $head
6432 set state normal
6433 if {$head eq $mainhead} {
6434 set state disabled
6435 }
6436 $headctxmenu entryconfigure 0 -state $state
6437 $headctxmenu entryconfigure 1 -state $state
6438 tk_popup $headctxmenu $x $y
6439}
6440
6441proc cobranch {} {
6442 global headmenuid headmenuhead mainhead headids
6443 global showlocalchanges mainheadid
6444
6445 # check the tree is clean first??
6446 set oldmainhead $mainhead
6447 nowbusy checkout [mc "Checking out"]
6448 update
6449 dohidelocalchanges
6450 if {[catch {
6451 exec git checkout -q $headmenuhead
6452 } err]} {
6453 notbusy checkout
6454 error_popup $err
6455 } else {
6456 notbusy checkout
6457 set mainhead $headmenuhead
6458 set mainheadid $headmenuid
6459 if {[info exists headids($oldmainhead)]} {
6460 redrawtags $headids($oldmainhead)
6461 }
6462 redrawtags $headmenuid
6463 }
6464 if {$showlocalchanges} {
6465 dodiffindex
6466 }
6467}
6468
6469proc rmbranch {} {
6470 global headmenuid headmenuhead mainhead
6471 global idheads
6472
6473 set head $headmenuhead
6474 set id $headmenuid
6475 # this check shouldn't be needed any more...
6476 if {$head eq $mainhead} {
6477 error_popup [mc "Cannot delete the currently checked-out branch"]
6478 return
6479 }
6480 set dheads [descheads $id]
6481 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6482 # the stuff on this branch isn't on any other branch
6483 if {![confirm_popup [mc "The commits on branch %s aren't on any other\
6484 branch.\nReally delete branch %s?" $head $head]]} return
6485 }
6486 nowbusy rmbranch
6487 update
6488 if {[catch {exec git branch -D $head} err]} {
6489 notbusy rmbranch
6490 error_popup $err
6491 return
6492 }
6493 removehead $id $head
6494 removedhead $id $head
6495 redrawtags $id
6496 notbusy rmbranch
6497 dispneartags 0
6498 run refill_reflist
6499}
6500
6501# Display a list of tags and heads
6502proc showrefs {} {
6503 global showrefstop bgcolor fgcolor selectbgcolor
6504 global bglist fglist reflistfilter reflist maincursor
6505
6506 set top .showrefs
6507 set showrefstop $top
6508 if {[winfo exists $top]} {
6509 raise $top
6510 refill_reflist
6511 return
6512 }
6513 toplevel $top
6514 wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
6515 text $top.list -background $bgcolor -foreground $fgcolor \
6516 -selectbackground $selectbgcolor -font mainfont \
6517 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6518 -width 30 -height 20 -cursor $maincursor \
6519 -spacing1 1 -spacing3 1 -state disabled
6520 $top.list tag configure highlight -background $selectbgcolor
6521 lappend bglist $top.list
6522 lappend fglist $top.list
6523 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6524 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6525 grid $top.list $top.ysb -sticky nsew
6526 grid $top.xsb x -sticky ew
6527 frame $top.f
6528 label $top.f.l -text "[mc "Filter"]: "
6529 entry $top.f.e -width 20 -textvariable reflistfilter
6530 set reflistfilter "*"
6531 trace add variable reflistfilter write reflistfilter_change
6532 pack $top.f.e -side right -fill x -expand 1
6533 pack $top.f.l -side left
6534 grid $top.f - -sticky ew -pady 2
6535 button $top.close -command [list destroy $top] -text [mc "Close"]
6536 grid $top.close -
6537 grid columnconfigure $top 0 -weight 1
6538 grid rowconfigure $top 0 -weight 1
6539 bind $top.list <1> {break}
6540 bind $top.list <B1-Motion> {break}
6541 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6542 set reflist {}
6543 refill_reflist
6544}
6545
6546proc sel_reflist {w x y} {
6547 global showrefstop reflist headids tagids otherrefids
6548
6549 if {![winfo exists $showrefstop]} return
6550 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6551 set ref [lindex $reflist [expr {$l-1}]]
6552 set n [lindex $ref 0]
6553 switch -- [lindex $ref 1] {
6554 "H" {selbyid $headids($n)}
6555 "T" {selbyid $tagids($n)}
6556 "o" {selbyid $otherrefids($n)}
6557 }
6558 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6559}
6560
6561proc unsel_reflist {} {
6562 global showrefstop
6563
6564 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6565 $showrefstop.list tag remove highlight 0.0 end
6566}
6567
6568proc reflistfilter_change {n1 n2 op} {
6569 global reflistfilter
6570
6571 after cancel refill_reflist
6572 after 200 refill_reflist
6573}
6574
6575proc refill_reflist {} {
6576 global reflist reflistfilter showrefstop headids tagids otherrefids
6577 global commitrow curview commitinterest
6578
6579 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6580 set refs {}
6581 foreach n [array names headids] {
6582 if {[string match $reflistfilter $n]} {
6583 if {[info exists commitrow($curview,$headids($n))]} {
6584 lappend refs [list $n H]
6585 } else {
6586 set commitinterest($headids($n)) {run refill_reflist}
6587 }
6588 }
6589 }
6590 foreach n [array names tagids] {
6591 if {[string match $reflistfilter $n]} {
6592 if {[info exists commitrow($curview,$tagids($n))]} {
6593 lappend refs [list $n T]
6594 } else {
6595 set commitinterest($tagids($n)) {run refill_reflist}
6596 }
6597 }
6598 }
6599 foreach n [array names otherrefids] {
6600 if {[string match $reflistfilter $n]} {
6601 if {[info exists commitrow($curview,$otherrefids($n))]} {
6602 lappend refs [list $n o]
6603 } else {
6604 set commitinterest($otherrefids($n)) {run refill_reflist}
6605 }
6606 }
6607 }
6608 set refs [lsort -index 0 $refs]
6609 if {$refs eq $reflist} return
6610
6611 # Update the contents of $showrefstop.list according to the
6612 # differences between $reflist (old) and $refs (new)
6613 $showrefstop.list conf -state normal
6614 $showrefstop.list insert end "\n"
6615 set i 0
6616 set j 0
6617 while {$i < [llength $reflist] || $j < [llength $refs]} {
6618 if {$i < [llength $reflist]} {
6619 if {$j < [llength $refs]} {
6620 set cmp [string compare [lindex $reflist $i 0] \
6621 [lindex $refs $j 0]]
6622 if {$cmp == 0} {
6623 set cmp [string compare [lindex $reflist $i 1] \
6624 [lindex $refs $j 1]]
6625 }
6626 } else {
6627 set cmp -1
6628 }
6629 } else {
6630 set cmp 1
6631 }
6632 switch -- $cmp {
6633 -1 {
6634 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6635 incr i
6636 }
6637 0 {
6638 incr i
6639 incr j
6640 }
6641 1 {
6642 set l [expr {$j + 1}]
6643 $showrefstop.list image create $l.0 -align baseline \
6644 -image reficon-[lindex $refs $j 1] -padx 2
6645 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6646 incr j
6647 }
6648 }
6649 }
6650 set reflist $refs
6651 # delete last newline
6652 $showrefstop.list delete end-2c end-1c
6653 $showrefstop.list conf -state disabled
6654}
6655
6656# Stuff for finding nearby tags
6657proc getallcommits {} {
6658 global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6659 global idheads idtags idotherrefs allparents tagobjid
6660
6661 if {![info exists allcommits]} {
6662 set nextarc 0
6663 set allcommits 0
6664 set seeds {}
6665 set allcwait 0
6666 set cachedarcs 0
6667 set allccache [file join [gitdir] "gitk.cache"]
6668 if {![catch {
6669 set f [open $allccache r]
6670 set allcwait 1
6671 getcache $f
6672 }]} return
6673 }
6674
6675 if {$allcwait} {
6676 return
6677 }
6678 set cmd [list | git rev-list --parents]
6679 set allcupdate [expr {$seeds ne {}}]
6680 if {!$allcupdate} {
6681 set ids "--all"
6682 } else {
6683 set refs [concat [array names idheads] [array names idtags] \
6684 [array names idotherrefs]]
6685 set ids {}
6686 set tagobjs {}
6687 foreach name [array names tagobjid] {
6688 lappend tagobjs $tagobjid($name)
6689 }
6690 foreach id [lsort -unique $refs] {
6691 if {![info exists allparents($id)] &&
6692 [lsearch -exact $tagobjs $id] < 0} {
6693 lappend ids $id
6694 }
6695 }
6696 if {$ids ne {}} {
6697 foreach id $seeds {
6698 lappend ids "^$id"
6699 }
6700 }
6701 }
6702 if {$ids ne {}} {
6703 set fd [open [concat $cmd $ids] r]
6704 fconfigure $fd -blocking 0
6705 incr allcommits
6706 nowbusy allcommits
6707 filerun $fd [list getallclines $fd]
6708 } else {
6709 dispneartags 0
6710 }
6711}
6712
6713# Since most commits have 1 parent and 1 child, we group strings of
6714# such commits into "arcs" joining branch/merge points (BMPs), which
6715# are commits that either don't have 1 parent or don't have 1 child.
6716#
6717# arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6718# arcout(id) - outgoing arcs for BMP
6719# arcids(a) - list of IDs on arc including end but not start
6720# arcstart(a) - BMP ID at start of arc
6721# arcend(a) - BMP ID at end of arc
6722# growing(a) - arc a is still growing
6723# arctags(a) - IDs out of arcids (excluding end) that have tags
6724# archeads(a) - IDs out of arcids (excluding end) that have heads
6725# The start of an arc is at the descendent end, so "incoming" means
6726# coming from descendents, and "outgoing" means going towards ancestors.
6727
6728proc getallclines {fd} {
6729 global allparents allchildren idtags idheads nextarc
6730 global arcnos arcids arctags arcout arcend arcstart archeads growing
6731 global seeds allcommits cachedarcs allcupdate
6732
6733 set nid 0
6734 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6735 set id [lindex $line 0]
6736 if {[info exists allparents($id)]} {
6737 # seen it already
6738 continue
6739 }
6740 set cachedarcs 0
6741 set olds [lrange $line 1 end]
6742 set allparents($id) $olds
6743 if {![info exists allchildren($id)]} {
6744 set allchildren($id) {}
6745 set arcnos($id) {}
6746 lappend seeds $id
6747 } else {
6748 set a $arcnos($id)
6749 if {[llength $olds] == 1 && [llength $a] == 1} {
6750 lappend arcids($a) $id
6751 if {[info exists idtags($id)]} {
6752 lappend arctags($a) $id
6753 }
6754 if {[info exists idheads($id)]} {
6755 lappend archeads($a) $id
6756 }
6757 if {[info exists allparents($olds)]} {
6758 # seen parent already
6759 if {![info exists arcout($olds)]} {
6760 splitarc $olds
6761 }
6762 lappend arcids($a) $olds
6763 set arcend($a) $olds
6764 unset growing($a)
6765 }
6766 lappend allchildren($olds) $id
6767 lappend arcnos($olds) $a
6768 continue
6769 }
6770 }
6771 foreach a $arcnos($id) {
6772 lappend arcids($a) $id
6773 set arcend($a) $id
6774 unset growing($a)
6775 }
6776
6777 set ao {}
6778 foreach p $olds {
6779 lappend allchildren($p) $id
6780 set a [incr nextarc]
6781 set arcstart($a) $id
6782 set archeads($a) {}
6783 set arctags($a) {}
6784 set archeads($a) {}
6785 set arcids($a) {}
6786 lappend ao $a
6787 set growing($a) 1
6788 if {[info exists allparents($p)]} {
6789 # seen it already, may need to make a new branch
6790 if {![info exists arcout($p)]} {
6791 splitarc $p
6792 }
6793 lappend arcids($a) $p
6794 set arcend($a) $p
6795 unset growing($a)
6796 }
6797 lappend arcnos($p) $a
6798 }
6799 set arcout($id) $ao
6800 }
6801 if {$nid > 0} {
6802 global cached_dheads cached_dtags cached_atags
6803 catch {unset cached_dheads}
6804 catch {unset cached_dtags}
6805 catch {unset cached_atags}
6806 }
6807 if {![eof $fd]} {
6808 return [expr {$nid >= 1000? 2: 1}]
6809 }
6810 set cacheok 1
6811 if {[catch {
6812 fconfigure $fd -blocking 1
6813 close $fd
6814 } err]} {
6815 # got an error reading the list of commits
6816 # if we were updating, try rereading the whole thing again
6817 if {$allcupdate} {
6818 incr allcommits -1
6819 dropcache $err
6820 return
6821 }
6822 error_popup "[mc "Error reading commit topology information;\
6823 branch and preceding/following tag information\
6824 will be incomplete."]\n($err)"
6825 set cacheok 0
6826 }
6827 if {[incr allcommits -1] == 0} {
6828 notbusy allcommits
6829 if {$cacheok} {
6830 run savecache
6831 }
6832 }
6833 dispneartags 0
6834 return 0
6835}
6836
6837proc recalcarc {a} {
6838 global arctags archeads arcids idtags idheads
6839
6840 set at {}
6841 set ah {}
6842 foreach id [lrange $arcids($a) 0 end-1] {
6843 if {[info exists idtags($id)]} {
6844 lappend at $id
6845 }
6846 if {[info exists idheads($id)]} {
6847 lappend ah $id
6848 }
6849 }
6850 set arctags($a) $at
6851 set archeads($a) $ah
6852}
6853
6854proc splitarc {p} {
6855 global arcnos arcids nextarc arctags archeads idtags idheads
6856 global arcstart arcend arcout allparents growing
6857
6858 set a $arcnos($p)
6859 if {[llength $a] != 1} {
6860 puts "oops splitarc called but [llength $a] arcs already"
6861 return
6862 }
6863 set a [lindex $a 0]
6864 set i [lsearch -exact $arcids($a) $p]
6865 if {$i < 0} {
6866 puts "oops splitarc $p not in arc $a"
6867 return
6868 }
6869 set na [incr nextarc]
6870 if {[info exists arcend($a)]} {
6871 set arcend($na) $arcend($a)
6872 } else {
6873 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6874 set j [lsearch -exact $arcnos($l) $a]
6875 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6876 }
6877 set tail [lrange $arcids($a) [expr {$i+1}] end]
6878 set arcids($a) [lrange $arcids($a) 0 $i]
6879 set arcend($a) $p
6880 set arcstart($na) $p
6881 set arcout($p) $na
6882 set arcids($na) $tail
6883 if {[info exists growing($a)]} {
6884 set growing($na) 1
6885 unset growing($a)
6886 }
6887
6888 foreach id $tail {
6889 if {[llength $arcnos($id)] == 1} {
6890 set arcnos($id) $na
6891 } else {
6892 set j [lsearch -exact $arcnos($id) $a]
6893 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6894 }
6895 }
6896
6897 # reconstruct tags and heads lists
6898 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6899 recalcarc $a
6900 recalcarc $na
6901 } else {
6902 set arctags($na) {}
6903 set archeads($na) {}
6904 }
6905}
6906
6907# Update things for a new commit added that is a child of one
6908# existing commit. Used when cherry-picking.
6909proc addnewchild {id p} {
6910 global allparents allchildren idtags nextarc
6911 global arcnos arcids arctags arcout arcend arcstart archeads growing
6912 global seeds allcommits
6913
6914 if {![info exists allcommits] || ![info exists arcnos($p)]} return
6915 set allparents($id) [list $p]
6916 set allchildren($id) {}
6917 set arcnos($id) {}
6918 lappend seeds $id
6919 lappend allchildren($p) $id
6920 set a [incr nextarc]
6921 set arcstart($a) $id
6922 set archeads($a) {}
6923 set arctags($a) {}
6924 set arcids($a) [list $p]
6925 set arcend($a) $p
6926 if {![info exists arcout($p)]} {
6927 splitarc $p
6928 }
6929 lappend arcnos($p) $a
6930 set arcout($id) [list $a]
6931}
6932
6933# This implements a cache for the topology information.
6934# The cache saves, for each arc, the start and end of the arc,
6935# the ids on the arc, and the outgoing arcs from the end.
6936proc readcache {f} {
6937 global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6938 global idtags idheads allparents cachedarcs possible_seeds seeds growing
6939 global allcwait
6940
6941 set a $nextarc
6942 set lim $cachedarcs
6943 if {$lim - $a > 500} {
6944 set lim [expr {$a + 500}]
6945 }
6946 if {[catch {
6947 if {$a == $lim} {
6948 # finish reading the cache and setting up arctags, etc.
6949 set line [gets $f]
6950 if {$line ne "1"} {error "bad final version"}
6951 close $f
6952 foreach id [array names idtags] {
6953 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6954 [llength $allparents($id)] == 1} {
6955 set a [lindex $arcnos($id) 0]
6956 if {$arctags($a) eq {}} {
6957 recalcarc $a
6958 }
6959 }
6960 }
6961 foreach id [array names idheads] {
6962 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6963 [llength $allparents($id)] == 1} {
6964 set a [lindex $arcnos($id) 0]
6965 if {$archeads($a) eq {}} {
6966 recalcarc $a
6967 }
6968 }
6969 }
6970 foreach id [lsort -unique $possible_seeds] {
6971 if {$arcnos($id) eq {}} {
6972 lappend seeds $id
6973 }
6974 }
6975 set allcwait 0
6976 } else {
6977 while {[incr a] <= $lim} {
6978 set line [gets $f]
6979 if {[llength $line] != 3} {error "bad line"}
6980 set s [lindex $line 0]
6981 set arcstart($a) $s
6982 lappend arcout($s) $a
6983 if {![info exists arcnos($s)]} {
6984 lappend possible_seeds $s
6985 set arcnos($s) {}
6986 }
6987 set e [lindex $line 1]
6988 if {$e eq {}} {
6989 set growing($a) 1
6990 } else {
6991 set arcend($a) $e
6992 if {![info exists arcout($e)]} {
6993 set arcout($e) {}
6994 }
6995 }
6996 set arcids($a) [lindex $line 2]
6997 foreach id $arcids($a) {
6998 lappend allparents($s) $id
6999 set s $id
7000 lappend arcnos($id) $a
7001 }
7002 if {![info exists allparents($s)]} {
7003 set allparents($s) {}
7004 }
7005 set arctags($a) {}
7006 set archeads($a) {}
7007 }
7008 set nextarc [expr {$a - 1}]
7009 }
7010 } err]} {
7011 dropcache $err
7012 return 0
7013 }
7014 if {!$allcwait} {
7015 getallcommits
7016 }
7017 return $allcwait
7018}
7019
7020proc getcache {f} {
7021 global nextarc cachedarcs possible_seeds
7022
7023 if {[catch {
7024 set line [gets $f]
7025 if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7026 # make sure it's an integer
7027 set cachedarcs [expr {int([lindex $line 1])}]
7028 if {$cachedarcs < 0} {error "bad number of arcs"}
7029 set nextarc 0
7030 set possible_seeds {}
7031 run readcache $f
7032 } err]} {
7033 dropcache $err
7034 }
7035 return 0
7036}
7037
7038proc dropcache {err} {
7039 global allcwait nextarc cachedarcs seeds
7040
7041 #puts "dropping cache ($err)"
7042 foreach v {arcnos arcout arcids arcstart arcend growing \
7043 arctags archeads allparents allchildren} {
7044 global $v
7045 catch {unset $v}
7046 }
7047 set allcwait 0
7048 set nextarc 0
7049 set cachedarcs 0
7050 set seeds {}
7051 getallcommits
7052}
7053
7054proc writecache {f} {
7055 global cachearc cachedarcs allccache
7056 global arcstart arcend arcnos arcids arcout
7057
7058 set a $cachearc
7059 set lim $cachedarcs
7060 if {$lim - $a > 1000} {
7061 set lim [expr {$a + 1000}]
7062 }
7063 if {[catch {
7064 while {[incr a] <= $lim} {
7065 if {[info exists arcend($a)]} {
7066 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7067 } else {
7068 puts $f [list $arcstart($a) {} $arcids($a)]
7069 }
7070 }
7071 } err]} {
7072 catch {close $f}
7073 catch {file delete $allccache}
7074 #puts "writing cache failed ($err)"
7075 return 0
7076 }
7077 set cachearc [expr {$a - 1}]
7078 if {$a > $cachedarcs} {
7079 puts $f "1"
7080 close $f
7081 return 0
7082 }
7083 return 1
7084}
7085
7086proc savecache {} {
7087 global nextarc cachedarcs cachearc allccache
7088
7089 if {$nextarc == $cachedarcs} return
7090 set cachearc 0
7091 set cachedarcs $nextarc
7092 catch {
7093 set f [open $allccache w]
7094 puts $f [list 1 $cachedarcs]
7095 run writecache $f
7096 }
7097}
7098
7099# Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7100# or 0 if neither is true.
7101proc anc_or_desc {a b} {
7102 global arcout arcstart arcend arcnos cached_isanc
7103
7104 if {$arcnos($a) eq $arcnos($b)} {
7105 # Both are on the same arc(s); either both are the same BMP,
7106 # or if one is not a BMP, the other is also not a BMP or is
7107 # the BMP at end of the arc (and it only has 1 incoming arc).
7108 # Or both can be BMPs with no incoming arcs.
7109 if {$a eq $b || $arcnos($a) eq {}} {
7110 return 0
7111 }
7112 # assert {[llength $arcnos($a)] == 1}
7113 set arc [lindex $arcnos($a) 0]
7114 set i [lsearch -exact $arcids($arc) $a]
7115 set j [lsearch -exact $arcids($arc) $b]
7116 if {$i < 0 || $i > $j} {
7117 return 1
7118 } else {
7119 return -1
7120 }
7121 }
7122
7123 if {![info exists arcout($a)]} {
7124 set arc [lindex $arcnos($a) 0]
7125 if {[info exists arcend($arc)]} {
7126 set aend $arcend($arc)
7127 } else {
7128 set aend {}
7129 }
7130 set a $arcstart($arc)
7131 } else {
7132 set aend $a
7133 }
7134 if {![info exists arcout($b)]} {
7135 set arc [lindex $arcnos($b) 0]
7136 if {[info exists arcend($arc)]} {
7137 set bend $arcend($arc)
7138 } else {
7139 set bend {}
7140 }
7141 set b $arcstart($arc)
7142 } else {
7143 set bend $b
7144 }
7145 if {$a eq $bend} {
7146 return 1
7147 }
7148 if {$b eq $aend} {
7149 return -1
7150 }
7151 if {[info exists cached_isanc($a,$bend)]} {
7152 if {$cached_isanc($a,$bend)} {
7153 return 1
7154 }
7155 }
7156 if {[info exists cached_isanc($b,$aend)]} {
7157 if {$cached_isanc($b,$aend)} {
7158 return -1
7159 }
7160 if {[info exists cached_isanc($a,$bend)]} {
7161 return 0
7162 }
7163 }
7164
7165 set todo [list $a $b]
7166 set anc($a) a
7167 set anc($b) b
7168 for {set i 0} {$i < [llength $todo]} {incr i} {
7169 set x [lindex $todo $i]
7170 if {$anc($x) eq {}} {
7171 continue
7172 }
7173 foreach arc $arcnos($x) {
7174 set xd $arcstart($arc)
7175 if {$xd eq $bend} {
7176 set cached_isanc($a,$bend) 1
7177 set cached_isanc($b,$aend) 0
7178 return 1
7179 } elseif {$xd eq $aend} {
7180 set cached_isanc($b,$aend) 1
7181 set cached_isanc($a,$bend) 0
7182 return -1
7183 }
7184 if {![info exists anc($xd)]} {
7185 set anc($xd) $anc($x)
7186 lappend todo $xd
7187 } elseif {$anc($xd) ne $anc($x)} {
7188 set anc($xd) {}
7189 }
7190 }
7191 }
7192 set cached_isanc($a,$bend) 0
7193 set cached_isanc($b,$aend) 0
7194 return 0
7195}
7196
7197# This identifies whether $desc has an ancestor that is
7198# a growing tip of the graph and which is not an ancestor of $anc
7199# and returns 0 if so and 1 if not.
7200# If we subsequently discover a tag on such a growing tip, and that
7201# turns out to be a descendent of $anc (which it could, since we
7202# don't necessarily see children before parents), then $desc
7203# isn't a good choice to display as a descendent tag of
7204# $anc (since it is the descendent of another tag which is
7205# a descendent of $anc). Similarly, $anc isn't a good choice to
7206# display as a ancestor tag of $desc.
7207#
7208proc is_certain {desc anc} {
7209 global arcnos arcout arcstart arcend growing problems
7210
7211 set certain {}
7212 if {[llength $arcnos($anc)] == 1} {
7213 # tags on the same arc are certain
7214 if {$arcnos($desc) eq $arcnos($anc)} {
7215 return 1
7216 }
7217 if {![info exists arcout($anc)]} {
7218 # if $anc is partway along an arc, use the start of the arc instead
7219 set a [lindex $arcnos($anc) 0]
7220 set anc $arcstart($a)
7221 }
7222 }
7223 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7224 set x $desc
7225 } else {
7226 set a [lindex $arcnos($desc) 0]
7227 set x $arcend($a)
7228 }
7229 if {$x == $anc} {
7230 return 1
7231 }
7232 set anclist [list $x]
7233 set dl($x) 1
7234 set nnh 1
7235 set ngrowanc 0
7236 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7237 set x [lindex $anclist $i]
7238 if {$dl($x)} {
7239 incr nnh -1
7240 }
7241 set done($x) 1
7242 foreach a $arcout($x) {
7243 if {[info exists growing($a)]} {
7244 if {![info exists growanc($x)] && $dl($x)} {
7245 set growanc($x) 1
7246 incr ngrowanc
7247 }
7248 } else {
7249 set y $arcend($a)
7250 if {[info exists dl($y)]} {
7251 if {$dl($y)} {
7252 if {!$dl($x)} {
7253 set dl($y) 0
7254 if {![info exists done($y)]} {
7255 incr nnh -1
7256 }
7257 if {[info exists growanc($x)]} {
7258 incr ngrowanc -1
7259 }
7260 set xl [list $y]
7261 for {set k 0} {$k < [llength $xl]} {incr k} {
7262 set z [lindex $xl $k]
7263 foreach c $arcout($z) {
7264 if {[info exists arcend($c)]} {
7265 set v $arcend($c)
7266 if {[info exists dl($v)] && $dl($v)} {
7267 set dl($v) 0
7268 if {![info exists done($v)]} {
7269 incr nnh -1
7270 }
7271 if {[info exists growanc($v)]} {
7272 incr ngrowanc -1
7273 }
7274 lappend xl $v
7275 }
7276 }
7277 }
7278 }
7279 }
7280 }
7281 } elseif {$y eq $anc || !$dl($x)} {
7282 set dl($y) 0
7283 lappend anclist $y
7284 } else {
7285 set dl($y) 1
7286 lappend anclist $y
7287 incr nnh
7288 }
7289 }
7290 }
7291 }
7292 foreach x [array names growanc] {
7293 if {$dl($x)} {
7294 return 0
7295 }
7296 return 0
7297 }
7298 return 1
7299}
7300
7301proc validate_arctags {a} {
7302 global arctags idtags
7303
7304 set i -1
7305 set na $arctags($a)
7306 foreach id $arctags($a) {
7307 incr i
7308 if {![info exists idtags($id)]} {
7309 set na [lreplace $na $i $i]
7310 incr i -1
7311 }
7312 }
7313 set arctags($a) $na
7314}
7315
7316proc validate_archeads {a} {
7317 global archeads idheads
7318
7319 set i -1
7320 set na $archeads($a)
7321 foreach id $archeads($a) {
7322 incr i
7323 if {![info exists idheads($id)]} {
7324 set na [lreplace $na $i $i]
7325 incr i -1
7326 }
7327 }
7328 set archeads($a) $na
7329}
7330
7331# Return the list of IDs that have tags that are descendents of id,
7332# ignoring IDs that are descendents of IDs already reported.
7333proc desctags {id} {
7334 global arcnos arcstart arcids arctags idtags allparents
7335 global growing cached_dtags
7336
7337 if {![info exists allparents($id)]} {
7338 return {}
7339 }
7340 set t1 [clock clicks -milliseconds]
7341 set argid $id
7342 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7343 # part-way along an arc; check that arc first
7344 set a [lindex $arcnos($id) 0]
7345 if {$arctags($a) ne {}} {
7346 validate_arctags $a
7347 set i [lsearch -exact $arcids($a) $id]
7348 set tid {}
7349 foreach t $arctags($a) {
7350 set j [lsearch -exact $arcids($a) $t]
7351 if {$j >= $i} break
7352 set tid $t
7353 }
7354 if {$tid ne {}} {
7355 return $tid
7356 }
7357 }
7358 set id $arcstart($a)
7359 if {[info exists idtags($id)]} {
7360 return $id
7361 }
7362 }
7363 if {[info exists cached_dtags($id)]} {
7364 return $cached_dtags($id)
7365 }
7366
7367 set origid $id
7368 set todo [list $id]
7369 set queued($id) 1
7370 set nc 1
7371 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7372 set id [lindex $todo $i]
7373 set done($id) 1
7374 set ta [info exists hastaggedancestor($id)]
7375 if {!$ta} {
7376 incr nc -1
7377 }
7378 # ignore tags on starting node
7379 if {!$ta && $i > 0} {
7380 if {[info exists idtags($id)]} {
7381 set tagloc($id) $id
7382 set ta 1
7383 } elseif {[info exists cached_dtags($id)]} {
7384 set tagloc($id) $cached_dtags($id)
7385 set ta 1
7386 }
7387 }
7388 foreach a $arcnos($id) {
7389 set d $arcstart($a)
7390 if {!$ta && $arctags($a) ne {}} {
7391 validate_arctags $a
7392 if {$arctags($a) ne {}} {
7393 lappend tagloc($id) [lindex $arctags($a) end]
7394 }
7395 }
7396 if {$ta || $arctags($a) ne {}} {
7397 set tomark [list $d]
7398 for {set j 0} {$j < [llength $tomark]} {incr j} {
7399 set dd [lindex $tomark $j]
7400 if {![info exists hastaggedancestor($dd)]} {
7401 if {[info exists done($dd)]} {
7402 foreach b $arcnos($dd) {
7403 lappend tomark $arcstart($b)
7404 }
7405 if {[info exists tagloc($dd)]} {
7406 unset tagloc($dd)
7407 }
7408 } elseif {[info exists queued($dd)]} {
7409 incr nc -1
7410 }
7411 set hastaggedancestor($dd) 1
7412 }
7413 }
7414 }
7415 if {![info exists queued($d)]} {
7416 lappend todo $d
7417 set queued($d) 1
7418 if {![info exists hastaggedancestor($d)]} {
7419 incr nc
7420 }
7421 }
7422 }
7423 }
7424 set tags {}
7425 foreach id [array names tagloc] {
7426 if {![info exists hastaggedancestor($id)]} {
7427 foreach t $tagloc($id) {
7428 if {[lsearch -exact $tags $t] < 0} {
7429 lappend tags $t
7430 }
7431 }
7432 }
7433 }
7434 set t2 [clock clicks -milliseconds]
7435 set loopix $i
7436
7437 # remove tags that are descendents of other tags
7438 for {set i 0} {$i < [llength $tags]} {incr i} {
7439 set a [lindex $tags $i]
7440 for {set j 0} {$j < $i} {incr j} {
7441 set b [lindex $tags $j]
7442 set r [anc_or_desc $a $b]
7443 if {$r == 1} {
7444 set tags [lreplace $tags $j $j]
7445 incr j -1
7446 incr i -1
7447 } elseif {$r == -1} {
7448 set tags [lreplace $tags $i $i]
7449 incr i -1
7450 break
7451 }
7452 }
7453 }
7454
7455 if {[array names growing] ne {}} {
7456 # graph isn't finished, need to check if any tag could get
7457 # eclipsed by another tag coming later. Simply ignore any
7458 # tags that could later get eclipsed.
7459 set ctags {}
7460 foreach t $tags {
7461 if {[is_certain $t $origid]} {
7462 lappend ctags $t
7463 }
7464 }
7465 if {$tags eq $ctags} {
7466 set cached_dtags($origid) $tags
7467 } else {
7468 set tags $ctags
7469 }
7470 } else {
7471 set cached_dtags($origid) $tags
7472 }
7473 set t3 [clock clicks -milliseconds]
7474 if {0 && $t3 - $t1 >= 100} {
7475 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7476 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7477 }
7478 return $tags
7479}
7480
7481proc anctags {id} {
7482 global arcnos arcids arcout arcend arctags idtags allparents
7483 global growing cached_atags
7484
7485 if {![info exists allparents($id)]} {
7486 return {}
7487 }
7488 set t1 [clock clicks -milliseconds]
7489 set argid $id
7490 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7491 # part-way along an arc; check that arc first
7492 set a [lindex $arcnos($id) 0]
7493 if {$arctags($a) ne {}} {
7494 validate_arctags $a
7495 set i [lsearch -exact $arcids($a) $id]
7496 foreach t $arctags($a) {
7497 set j [lsearch -exact $arcids($a) $t]
7498 if {$j > $i} {
7499 return $t
7500 }
7501 }
7502 }
7503 if {![info exists arcend($a)]} {
7504 return {}
7505 }
7506 set id $arcend($a)
7507 if {[info exists idtags($id)]} {
7508 return $id
7509 }
7510 }
7511 if {[info exists cached_atags($id)]} {
7512 return $cached_atags($id)
7513 }
7514
7515 set origid $id
7516 set todo [list $id]
7517 set queued($id) 1
7518 set taglist {}
7519 set nc 1
7520 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7521 set id [lindex $todo $i]
7522 set done($id) 1
7523 set td [info exists hastaggeddescendent($id)]
7524 if {!$td} {
7525 incr nc -1
7526 }
7527 # ignore tags on starting node
7528 if {!$td && $i > 0} {
7529 if {[info exists idtags($id)]} {
7530 set tagloc($id) $id
7531 set td 1
7532 } elseif {[info exists cached_atags($id)]} {
7533 set tagloc($id) $cached_atags($id)
7534 set td 1
7535 }
7536 }
7537 foreach a $arcout($id) {
7538 if {!$td && $arctags($a) ne {}} {
7539 validate_arctags $a
7540 if {$arctags($a) ne {}} {
7541 lappend tagloc($id) [lindex $arctags($a) 0]
7542 }
7543 }
7544 if {![info exists arcend($a)]} continue
7545 set d $arcend($a)
7546 if {$td || $arctags($a) ne {}} {
7547 set tomark [list $d]
7548 for {set j 0} {$j < [llength $tomark]} {incr j} {
7549 set dd [lindex $tomark $j]
7550 if {![info exists hastaggeddescendent($dd)]} {
7551 if {[info exists done($dd)]} {
7552 foreach b $arcout($dd) {
7553 if {[info exists arcend($b)]} {
7554 lappend tomark $arcend($b)
7555 }
7556 }
7557 if {[info exists tagloc($dd)]} {
7558 unset tagloc($dd)
7559 }
7560 } elseif {[info exists queued($dd)]} {
7561 incr nc -1
7562 }
7563 set hastaggeddescendent($dd) 1
7564 }
7565 }
7566 }
7567 if {![info exists queued($d)]} {
7568 lappend todo $d
7569 set queued($d) 1
7570 if {![info exists hastaggeddescendent($d)]} {
7571 incr nc
7572 }
7573 }
7574 }
7575 }
7576 set t2 [clock clicks -milliseconds]
7577 set loopix $i
7578 set tags {}
7579 foreach id [array names tagloc] {
7580 if {![info exists hastaggeddescendent($id)]} {
7581 foreach t $tagloc($id) {
7582 if {[lsearch -exact $tags $t] < 0} {
7583 lappend tags $t
7584 }
7585 }
7586 }
7587 }
7588
7589 # remove tags that are ancestors of other tags
7590 for {set i 0} {$i < [llength $tags]} {incr i} {
7591 set a [lindex $tags $i]
7592 for {set j 0} {$j < $i} {incr j} {
7593 set b [lindex $tags $j]
7594 set r [anc_or_desc $a $b]
7595 if {$r == -1} {
7596 set tags [lreplace $tags $j $j]
7597 incr j -1
7598 incr i -1
7599 } elseif {$r == 1} {
7600 set tags [lreplace $tags $i $i]
7601 incr i -1
7602 break
7603 }
7604 }
7605 }
7606
7607 if {[array names growing] ne {}} {
7608 # graph isn't finished, need to check if any tag could get
7609 # eclipsed by another tag coming later. Simply ignore any
7610 # tags that could later get eclipsed.
7611 set ctags {}
7612 foreach t $tags {
7613 if {[is_certain $origid $t]} {
7614 lappend ctags $t
7615 }
7616 }
7617 if {$tags eq $ctags} {
7618 set cached_atags($origid) $tags
7619 } else {
7620 set tags $ctags
7621 }
7622 } else {
7623 set cached_atags($origid) $tags
7624 }
7625 set t3 [clock clicks -milliseconds]
7626 if {0 && $t3 - $t1 >= 100} {
7627 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7628 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7629 }
7630 return $tags
7631}
7632
7633# Return the list of IDs that have heads that are descendents of id,
7634# including id itself if it has a head.
7635proc descheads {id} {
7636 global arcnos arcstart arcids archeads idheads cached_dheads
7637 global allparents
7638
7639 if {![info exists allparents($id)]} {
7640 return {}
7641 }
7642 set aret {}
7643 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7644 # part-way along an arc; check it first
7645 set a [lindex $arcnos($id) 0]
7646 if {$archeads($a) ne {}} {
7647 validate_archeads $a
7648 set i [lsearch -exact $arcids($a) $id]
7649 foreach t $archeads($a) {
7650 set j [lsearch -exact $arcids($a) $t]
7651 if {$j > $i} break
7652 lappend aret $t
7653 }
7654 }
7655 set id $arcstart($a)
7656 }
7657 set origid $id
7658 set todo [list $id]
7659 set seen($id) 1
7660 set ret {}
7661 for {set i 0} {$i < [llength $todo]} {incr i} {
7662 set id [lindex $todo $i]
7663 if {[info exists cached_dheads($id)]} {
7664 set ret [concat $ret $cached_dheads($id)]
7665 } else {
7666 if {[info exists idheads($id)]} {
7667 lappend ret $id
7668 }
7669 foreach a $arcnos($id) {
7670 if {$archeads($a) ne {}} {
7671 validate_archeads $a
7672 if {$archeads($a) ne {}} {
7673 set ret [concat $ret $archeads($a)]
7674 }
7675 }
7676 set d $arcstart($a)
7677 if {![info exists seen($d)]} {
7678 lappend todo $d
7679 set seen($d) 1
7680 }
7681 }
7682 }
7683 }
7684 set ret [lsort -unique $ret]
7685 set cached_dheads($origid) $ret
7686 return [concat $ret $aret]
7687}
7688
7689proc addedtag {id} {
7690 global arcnos arcout cached_dtags cached_atags
7691
7692 if {![info exists arcnos($id)]} return
7693 if {![info exists arcout($id)]} {
7694 recalcarc [lindex $arcnos($id) 0]
7695 }
7696 catch {unset cached_dtags}
7697 catch {unset cached_atags}
7698}
7699
7700proc addedhead {hid head} {
7701 global arcnos arcout cached_dheads
7702
7703 if {![info exists arcnos($hid)]} return
7704 if {![info exists arcout($hid)]} {
7705 recalcarc [lindex $arcnos($hid) 0]
7706 }
7707 catch {unset cached_dheads}
7708}
7709
7710proc removedhead {hid head} {
7711 global cached_dheads
7712
7713 catch {unset cached_dheads}
7714}
7715
7716proc movedhead {hid head} {
7717 global arcnos arcout cached_dheads
7718
7719 if {![info exists arcnos($hid)]} return
7720 if {![info exists arcout($hid)]} {
7721 recalcarc [lindex $arcnos($hid) 0]
7722 }
7723 catch {unset cached_dheads}
7724}
7725
7726proc changedrefs {} {
7727 global cached_dheads cached_dtags cached_atags
7728 global arctags archeads arcnos arcout idheads idtags
7729
7730 foreach id [concat [array names idheads] [array names idtags]] {
7731 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7732 set a [lindex $arcnos($id) 0]
7733 if {![info exists donearc($a)]} {
7734 recalcarc $a
7735 set donearc($a) 1
7736 }
7737 }
7738 }
7739 catch {unset cached_dtags}
7740 catch {unset cached_atags}
7741 catch {unset cached_dheads}
7742}
7743
7744proc rereadrefs {} {
7745 global idtags idheads idotherrefs mainhead
7746
7747 set refids [concat [array names idtags] \
7748 [array names idheads] [array names idotherrefs]]
7749 foreach id $refids {
7750 if {![info exists ref($id)]} {
7751 set ref($id) [listrefs $id]
7752 }
7753 }
7754 set oldmainhead $mainhead
7755 readrefs
7756 changedrefs
7757 set refids [lsort -unique [concat $refids [array names idtags] \
7758 [array names idheads] [array names idotherrefs]]]
7759 foreach id $refids {
7760 set v [listrefs $id]
7761 if {![info exists ref($id)] || $ref($id) != $v ||
7762 ($id eq $oldmainhead && $id ne $mainhead) ||
7763 ($id eq $mainhead && $id ne $oldmainhead)} {
7764 redrawtags $id
7765 }
7766 }
7767 run refill_reflist
7768}
7769
7770proc listrefs {id} {
7771 global idtags idheads idotherrefs
7772
7773 set x {}
7774 if {[info exists idtags($id)]} {
7775 set x $idtags($id)
7776 }
7777 set y {}
7778 if {[info exists idheads($id)]} {
7779 set y $idheads($id)
7780 }
7781 set z {}
7782 if {[info exists idotherrefs($id)]} {
7783 set z $idotherrefs($id)
7784 }
7785 return [list $x $y $z]
7786}
7787
7788proc showtag {tag isnew} {
7789 global ctext tagcontents tagids linknum tagobjid
7790
7791 if {$isnew} {
7792 addtohistory [list showtag $tag 0]
7793 }
7794 $ctext conf -state normal
7795 clear_ctext
7796 settabs 0
7797 set linknum 0
7798 if {![info exists tagcontents($tag)]} {
7799 catch {
7800 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7801 }
7802 }
7803 if {[info exists tagcontents($tag)]} {
7804 set text $tagcontents($tag)
7805 } else {
7806 set text "[mc "Tag"]: $tag\n[mc "Id"]: $tagids($tag)"
7807 }
7808 appendwithlinks $text {}
7809 $ctext conf -state disabled
7810 init_flist {}
7811}
7812
7813proc doquit {} {
7814 global stopped
7815 set stopped 100
7816 savestuff .
7817 destroy .
7818}
7819
7820proc mkfontdisp {font top which} {
7821 global fontattr fontpref $font
7822
7823 set fontpref($font) [set $font]
7824 button $top.${font}but -text $which -font optionfont \
7825 -command [list choosefont $font $which]
7826 label $top.$font -relief flat -font $font \
7827 -text $fontattr($font,family) -justify left
7828 grid x $top.${font}but $top.$font -sticky w
7829}
7830
7831proc choosefont {font which} {
7832 global fontparam fontlist fonttop fontattr
7833
7834 set fontparam(which) $which
7835 set fontparam(font) $font
7836 set fontparam(family) [font actual $font -family]
7837 set fontparam(size) $fontattr($font,size)
7838 set fontparam(weight) $fontattr($font,weight)
7839 set fontparam(slant) $fontattr($font,slant)
7840 set top .gitkfont
7841 set fonttop $top
7842 if {![winfo exists $top]} {
7843 font create sample
7844 eval font config sample [font actual $font]
7845 toplevel $top
7846 wm title $top [mc "Gitk font chooser"]
7847 label $top.l -textvariable fontparam(which)
7848 pack $top.l -side top
7849 set fontlist [lsort [font families]]
7850 frame $top.f
7851 listbox $top.f.fam -listvariable fontlist \
7852 -yscrollcommand [list $top.f.sb set]
7853 bind $top.f.fam <<ListboxSelect>> selfontfam
7854 scrollbar $top.f.sb -command [list $top.f.fam yview]
7855 pack $top.f.sb -side right -fill y
7856 pack $top.f.fam -side left -fill both -expand 1
7857 pack $top.f -side top -fill both -expand 1
7858 frame $top.g
7859 spinbox $top.g.size -from 4 -to 40 -width 4 \
7860 -textvariable fontparam(size) \
7861 -validatecommand {string is integer -strict %s}
7862 checkbutton $top.g.bold -padx 5 \
7863 -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7864 -variable fontparam(weight) -onvalue bold -offvalue normal
7865 checkbutton $top.g.ital -padx 5 \
7866 -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0 \
7867 -variable fontparam(slant) -onvalue italic -offvalue roman
7868 pack $top.g.size $top.g.bold $top.g.ital -side left
7869 pack $top.g -side top
7870 canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7871 -background white
7872 $top.c create text 100 25 -anchor center -text $which -font sample \
7873 -fill black -tags text
7874 bind $top.c <Configure> [list centertext $top.c]
7875 pack $top.c -side top -fill x
7876 frame $top.buts
7877 button $top.buts.ok -text [mc "OK"] -command fontok -default active
7878 button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7879 grid $top.buts.ok $top.buts.can
7880 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7881 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7882 pack $top.buts -side bottom -fill x
7883 trace add variable fontparam write chg_fontparam
7884 } else {
7885 raise $top
7886 $top.c itemconf text -text $which
7887 }
7888 set i [lsearch -exact $fontlist $fontparam(family)]
7889 if {$i >= 0} {
7890 $top.f.fam selection set $i
7891 $top.f.fam see $i
7892 }
7893}
7894
7895proc centertext {w} {
7896 $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7897}
7898
7899proc fontok {} {
7900 global fontparam fontpref prefstop
7901
7902 set f $fontparam(font)
7903 set fontpref($f) [list $fontparam(family) $fontparam(size)]
7904 if {$fontparam(weight) eq "bold"} {
7905 lappend fontpref($f) "bold"
7906 }
7907 if {$fontparam(slant) eq "italic"} {
7908 lappend fontpref($f) "italic"
7909 }
7910 set w $prefstop.$f
7911 $w conf -text $fontparam(family) -font $fontpref($f)
7912
7913 fontcan
7914}
7915
7916proc fontcan {} {
7917 global fonttop fontparam
7918
7919 if {[info exists fonttop]} {
7920 catch {destroy $fonttop}
7921 catch {font delete sample}
7922 unset fonttop
7923 unset fontparam
7924 }
7925}
7926
7927proc selfontfam {} {
7928 global fonttop fontparam
7929
7930 set i [$fonttop.f.fam curselection]
7931 if {$i ne {}} {
7932 set fontparam(family) [$fonttop.f.fam get $i]
7933 }
7934}
7935
7936proc chg_fontparam {v sub op} {
7937 global fontparam
7938
7939 font config sample -$sub $fontparam($sub)
7940}
7941
7942proc doprefs {} {
7943 global maxwidth maxgraphpct
7944 global oldprefs prefstop showneartags showlocalchanges
7945 global bgcolor fgcolor ctext diffcolors selectbgcolor
7946 global tabstop limitdiffs
7947
7948 set top .gitkprefs
7949 set prefstop $top
7950 if {[winfo exists $top]} {
7951 raise $top
7952 return
7953 }
7954 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7955 limitdiffs tabstop} {
7956 set oldprefs($v) [set $v]
7957 }
7958 toplevel $top
7959 wm title $top [mc "Gitk preferences"]
7960 label $top.ldisp -text [mc "Commit list display options"]
7961 grid $top.ldisp - -sticky w -pady 10
7962 label $top.spacer -text " "
7963 label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
7964 -font optionfont
7965 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7966 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7967 label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
7968 -font optionfont
7969 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7970 grid x $top.maxpctl $top.maxpct -sticky w
7971 frame $top.showlocal
7972 label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
7973 checkbutton $top.showlocal.b -variable showlocalchanges
7974 pack $top.showlocal.b $top.showlocal.l -side left
7975 grid x $top.showlocal -sticky w
7976
7977 label $top.ddisp -text [mc "Diff display options"]
7978 grid $top.ddisp - -sticky w -pady 10
7979 label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
7980 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7981 grid x $top.tabstopl $top.tabstop -sticky w
7982 frame $top.ntag
7983 label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
7984 checkbutton $top.ntag.b -variable showneartags
7985 pack $top.ntag.b $top.ntag.l -side left
7986 grid x $top.ntag -sticky w
7987 frame $top.ldiff
7988 label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
7989 checkbutton $top.ldiff.b -variable limitdiffs
7990 pack $top.ldiff.b $top.ldiff.l -side left
7991 grid x $top.ldiff -sticky w
7992
7993 label $top.cdisp -text [mc "Colors: press to choose"]
7994 grid $top.cdisp - -sticky w -pady 10
7995 label $top.bg -padx 40 -relief sunk -background $bgcolor
7996 button $top.bgbut -text [mc "Background"] -font optionfont \
7997 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7998 grid x $top.bgbut $top.bg -sticky w
7999 label $top.fg -padx 40 -relief sunk -background $fgcolor
8000 button $top.fgbut -text [mc "Foreground"] -font optionfont \
8001 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8002 grid x $top.fgbut $top.fg -sticky w
8003 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8004 button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8005 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8006 [list $ctext tag conf d0 -foreground]]
8007 grid x $top.diffoldbut $top.diffold -sticky w
8008 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8009 button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8010 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8011 [list $ctext tag conf d1 -foreground]]
8012 grid x $top.diffnewbut $top.diffnew -sticky w
8013 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8014 button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8015 -command [list choosecolor diffcolors 2 $top.hunksep \
8016 "diff hunk header" \
8017 [list $ctext tag conf hunksep -foreground]]
8018 grid x $top.hunksepbut $top.hunksep -sticky w
8019 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8020 button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8021 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8022 grid x $top.selbgbut $top.selbgsep -sticky w
8023
8024 label $top.cfont -text [mc "Fonts: press to choose"]
8025 grid $top.cfont - -sticky w -pady 10
8026 mkfontdisp mainfont $top [mc "Main font"]
8027 mkfontdisp textfont $top [mc "Diff display font"]
8028 mkfontdisp uifont $top [mc "User interface font"]
8029
8030 frame $top.buts
8031 button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8032 button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8033 grid $top.buts.ok $top.buts.can
8034 grid columnconfigure $top.buts 0 -weight 1 -uniform a
8035 grid columnconfigure $top.buts 1 -weight 1 -uniform a
8036 grid $top.buts - - -pady 10 -sticky ew
8037 bind $top <Visibility> "focus $top.buts.ok"
8038}
8039
8040proc choosecolor {v vi w x cmd} {
8041 global $v
8042
8043 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8044 -title [mc "Gitk: choose color for %s" $x]]
8045 if {$c eq {}} return
8046 $w conf -background $c
8047 lset $v $vi $c
8048 eval $cmd $c
8049}
8050
8051proc setselbg {c} {
8052 global bglist cflist
8053 foreach w $bglist {
8054 $w configure -selectbackground $c
8055 }
8056 $cflist tag configure highlight \
8057 -background [$cflist cget -selectbackground]
8058 allcanvs itemconf secsel -fill $c
8059}
8060
8061proc setbg {c} {
8062 global bglist
8063
8064 foreach w $bglist {
8065 $w conf -background $c
8066 }
8067}
8068
8069proc setfg {c} {
8070 global fglist canv
8071
8072 foreach w $fglist {
8073 $w conf -foreground $c
8074 }
8075 allcanvs itemconf text -fill $c
8076 $canv itemconf circle -outline $c
8077}
8078
8079proc prefscan {} {
8080 global oldprefs prefstop
8081
8082 foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8083 limitdiffs tabstop} {
8084 global $v
8085 set $v $oldprefs($v)
8086 }
8087 catch {destroy $prefstop}
8088 unset prefstop
8089 fontcan
8090}
8091
8092proc prefsok {} {
8093 global maxwidth maxgraphpct
8094 global oldprefs prefstop showneartags showlocalchanges
8095 global fontpref mainfont textfont uifont
8096 global limitdiffs treediffs
8097
8098 catch {destroy $prefstop}
8099 unset prefstop
8100 fontcan
8101 set fontchanged 0
8102 if {$mainfont ne $fontpref(mainfont)} {
8103 set mainfont $fontpref(mainfont)
8104 parsefont mainfont $mainfont
8105 eval font configure mainfont [fontflags mainfont]
8106 eval font configure mainfontbold [fontflags mainfont 1]
8107 setcoords
8108 set fontchanged 1
8109 }
8110 if {$textfont ne $fontpref(textfont)} {
8111 set textfont $fontpref(textfont)
8112 parsefont textfont $textfont
8113 eval font configure textfont [fontflags textfont]
8114 eval font configure textfontbold [fontflags textfont 1]
8115 }
8116 if {$uifont ne $fontpref(uifont)} {
8117 set uifont $fontpref(uifont)
8118 parsefont uifont $uifont
8119 eval font configure uifont [fontflags uifont]
8120 }
8121 settabs
8122 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8123 if {$showlocalchanges} {
8124 doshowlocalchanges
8125 } else {
8126 dohidelocalchanges
8127 }
8128 }
8129 if {$limitdiffs != $oldprefs(limitdiffs)} {
8130 # treediffs elements are limited by path
8131 catch {unset treediffs}
8132 }
8133 if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8134 || $maxgraphpct != $oldprefs(maxgraphpct)} {
8135 redisplay
8136 } elseif {$showneartags != $oldprefs(showneartags) ||
8137 $limitdiffs != $oldprefs(limitdiffs)} {
8138 reselectline
8139 }
8140}
8141
8142proc formatdate {d} {
8143 global datetimeformat
8144 if {$d ne {}} {
8145 set d [clock format $d -format $datetimeformat]
8146 }
8147 return $d
8148}
8149
8150# This list of encoding names and aliases is distilled from
8151# http://www.iana.org/assignments/character-sets.
8152# Not all of them are supported by Tcl.
8153set encoding_aliases {
8154 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8155 ISO646-US US-ASCII us IBM367 cp367 csASCII }
8156 { ISO-10646-UTF-1 csISO10646UTF1 }
8157 { ISO_646.basic:1983 ref csISO646basic1983 }
8158 { INVARIANT csINVARIANT }
8159 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8160 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8161 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8162 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8163 { NATS-DANO iso-ir-9-1 csNATSDANO }
8164 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8165 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8166 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8167 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8168 { ISO-2022-KR csISO2022KR }
8169 { EUC-KR csEUCKR }
8170 { ISO-2022-JP csISO2022JP }
8171 { ISO-2022-JP-2 csISO2022JP2 }
8172 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8173 csISO13JISC6220jp }
8174 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8175 { IT iso-ir-15 ISO646-IT csISO15Italian }
8176 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8177 { ES iso-ir-17 ISO646-ES csISO17Spanish }
8178 { greek7-old iso-ir-18 csISO18Greek7Old }
8179 { latin-greek iso-ir-19 csISO19LatinGreek }
8180 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8181 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8182 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8183 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8184 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8185 { BS_viewdata iso-ir-47 csISO47BSViewdata }
8186 { INIS iso-ir-49 csISO49INIS }
8187 { INIS-8 iso-ir-50 csISO50INIS8 }
8188 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8189 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8190 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8191 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8192 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8193 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8194 csISO60Norwegian1 }
8195 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8196 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8197 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8198 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8199 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8200 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8201 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8202 { greek7 iso-ir-88 csISO88Greek7 }
8203 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8204 { iso-ir-90 csISO90 }
8205 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8206 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8207 csISO92JISC62991984b }
8208 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8209 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8210 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8211 csISO95JIS62291984handadd }
8212 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8213 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8214 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8215 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8216 CP819 csISOLatin1 }
8217 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8218 { T.61-7bit iso-ir-102 csISO102T617bit }
8219 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8220 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8221 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8222 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8223 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8224 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8225 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8226 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8227 arabic csISOLatinArabic }
8228 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8229 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8230 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8231 greek greek8 csISOLatinGreek }
8232 { T.101-G2 iso-ir-128 csISO128T101G2 }
8233 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8234 csISOLatinHebrew }
8235 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8236 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8237 { CSN_369103 iso-ir-139 csISO139CSN369103 }
8238 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8239 { ISO_6937-2-add iso-ir-142 csISOTextComm }
8240 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8241 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8242 csISOLatinCyrillic }
8243 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8244 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8245 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8246 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8247 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8248 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8249 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8250 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8251 { ISO_10367-box iso-ir-155 csISO10367Box }
8252 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8253 { latin-lap lap iso-ir-158 csISO158Lap }
8254 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8255 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8256 { us-dk csUSDK }
8257 { dk-us csDKUS }
8258 { JIS_X0201 X0201 csHalfWidthKatakana }
8259 { KSC5636 ISO646-KR csKSC5636 }
8260 { ISO-10646-UCS-2 csUnicode }
8261 { ISO-10646-UCS-4 csUCS4 }
8262 { DEC-MCS dec csDECMCS }
8263 { hp-roman8 roman8 r8 csHPRoman8 }
8264 { macintosh mac csMacintosh }
8265 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8266 csIBM037 }
8267 { IBM038 EBCDIC-INT cp038 csIBM038 }
8268 { IBM273 CP273 csIBM273 }
8269 { IBM274 EBCDIC-BE CP274 csIBM274 }
8270 { IBM275 EBCDIC-BR cp275 csIBM275 }
8271 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8272 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8273 { IBM280 CP280 ebcdic-cp-it csIBM280 }
8274 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8275 { IBM284 CP284 ebcdic-cp-es csIBM284 }
8276 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8277 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8278 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8279 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8280 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8281 { IBM424 cp424 ebcdic-cp-he csIBM424 }
8282 { IBM437 cp437 437 csPC8CodePage437 }
8283 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8284 { IBM775 cp775 csPC775Baltic }
8285 { IBM850 cp850 850 csPC850Multilingual }
8286 { IBM851 cp851 851 csIBM851 }
8287 { IBM852 cp852 852 csPCp852 }
8288 { IBM855 cp855 855 csIBM855 }
8289 { IBM857 cp857 857 csIBM857 }
8290 { IBM860 cp860 860 csIBM860 }
8291 { IBM861 cp861 861 cp-is csIBM861 }
8292 { IBM862 cp862 862 csPC862LatinHebrew }
8293 { IBM863 cp863 863 csIBM863 }
8294 { IBM864 cp864 csIBM864 }
8295 { IBM865 cp865 865 csIBM865 }
8296 { IBM866 cp866 866 csIBM866 }
8297 { IBM868 CP868 cp-ar csIBM868 }
8298 { IBM869 cp869 869 cp-gr csIBM869 }
8299 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8300 { IBM871 CP871 ebcdic-cp-is csIBM871 }
8301 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8302 { IBM891 cp891 csIBM891 }
8303 { IBM903 cp903 csIBM903 }
8304 { IBM904 cp904 904 csIBBM904 }
8305 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8306 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8307 { IBM1026 CP1026 csIBM1026 }
8308 { EBCDIC-AT-DE csIBMEBCDICATDE }
8309 { EBCDIC-AT-DE-A csEBCDICATDEA }
8310 { EBCDIC-CA-FR csEBCDICCAFR }
8311 { EBCDIC-DK-NO csEBCDICDKNO }
8312 { EBCDIC-DK-NO-A csEBCDICDKNOA }
8313 { EBCDIC-FI-SE csEBCDICFISE }
8314 { EBCDIC-FI-SE-A csEBCDICFISEA }
8315 { EBCDIC-FR csEBCDICFR }
8316 { EBCDIC-IT csEBCDICIT }
8317 { EBCDIC-PT csEBCDICPT }
8318 { EBCDIC-ES csEBCDICES }
8319 { EBCDIC-ES-A csEBCDICESA }
8320 { EBCDIC-ES-S csEBCDICESS }
8321 { EBCDIC-UK csEBCDICUK }
8322 { EBCDIC-US csEBCDICUS }
8323 { UNKNOWN-8BIT csUnknown8BiT }
8324 { MNEMONIC csMnemonic }
8325 { MNEM csMnem }
8326 { VISCII csVISCII }
8327 { VIQR csVIQR }
8328 { KOI8-R csKOI8R }
8329 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8330 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8331 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8332 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8333 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8334 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8335 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8336 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8337 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8338 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8339 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8340 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8341 { IBM1047 IBM-1047 }
8342 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8343 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8344 { UNICODE-1-1 csUnicode11 }
8345 { CESU-8 csCESU-8 }
8346 { BOCU-1 csBOCU-1 }
8347 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8348 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8349 l8 }
8350 { ISO-8859-15 ISO_8859-15 Latin-9 }
8351 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8352 { GBK CP936 MS936 windows-936 }
8353 { JIS_Encoding csJISEncoding }
8354 { Shift_JIS MS_Kanji csShiftJIS }
8355 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8356 EUC-JP }
8357 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8358 { ISO-10646-UCS-Basic csUnicodeASCII }
8359 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8360 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8361 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8362 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8363 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8364 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8365 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8366 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8367 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8368 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8369 { Adobe-Standard-Encoding csAdobeStandardEncoding }
8370 { Ventura-US csVenturaUS }
8371 { Ventura-International csVenturaInternational }
8372 { PC8-Danish-Norwegian csPC8DanishNorwegian }
8373 { PC8-Turkish csPC8Turkish }
8374 { IBM-Symbols csIBMSymbols }
8375 { IBM-Thai csIBMThai }
8376 { HP-Legal csHPLegal }
8377 { HP-Pi-font csHPPiFont }
8378 { HP-Math8 csHPMath8 }
8379 { Adobe-Symbol-Encoding csHPPSMath }
8380 { HP-DeskTop csHPDesktop }
8381 { Ventura-Math csVenturaMath }
8382 { Microsoft-Publishing csMicrosoftPublishing }
8383 { Windows-31J csWindows31J }
8384 { GB2312 csGB2312 }
8385 { Big5 csBig5 }
8386}
8387
8388proc tcl_encoding {enc} {
8389 global encoding_aliases
8390 set names [encoding names]
8391 set lcnames [string tolower $names]
8392 set enc [string tolower $enc]
8393 set i [lsearch -exact $lcnames $enc]
8394 if {$i < 0} {
8395 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8396 if {[regsub {^iso[-_]} $enc iso encx]} {
8397 set i [lsearch -exact $lcnames $encx]
8398 }
8399 }
8400 if {$i < 0} {
8401 foreach l $encoding_aliases {
8402 set ll [string tolower $l]
8403 if {[lsearch -exact $ll $enc] < 0} continue
8404 # look through the aliases for one that tcl knows about
8405 foreach e $ll {
8406 set i [lsearch -exact $lcnames $e]
8407 if {$i < 0} {
8408 if {[regsub {^iso[-_]} $e iso ex]} {
8409 set i [lsearch -exact $lcnames $ex]
8410 }
8411 }
8412 if {$i >= 0} break
8413 }
8414 break
8415 }
8416 }
8417 if {$i >= 0} {
8418 return [lindex $names $i]
8419 }
8420 return {}
8421}
8422
8423# First check that Tcl/Tk is recent enough
8424if {[catch {package require Tk 8.4} err]} {
8425 show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8426 Gitk requires at least Tcl/Tk 8.4."]
8427 exit 1
8428}
8429
8430# defaults...
8431set datemode 0
8432set wrcomcmd "git diff-tree --stdin -p --pretty"
8433
8434set gitencoding {}
8435catch {
8436 set gitencoding [exec git config --get i18n.commitencoding]
8437}
8438if {$gitencoding == ""} {
8439 set gitencoding "utf-8"
8440}
8441set tclencoding [tcl_encoding $gitencoding]
8442if {$tclencoding == {}} {
8443 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8444}
8445
8446set mainfont {Helvetica 9}
8447set textfont {Courier 9}
8448set uifont {Helvetica 9 bold}
8449set tabstop 8
8450set findmergefiles 0
8451set maxgraphpct 50
8452set maxwidth 16
8453set revlistorder 0
8454set fastdate 0
8455set uparrowlen 5
8456set downarrowlen 5
8457set mingaplen 100
8458set cmitmode "patch"
8459set wrapcomment "none"
8460set showneartags 1
8461set maxrefs 20
8462set maxlinelen 200
8463set showlocalchanges 1
8464set limitdiffs 1
8465set datetimeformat "%Y-%m-%d %H:%M:%S"
8466
8467set colors {green red blue magenta darkgrey brown orange}
8468set bgcolor white
8469set fgcolor black
8470set diffcolors {red "#00a000" blue}
8471set diffcontext 3
8472set ignorespace 0
8473set selectbgcolor gray85
8474
8475## For msgcat loading, first locate the installation location.
8476if { [info exists ::env(GITK_MSGSDIR)] } {
8477 ## Msgsdir was manually set in the environment.
8478 set gitk_msgsdir $::env(GITK_MSGSDIR)
8479} else {
8480 ## Let's guess the prefix from argv0.
8481 set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8482 set gitk_libdir [file join $gitk_prefix share gitk lib]
8483 set gitk_msgsdir [file join $gitk_libdir msgs]
8484 unset gitk_prefix
8485}
8486
8487## Internationalization (i18n) through msgcat and gettext. See
8488## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8489package require msgcat
8490namespace import ::msgcat::mc
8491## And eventually load the actual message catalog
8492::msgcat::mcload $gitk_msgsdir
8493
8494catch {source ~/.gitk}
8495
8496font create optionfont -family sans-serif -size -12
8497
8498parsefont mainfont $mainfont
8499eval font create mainfont [fontflags mainfont]
8500eval font create mainfontbold [fontflags mainfont 1]
8501
8502parsefont textfont $textfont
8503eval font create textfont [fontflags textfont]
8504eval font create textfontbold [fontflags textfont 1]
8505
8506parsefont uifont $uifont
8507eval font create uifont [fontflags uifont]
8508
8509setoptions
8510
8511# check that we can find a .git directory somewhere...
8512if {[catch {set gitdir [gitdir]}]} {
8513 show_error {} . [mc "Cannot find a git repository here."]
8514 exit 1
8515}
8516if {![file isdirectory $gitdir]} {
8517 show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8518 exit 1
8519}
8520
8521set mergeonly 0
8522set revtreeargs {}
8523set cmdline_files {}
8524set i 0
8525foreach arg $argv {
8526 switch -- $arg {
8527 "" { }
8528 "-d" { set datemode 1 }
8529 "--merge" {
8530 set mergeonly 1
8531 lappend revtreeargs $arg
8532 }
8533 "--" {
8534 set cmdline_files [lrange $argv [expr {$i + 1}] end]
8535 break
8536 }
8537 default {
8538 lappend revtreeargs $arg
8539 }
8540 }
8541 incr i
8542}
8543
8544if {$i >= [llength $argv] && $revtreeargs ne {}} {
8545 # no -- on command line, but some arguments (other than -d)
8546 if {[catch {
8547 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8548 set cmdline_files [split $f "\n"]
8549 set n [llength $cmdline_files]
8550 set revtreeargs [lrange $revtreeargs 0 end-$n]
8551 # Unfortunately git rev-parse doesn't produce an error when
8552 # something is both a revision and a filename. To be consistent
8553 # with git log and git rev-list, check revtreeargs for filenames.
8554 foreach arg $revtreeargs {
8555 if {[file exists $arg]} {
8556 show_error {} . [mc "Ambiguous argument '%s': both revision\
8557 and filename" $arg]
8558 exit 1
8559 }
8560 }
8561 } err]} {
8562 # unfortunately we get both stdout and stderr in $err,
8563 # so look for "fatal:".
8564 set i [string first "fatal:" $err]
8565 if {$i > 0} {
8566 set err [string range $err [expr {$i + 6}] end]
8567 }
8568 show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8569 exit 1
8570 }
8571}
8572
8573if {$mergeonly} {
8574 # find the list of unmerged files
8575 set mlist {}
8576 set nr_unmerged 0
8577 if {[catch {
8578 set fd [open "| git ls-files -u" r]
8579 } err]} {
8580 show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8581 exit 1
8582 }
8583 while {[gets $fd line] >= 0} {
8584 set i [string first "\t" $line]
8585 if {$i < 0} continue
8586 set fname [string range $line [expr {$i+1}] end]
8587 if {[lsearch -exact $mlist $fname] >= 0} continue
8588 incr nr_unmerged
8589 if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8590 lappend mlist $fname
8591 }
8592 }
8593 catch {close $fd}
8594 if {$mlist eq {}} {
8595 if {$nr_unmerged == 0} {
8596 show_error {} . [mc "No files selected: --merge specified but\
8597 no files are unmerged."]
8598 } else {
8599 show_error {} . [mc "No files selected: --merge specified but\
8600 no unmerged files are within file limit."]
8601 }
8602 exit 1
8603 }
8604 set cmdline_files $mlist
8605}
8606
8607set nullid "0000000000000000000000000000000000000000"
8608set nullid2 "0000000000000000000000000000000000000001"
8609
8610set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8611
8612set runq {}
8613set history {}
8614set historyindex 0
8615set fh_serial 0
8616set nhl_names {}
8617set highlight_paths {}
8618set findpattern {}
8619set searchdirn -forwards
8620set boldrows {}
8621set boldnamerows {}
8622set diffelide {0 0}
8623set markingmatches 0
8624set linkentercount 0
8625set need_redisplay 0
8626set nrows_drawn 0
8627set firsttabstop 0
8628
8629set nextviewnum 1
8630set curview 0
8631set selectedview 0
8632set selectedhlview [mc "None"]
8633set highlight_related [mc "None"]
8634set highlight_files {}
8635set viewfiles(0) {}
8636set viewperm(0) 0
8637set viewargs(0) {}
8638
8639set cmdlineok 0
8640set stopped 0
8641set stuffsaved 0
8642set patchnum 0
8643set localirow -1
8644set localfrow -1
8645set lserial 0
8646setcoords
8647makewindow
8648# wait for the window to become visible
8649tkwait visibility .
8650wm title . "[file tail $argv0]: [file tail [pwd]]"
8651readrefs
8652
8653if {$cmdline_files ne {} || $revtreeargs ne {}} {
8654 # create a view for the files/dirs specified on the command line
8655 set curview 1
8656 set selectedview 1
8657 set nextviewnum 2
8658 set viewname(1) [mc "Command line"]
8659 set viewfiles(1) $cmdline_files
8660 set viewargs(1) $revtreeargs
8661 set viewperm(1) 0
8662 addviewmenu 1
8663 .bar.view entryconf [mc "Edit view..."] -state normal
8664 .bar.view entryconf [mc "Delete view"] -state normal
8665}
8666
8667if {[info exists permviews]} {
8668 foreach v $permviews {
8669 set n $nextviewnum
8670 incr nextviewnum
8671 set viewname($n) [lindex $v 0]
8672 set viewfiles($n) [lindex $v 1]
8673 set viewargs($n) [lindex $v 2]
8674 set viewperm($n) 1
8675 addviewmenu $n
8676 }
8677}
8678getcommits