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