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