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