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