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