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