gitk: Store ids in rowrangelist and idrowranges rather than row numbers
[git/mingw/4msysgit.git] / gitk
blob023205a3b141e5961d17ba1f5fd04f09de13cbdf
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 displayorder
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) [lindex $displayorder $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 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 set ranges [rowranges $id]
2631 foreach {s e} $ranges {
2632 incr i
2633 if {$e ne {} && $e < $numcommits && $s <= $r1 && $e >= $r0
2634 && ![info exists idrangedrawn($id,$i)]} {
2635 drawlineseg $id $i $ranges
2636 set idrangedrawn($id,$i) 1
2641 if {$canshow > $r1} {
2642 set canshow $r1
2644 while {$row < $canshow} {
2645 drawcmitrow $row
2646 incr row
2648 if {[info exists pending_select] &&
2649 [info exists commitrow($curview,$pending_select)] &&
2650 $commitrow($curview,$pending_select) < $numcommits} {
2651 selectline $commitrow($curview,$pending_select) 1
2653 if {$selectfirst} {
2654 if {[info exists selectedline] || [info exists pending_select]} {
2655 set selectfirst 0
2656 } else {
2657 selectline 0 1
2658 set selectfirst 0
2663 proc layoutrows {row endrow last} {
2664 global rowidlist rowoffsets displayorder
2665 global uparrowlen downarrowlen maxwidth mingaplen
2666 global childlist parentlist
2667 global idrowranges linesegends
2668 global commitidx curview
2669 global idinlist rowchk rowrangelist
2671 set idlist [lindex $rowidlist $row]
2672 set offs [lindex $rowoffsets $row]
2673 while {$row < $endrow} {
2674 set id [lindex $displayorder $row]
2675 set oldolds {}
2676 set newolds {}
2677 foreach p [lindex $parentlist $row] {
2678 if {![info exists idinlist($p)]} {
2679 lappend newolds $p
2680 } elseif {!$idinlist($p)} {
2681 lappend oldolds $p
2684 set lse {}
2685 set nev [expr {[llength $idlist] + [llength $newolds]
2686 + [llength $oldolds] - $maxwidth + 1}]
2687 if {$nev > 0} {
2688 if {!$last &&
2689 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2690 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2691 set i [lindex $idlist $x]
2692 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2693 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2694 [expr {$row + $uparrowlen + $mingaplen}]]
2695 if {$r == 0} {
2696 set idlist [lreplace $idlist $x $x]
2697 set offs [lreplace $offs $x $x]
2698 set offs [incrange $offs $x 1]
2699 set idinlist($i) 0
2700 set rm1 [expr {$row - 1}]
2701 lappend lse $i
2702 lappend idrowranges($i) [lindex $displayorder $rm1]
2703 if {[incr nev -1] <= 0} break
2704 continue
2706 set rowchk($id) [expr {$row + $r}]
2709 lset rowidlist $row $idlist
2710 lset rowoffsets $row $offs
2712 lappend linesegends $lse
2713 set col [lsearch -exact $idlist $id]
2714 if {$col < 0} {
2715 set col [llength $idlist]
2716 lappend idlist $id
2717 lset rowidlist $row $idlist
2718 set z {}
2719 if {[lindex $childlist $row] ne {}} {
2720 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2721 unset idinlist($id)
2723 lappend offs $z
2724 lset rowoffsets $row $offs
2725 if {$z ne {}} {
2726 makeuparrow $id $col $row $z
2728 } else {
2729 unset idinlist($id)
2731 set ranges {}
2732 if {[info exists idrowranges($id)]} {
2733 set ranges $idrowranges($id)
2734 lappend ranges $id
2735 unset idrowranges($id)
2737 lappend rowrangelist $ranges
2738 incr row
2739 set offs [ntimes [llength $idlist] 0]
2740 set l [llength $newolds]
2741 set idlist [eval lreplace \$idlist $col $col $newolds]
2742 set o 0
2743 if {$l != 1} {
2744 set offs [lrange $offs 0 [expr {$col - 1}]]
2745 foreach x $newolds {
2746 lappend offs {}
2747 incr o -1
2749 incr o
2750 set tmp [expr {[llength $idlist] - [llength $offs]}]
2751 if {$tmp > 0} {
2752 set offs [concat $offs [ntimes $tmp $o]]
2754 } else {
2755 lset offs $col {}
2757 foreach i $newolds {
2758 set idinlist($i) 1
2759 set idrowranges($i) $id
2761 incr col $l
2762 foreach oid $oldolds {
2763 set idinlist($oid) 1
2764 set idlist [linsert $idlist $col $oid]
2765 set offs [linsert $offs $col $o]
2766 makeuparrow $oid $col $row $o
2767 incr col
2769 lappend rowidlist $idlist
2770 lappend rowoffsets $offs
2772 return $row
2775 proc addextraid {id row} {
2776 global displayorder commitrow commitinfo
2777 global commitidx commitlisted
2778 global parentlist childlist children curview
2780 incr commitidx($curview)
2781 lappend displayorder $id
2782 lappend commitlisted 0
2783 lappend parentlist {}
2784 set commitrow($curview,$id) $row
2785 readcommit $id
2786 if {![info exists commitinfo($id)]} {
2787 set commitinfo($id) {"No commit information available"}
2789 if {![info exists children($curview,$id)]} {
2790 set children($curview,$id) {}
2792 lappend childlist $children($curview,$id)
2795 proc layouttail {} {
2796 global rowidlist rowoffsets idinlist commitidx curview
2797 global idrowranges rowrangelist
2799 set row $commitidx($curview)
2800 set idlist [lindex $rowidlist $row]
2801 while {$idlist ne {}} {
2802 set col [expr {[llength $idlist] - 1}]
2803 set id [lindex $idlist $col]
2804 addextraid $id $row
2805 unset idinlist($id)
2806 lappend idrowranges($id) $row
2807 lappend rowrangelist $idrowranges($id)
2808 unset idrowranges($id)
2809 incr row
2810 set offs [ntimes $col 0]
2811 set idlist [lreplace $idlist $col $col]
2812 lappend rowidlist $idlist
2813 lappend rowoffsets $offs
2816 foreach id [array names idinlist] {
2817 unset idinlist($id)
2818 addextraid $id $row
2819 lset rowidlist $row [list $id]
2820 lset rowoffsets $row 0
2821 makeuparrow $id 0 $row 0
2822 lappend idrowranges($id) $row
2823 lappend rowrangelist $idrowranges($id)
2824 unset idrowranges($id)
2825 incr row
2826 lappend rowidlist {}
2827 lappend rowoffsets {}
2831 proc insert_pad {row col npad} {
2832 global rowidlist rowoffsets
2834 set pad [ntimes $npad {}]
2835 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2836 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2837 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2840 proc optimize_rows {row col endrow} {
2841 global rowidlist rowoffsets idrowranges displayorder
2843 for {} {$row < $endrow} {incr row} {
2844 set idlist [lindex $rowidlist $row]
2845 set offs [lindex $rowoffsets $row]
2846 set haspad 0
2847 for {} {$col < [llength $offs]} {incr col} {
2848 if {[lindex $idlist $col] eq {}} {
2849 set haspad 1
2850 continue
2852 set z [lindex $offs $col]
2853 if {$z eq {}} continue
2854 set isarrow 0
2855 set x0 [expr {$col + $z}]
2856 set y0 [expr {$row - 1}]
2857 set z0 [lindex $rowoffsets $y0 $x0]
2858 if {$z0 eq {}} {
2859 set id [lindex $idlist $col]
2860 set ranges [rowranges $id]
2861 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2862 set isarrow 1
2865 # Looking at lines from this row to the previous row,
2866 # make them go straight up if they end in an arrow on
2867 # the previous row; otherwise make them go straight up
2868 # or at 45 degrees.
2869 if {$z < -1 || ($z < 0 && $isarrow)} {
2870 # Line currently goes left too much;
2871 # insert pads in the previous row, then optimize it
2872 set npad [expr {-1 - $z + $isarrow}]
2873 set offs [incrange $offs $col $npad]
2874 insert_pad $y0 $x0 $npad
2875 if {$y0 > 0} {
2876 optimize_rows $y0 $x0 $row
2878 set z [lindex $offs $col]
2879 set x0 [expr {$col + $z}]
2880 set z0 [lindex $rowoffsets $y0 $x0]
2881 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2882 # Line currently goes right too much;
2883 # insert pads in this line and adjust the next's rowoffsets
2884 set npad [expr {$z - 1 + $isarrow}]
2885 set y1 [expr {$row + 1}]
2886 set offs2 [lindex $rowoffsets $y1]
2887 set x1 -1
2888 foreach z $offs2 {
2889 incr x1
2890 if {$z eq {} || $x1 + $z < $col} continue
2891 if {$x1 + $z > $col} {
2892 incr npad
2894 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2895 break
2897 set pad [ntimes $npad {}]
2898 set idlist [eval linsert \$idlist $col $pad]
2899 set tmp [eval linsert \$offs $col $pad]
2900 incr col $npad
2901 set offs [incrange $tmp $col [expr {-$npad}]]
2902 set z [lindex $offs $col]
2903 set haspad 1
2905 if {$z0 eq {} && !$isarrow} {
2906 # this line links to its first child on row $row-2
2907 set rm2 [expr {$row - 2}]
2908 set id [lindex $displayorder $rm2]
2909 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2910 if {$xc >= 0} {
2911 set z0 [expr {$xc - $x0}]
2914 # avoid lines jigging left then immediately right
2915 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2916 insert_pad $y0 $x0 1
2917 set offs [incrange $offs $col 1]
2918 optimize_rows $y0 [expr {$x0 + 1}] $row
2921 if {!$haspad} {
2922 set o {}
2923 # Find the first column that doesn't have a line going right
2924 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
2925 set o [lindex $offs $col]
2926 if {$o eq {}} {
2927 # check if this is the link to the first child
2928 set id [lindex $idlist $col]
2929 set ranges [rowranges $id]
2930 if {$ranges ne {} && $row == [lindex $ranges 0]} {
2931 # it is, work out offset to child
2932 set y0 [expr {$row - 1}]
2933 set id [lindex $displayorder $y0]
2934 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
2935 if {$x0 >= 0} {
2936 set o [expr {$x0 - $col}]
2940 if {$o eq {} || $o <= 0} break
2942 # Insert a pad at that column as long as it has a line and
2943 # isn't the last column, and adjust the next row' offsets
2944 if {$o ne {} && [incr col] < [llength $idlist]} {
2945 set y1 [expr {$row + 1}]
2946 set offs2 [lindex $rowoffsets $y1]
2947 set x1 -1
2948 foreach z $offs2 {
2949 incr x1
2950 if {$z eq {} || $x1 + $z < $col} continue
2951 lset rowoffsets $y1 [incrange $offs2 $x1 1]
2952 break
2954 set idlist [linsert $idlist $col {}]
2955 set tmp [linsert $offs $col {}]
2956 incr col
2957 set offs [incrange $tmp $col -1]
2960 lset rowidlist $row $idlist
2961 lset rowoffsets $row $offs
2962 set col 0
2966 proc xc {row col} {
2967 global canvx0 linespc
2968 return [expr {$canvx0 + $col * $linespc}]
2971 proc yc {row} {
2972 global canvy0 linespc
2973 return [expr {$canvy0 + $row * $linespc}]
2976 proc linewidth {id} {
2977 global thickerline lthickness
2979 set wid $lthickness
2980 if {[info exists thickerline] && $id eq $thickerline} {
2981 set wid [expr {2 * $lthickness}]
2983 return $wid
2986 proc rowranges {id} {
2987 global phase idrowranges commitrow rowlaidout rowrangelist curview
2989 set ranges {}
2990 if {$phase eq {} ||
2991 ([info exists commitrow($curview,$id)]
2992 && $commitrow($curview,$id) < $rowlaidout)} {
2993 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
2994 } elseif {[info exists idrowranges($id)]} {
2995 set ranges $idrowranges($id)
2997 set linenos {}
2998 foreach rid $ranges {
2999 lappend linenos $commitrow($curview,$rid)
3001 if {$linenos ne {}} {
3002 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3004 return $linenos
3007 proc drawlineseg {id i ranges} {
3008 global rowoffsets rowidlist
3009 global displayorder
3010 global canv colormap linespc
3011 global numcommits commitrow curview
3013 set downarrow 1
3014 if {[info exists commitrow($curview,$id)]
3015 && $commitrow($curview,$id) < $numcommits} {
3016 set downarrow [expr {$i < [llength $ranges] / 2 - 1}]
3017 } else {
3018 set downarrow 1
3020 set startrow [lindex $ranges [expr {2 * $i}]]
3021 set row [lindex $ranges [expr {2 * $i + 1}]]
3022 if {$startrow == $row} return
3023 assigncolor $id
3024 set coords {}
3025 set col [lsearch -exact [lindex $rowidlist $row] $id]
3026 if {$col < 0} {
3027 puts "oops: drawline: id $id not on row $row"
3028 return
3030 set lasto {}
3031 set ns 0
3032 while {1} {
3033 set o [lindex $rowoffsets $row $col]
3034 if {$o eq {}} break
3035 if {$o ne $lasto} {
3036 # changing direction
3037 set x [xc $row $col]
3038 set y [yc $row]
3039 lappend coords $x $y
3040 set lasto $o
3042 incr col $o
3043 incr row -1
3045 set x [xc $row $col]
3046 set y [yc $row]
3047 lappend coords $x $y
3048 if {$i == 0} {
3049 # draw the link to the first child as part of this line
3050 incr row -1
3051 set child [lindex $displayorder $row]
3052 set ccol [lsearch -exact [lindex $rowidlist $row] $child]
3053 if {$ccol >= 0} {
3054 set x [xc $row $ccol]
3055 set y [yc $row]
3056 if {$ccol < $col - 1} {
3057 lappend coords [xc $row [expr {$col - 1}]] [yc $row]
3058 } elseif {$ccol > $col + 1} {
3059 lappend coords [xc $row [expr {$col + 1}]] [yc $row]
3061 lappend coords $x $y
3064 if {[llength $coords] < 4} return
3065 if {$downarrow} {
3066 # This line has an arrow at the lower end: check if the arrow is
3067 # on a diagonal segment, and if so, work around the Tk 8.4
3068 # refusal to draw arrows on diagonal lines.
3069 set x0 [lindex $coords 0]
3070 set x1 [lindex $coords 2]
3071 if {$x0 != $x1} {
3072 set y0 [lindex $coords 1]
3073 set y1 [lindex $coords 3]
3074 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3075 # we have a nearby vertical segment, just trim off the diag bit
3076 set coords [lrange $coords 2 end]
3077 } else {
3078 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3079 set xi [expr {$x0 - $slope * $linespc / 2}]
3080 set yi [expr {$y0 - $linespc / 2}]
3081 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3085 set arrow [expr {2 * ($i > 0) + $downarrow}]
3086 set arrow [lindex {none first last both} $arrow]
3087 set t [$canv create line $coords -width [linewidth $id] \
3088 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3089 $canv lower $t
3090 bindline $t $id
3093 proc drawparentlinks {id row col olds} {
3094 global rowidlist canv colormap
3096 set row2 [expr {$row + 1}]
3097 set x [xc $row $col]
3098 set y [yc $row]
3099 set y2 [yc $row2]
3100 set ids [lindex $rowidlist $row2]
3101 # rmx = right-most X coord used
3102 set rmx 0
3103 foreach p $olds {
3104 set i [lsearch -exact $ids $p]
3105 if {$i < 0} {
3106 puts "oops, parent $p of $id not in list"
3107 continue
3109 set x2 [xc $row2 $i]
3110 if {$x2 > $rmx} {
3111 set rmx $x2
3113 set ranges [rowranges $p]
3114 if {$ranges ne {} && $row2 == [lindex $ranges 0]
3115 && $row2 < [lindex $ranges 1]} {
3116 # drawlineseg will do this one for us
3117 continue
3119 assigncolor $p
3120 # should handle duplicated parents here...
3121 set coords [list $x $y]
3122 if {$i < $col - 1} {
3123 lappend coords [xc $row [expr {$i + 1}]] $y
3124 } elseif {$i > $col + 1} {
3125 lappend coords [xc $row [expr {$i - 1}]] $y
3127 lappend coords $x2 $y2
3128 set t [$canv create line $coords -width [linewidth $p] \
3129 -fill $colormap($p) -tags lines.$p]
3130 $canv lower $t
3131 bindline $t $p
3133 return $rmx
3136 proc drawlines {id} {
3137 global colormap canv
3138 global idrangedrawn
3139 global children iddrawn commitrow rowidlist curview
3141 $canv delete lines.$id
3142 set ranges [rowranges $id]
3143 set nr [expr {[llength $ranges] / 2}]
3144 for {set i 0} {$i < $nr} {incr i} {
3145 if {[info exists idrangedrawn($id,$i)]} {
3146 drawlineseg $id $i $ranges
3149 foreach child $children($curview,$id) {
3150 if {[info exists iddrawn($child)]} {
3151 set row $commitrow($curview,$child)
3152 set col [lsearch -exact [lindex $rowidlist $row] $child]
3153 if {$col >= 0} {
3154 drawparentlinks $child $row $col [list $id]
3160 proc drawcmittext {id row col rmx} {
3161 global linespc canv canv2 canv3 canvy0 fgcolor
3162 global commitlisted commitinfo rowidlist
3163 global rowtextx idpos idtags idheads idotherrefs
3164 global linehtag linentag linedtag
3165 global mainfont canvxmax boldrows boldnamerows fgcolor
3167 set ofill [expr {[lindex $commitlisted $row]? "blue": "white"}]
3168 set x [xc $row $col]
3169 set y [yc $row]
3170 set orad [expr {$linespc / 3}]
3171 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3172 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3173 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3174 $canv raise $t
3175 $canv bind $t <1> {selcanvline {} %x %y}
3176 set xt [xc $row [llength [lindex $rowidlist $row]]]
3177 if {$xt < $rmx} {
3178 set xt $rmx
3180 set rowtextx($row) $xt
3181 set idpos($id) [list $x $xt $y]
3182 if {[info exists idtags($id)] || [info exists idheads($id)]
3183 || [info exists idotherrefs($id)]} {
3184 set xt [drawtags $id $x $xt $y]
3186 set headline [lindex $commitinfo($id) 0]
3187 set name [lindex $commitinfo($id) 1]
3188 set date [lindex $commitinfo($id) 2]
3189 set date [formatdate $date]
3190 set font $mainfont
3191 set nfont $mainfont
3192 set isbold [ishighlighted $row]
3193 if {$isbold > 0} {
3194 lappend boldrows $row
3195 lappend font bold
3196 if {$isbold > 1} {
3197 lappend boldnamerows $row
3198 lappend nfont bold
3201 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3202 -text $headline -font $font -tags text]
3203 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3204 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3205 -text $name -font $nfont -tags text]
3206 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3207 -text $date -font $mainfont -tags text]
3208 set xr [expr {$xt + [font measure $mainfont $headline]}]
3209 if {$xr > $canvxmax} {
3210 set canvxmax $xr
3211 setcanvscroll
3215 proc drawcmitrow {row} {
3216 global displayorder rowidlist
3217 global idrangedrawn iddrawn
3218 global commitinfo parentlist numcommits
3219 global filehighlight fhighlights findstring nhighlights
3220 global hlview vhighlights
3221 global highlight_related rhighlights
3223 if {$row >= $numcommits} return
3224 foreach id [lindex $rowidlist $row] {
3225 if {$id eq {}} continue
3226 set i -1
3227 set ranges [rowranges $id]
3228 foreach {s e} $ranges {
3229 incr i
3230 if {$row < $s} continue
3231 if {$e eq {}} break
3232 if {$row <= $e} {
3233 if {$e < $numcommits && ![info exists idrangedrawn($id,$i)]} {
3234 drawlineseg $id $i $ranges
3235 set idrangedrawn($id,$i) 1
3237 break
3242 set id [lindex $displayorder $row]
3243 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3244 askvhighlight $row $id
3246 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3247 askfilehighlight $row $id
3249 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3250 askfindhighlight $row $id
3252 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3253 askrelhighlight $row $id
3255 if {[info exists iddrawn($id)]} return
3256 set col [lsearch -exact [lindex $rowidlist $row] $id]
3257 if {$col < 0} {
3258 puts "oops, row $row id $id not in list"
3259 return
3261 if {![info exists commitinfo($id)]} {
3262 getcommit $id
3264 assigncolor $id
3265 set olds [lindex $parentlist $row]
3266 if {$olds ne {}} {
3267 set rmx [drawparentlinks $id $row $col $olds]
3268 } else {
3269 set rmx 0
3271 drawcmittext $id $row $col $rmx
3272 set iddrawn($id) 1
3275 proc drawfrac {f0 f1} {
3276 global numcommits canv
3277 global linespc
3279 set ymax [lindex [$canv cget -scrollregion] 3]
3280 if {$ymax eq {} || $ymax == 0} return
3281 set y0 [expr {int($f0 * $ymax)}]
3282 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3283 if {$row < 0} {
3284 set row 0
3286 set y1 [expr {int($f1 * $ymax)}]
3287 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3288 if {$endrow >= $numcommits} {
3289 set endrow [expr {$numcommits - 1}]
3291 for {} {$row <= $endrow} {incr row} {
3292 drawcmitrow $row
3296 proc drawvisible {} {
3297 global canv
3298 eval drawfrac [$canv yview]
3301 proc clear_display {} {
3302 global iddrawn idrangedrawn
3303 global vhighlights fhighlights nhighlights rhighlights
3305 allcanvs delete all
3306 catch {unset iddrawn}
3307 catch {unset idrangedrawn}
3308 catch {unset vhighlights}
3309 catch {unset fhighlights}
3310 catch {unset nhighlights}
3311 catch {unset rhighlights}
3314 proc findcrossings {id} {
3315 global rowidlist parentlist numcommits rowoffsets displayorder
3317 set cross {}
3318 set ccross {}
3319 foreach {s e} [rowranges $id] {
3320 if {$e >= $numcommits} {
3321 set e [expr {$numcommits - 1}]
3323 if {$e <= $s} continue
3324 set x [lsearch -exact [lindex $rowidlist $e] $id]
3325 if {$x < 0} {
3326 puts "findcrossings: oops, no [shortids $id] in row $e"
3327 continue
3329 for {set row $e} {[incr row -1] >= $s} {} {
3330 set olds [lindex $parentlist $row]
3331 set kid [lindex $displayorder $row]
3332 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3333 if {$kidx < 0} continue
3334 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3335 foreach p $olds {
3336 set px [lsearch -exact $nextrow $p]
3337 if {$px < 0} continue
3338 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3339 if {[lsearch -exact $ccross $p] >= 0} continue
3340 if {$x == $px + ($kidx < $px? -1: 1)} {
3341 lappend ccross $p
3342 } elseif {[lsearch -exact $cross $p] < 0} {
3343 lappend cross $p
3347 set inc [lindex $rowoffsets $row $x]
3348 if {$inc eq {}} break
3349 incr x $inc
3352 return [concat $ccross {{}} $cross]
3355 proc assigncolor {id} {
3356 global colormap colors nextcolor
3357 global commitrow parentlist children children curview
3359 if {[info exists colormap($id)]} return
3360 set ncolors [llength $colors]
3361 if {[info exists children($curview,$id)]} {
3362 set kids $children($curview,$id)
3363 } else {
3364 set kids {}
3366 if {[llength $kids] == 1} {
3367 set child [lindex $kids 0]
3368 if {[info exists colormap($child)]
3369 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3370 set colormap($id) $colormap($child)
3371 return
3374 set badcolors {}
3375 set origbad {}
3376 foreach x [findcrossings $id] {
3377 if {$x eq {}} {
3378 # delimiter between corner crossings and other crossings
3379 if {[llength $badcolors] >= $ncolors - 1} break
3380 set origbad $badcolors
3382 if {[info exists colormap($x)]
3383 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3384 lappend badcolors $colormap($x)
3387 if {[llength $badcolors] >= $ncolors} {
3388 set badcolors $origbad
3390 set origbad $badcolors
3391 if {[llength $badcolors] < $ncolors - 1} {
3392 foreach child $kids {
3393 if {[info exists colormap($child)]
3394 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3395 lappend badcolors $colormap($child)
3397 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3398 if {[info exists colormap($p)]
3399 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3400 lappend badcolors $colormap($p)
3404 if {[llength $badcolors] >= $ncolors} {
3405 set badcolors $origbad
3408 for {set i 0} {$i <= $ncolors} {incr i} {
3409 set c [lindex $colors $nextcolor]
3410 if {[incr nextcolor] >= $ncolors} {
3411 set nextcolor 0
3413 if {[lsearch -exact $badcolors $c]} break
3415 set colormap($id) $c
3418 proc bindline {t id} {
3419 global canv
3421 $canv bind $t <Enter> "lineenter %x %y $id"
3422 $canv bind $t <Motion> "linemotion %x %y $id"
3423 $canv bind $t <Leave> "lineleave $id"
3424 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3427 proc drawtags {id x xt y1} {
3428 global idtags idheads idotherrefs mainhead
3429 global linespc lthickness
3430 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3432 set marks {}
3433 set ntags 0
3434 set nheads 0
3435 if {[info exists idtags($id)]} {
3436 set marks $idtags($id)
3437 set ntags [llength $marks]
3439 if {[info exists idheads($id)]} {
3440 set marks [concat $marks $idheads($id)]
3441 set nheads [llength $idheads($id)]
3443 if {[info exists idotherrefs($id)]} {
3444 set marks [concat $marks $idotherrefs($id)]
3446 if {$marks eq {}} {
3447 return $xt
3450 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3451 set yt [expr {$y1 - 0.5 * $linespc}]
3452 set yb [expr {$yt + $linespc - 1}]
3453 set xvals {}
3454 set wvals {}
3455 set i -1
3456 foreach tag $marks {
3457 incr i
3458 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3459 set wid [font measure [concat $mainfont bold] $tag]
3460 } else {
3461 set wid [font measure $mainfont $tag]
3463 lappend xvals $xt
3464 lappend wvals $wid
3465 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3467 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3468 -width $lthickness -fill black -tags tag.$id]
3469 $canv lower $t
3470 foreach tag $marks x $xvals wid $wvals {
3471 set xl [expr {$x + $delta}]
3472 set xr [expr {$x + $delta + $wid + $lthickness}]
3473 set font $mainfont
3474 if {[incr ntags -1] >= 0} {
3475 # draw a tag
3476 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3477 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3478 -width 1 -outline black -fill yellow -tags tag.$id]
3479 $canv bind $t <1> [list showtag $tag 1]
3480 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3481 } else {
3482 # draw a head or other ref
3483 if {[incr nheads -1] >= 0} {
3484 set col green
3485 if {$tag eq $mainhead} {
3486 lappend font bold
3488 } else {
3489 set col "#ddddff"
3491 set xl [expr {$xl - $delta/2}]
3492 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3493 -width 1 -outline black -fill $col -tags tag.$id
3494 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3495 set rwid [font measure $mainfont $remoteprefix]
3496 set xi [expr {$x + 1}]
3497 set yti [expr {$yt + 1}]
3498 set xri [expr {$x + $rwid}]
3499 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3500 -width 0 -fill "#ffddaa" -tags tag.$id
3503 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3504 -font $font -tags [list tag.$id text]]
3505 if {$ntags >= 0} {
3506 $canv bind $t <1> [list showtag $tag 1]
3507 } elseif {$nheads >= 0} {
3508 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3511 return $xt
3514 proc xcoord {i level ln} {
3515 global canvx0 xspc1 xspc2
3517 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3518 if {$i > 0 && $i == $level} {
3519 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3520 } elseif {$i > $level} {
3521 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3523 return $x
3526 proc show_status {msg} {
3527 global canv mainfont fgcolor
3529 clear_display
3530 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3531 -tags text -fill $fgcolor
3534 # Insert a new commit as the child of the commit on row $row.
3535 # The new commit will be displayed on row $row and the commits
3536 # on that row and below will move down one row.
3537 proc insertrow {row newcmit} {
3538 global displayorder parentlist childlist commitlisted
3539 global commitrow curview rowidlist rowoffsets numcommits
3540 global rowrangelist rowlaidout rowoptim numcommits
3541 global linesegends selectedline
3543 if {$row >= $numcommits} {
3544 puts "oops, inserting new row $row but only have $numcommits rows"
3545 return
3547 set p [lindex $displayorder $row]
3548 set displayorder [linsert $displayorder $row $newcmit]
3549 set parentlist [linsert $parentlist $row $p]
3550 set kids [lindex $childlist $row]
3551 lappend kids $newcmit
3552 lset childlist $row $kids
3553 set childlist [linsert $childlist $row {}]
3554 set commitlisted [linsert $commitlisted $row 1]
3555 set l [llength $displayorder]
3556 for {set r $row} {$r < $l} {incr r} {
3557 set id [lindex $displayorder $r]
3558 set commitrow($curview,$id) $r
3561 set idlist [lindex $rowidlist $row]
3562 set offs [lindex $rowoffsets $row]
3563 set newoffs {}
3564 foreach x $idlist {
3565 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3566 lappend newoffs {}
3567 } else {
3568 lappend newoffs 0
3571 if {[llength $kids] == 1} {
3572 set col [lsearch -exact $idlist $p]
3573 lset idlist $col $newcmit
3574 } else {
3575 set col [llength $idlist]
3576 lappend idlist $newcmit
3577 lappend offs {}
3578 lset rowoffsets $row $offs
3580 set rowidlist [linsert $rowidlist $row $idlist]
3581 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3583 set rowrangelist [linsert $rowrangelist $row {}]
3584 if {[llength $kids] > 1} {
3585 set rp1 [expr {$row + 1}]
3586 set ranges [lindex $rowrangelist $rp1]
3587 if {$ranges eq {}} {
3588 set ranges [list $newcmit $p]
3589 } elseif {[lindex $ranges end-1] eq $p} {
3590 lset ranges end-1 $newcmit
3592 lset rowrangelist $rp1 $ranges
3595 set linesegends [linsert $linesegends $row {}]
3597 incr rowlaidout
3598 incr rowoptim
3599 incr numcommits
3601 if {[info exists selectedline] && $selectedline >= $row} {
3602 incr selectedline
3604 redisplay
3607 # Don't change the text pane cursor if it is currently the hand cursor,
3608 # showing that we are over a sha1 ID link.
3609 proc settextcursor {c} {
3610 global ctext curtextcursor
3612 if {[$ctext cget -cursor] == $curtextcursor} {
3613 $ctext config -cursor $c
3615 set curtextcursor $c
3618 proc nowbusy {what} {
3619 global isbusy
3621 if {[array names isbusy] eq {}} {
3622 . config -cursor watch
3623 settextcursor watch
3625 set isbusy($what) 1
3628 proc notbusy {what} {
3629 global isbusy maincursor textcursor
3631 catch {unset isbusy($what)}
3632 if {[array names isbusy] eq {}} {
3633 . config -cursor $maincursor
3634 settextcursor $textcursor
3638 proc findmatches {f} {
3639 global findtype foundstring foundstrlen
3640 if {$findtype == "Regexp"} {
3641 set matches [regexp -indices -all -inline $foundstring $f]
3642 } else {
3643 if {$findtype == "IgnCase"} {
3644 set str [string tolower $f]
3645 } else {
3646 set str $f
3648 set matches {}
3649 set i 0
3650 while {[set j [string first $foundstring $str $i]] >= 0} {
3651 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
3652 set i [expr {$j + $foundstrlen}]
3655 return $matches
3658 proc dofind {} {
3659 global findtype findloc findstring markedmatches commitinfo
3660 global numcommits displayorder linehtag linentag linedtag
3661 global mainfont canv canv2 canv3 selectedline
3662 global matchinglines foundstring foundstrlen matchstring
3663 global commitdata
3665 stopfindproc
3666 unmarkmatches
3667 cancel_next_highlight
3668 focus .
3669 set matchinglines {}
3670 if {$findtype == "IgnCase"} {
3671 set foundstring [string tolower $findstring]
3672 } else {
3673 set foundstring $findstring
3675 set foundstrlen [string length $findstring]
3676 if {$foundstrlen == 0} return
3677 regsub -all {[*?\[\\]} $foundstring {\\&} matchstring
3678 set matchstring "*$matchstring*"
3679 if {![info exists selectedline]} {
3680 set oldsel -1
3681 } else {
3682 set oldsel $selectedline
3684 set didsel 0
3685 set fldtypes {Headline Author Date Committer CDate Comments}
3686 set l -1
3687 foreach id $displayorder {
3688 set d $commitdata($id)
3689 incr l
3690 if {$findtype == "Regexp"} {
3691 set doesmatch [regexp $foundstring $d]
3692 } elseif {$findtype == "IgnCase"} {
3693 set doesmatch [string match -nocase $matchstring $d]
3694 } else {
3695 set doesmatch [string match $matchstring $d]
3697 if {!$doesmatch} continue
3698 if {![info exists commitinfo($id)]} {
3699 getcommit $id
3701 set info $commitinfo($id)
3702 set doesmatch 0
3703 foreach f $info ty $fldtypes {
3704 if {$findloc != "All fields" && $findloc != $ty} {
3705 continue
3707 set matches [findmatches $f]
3708 if {$matches == {}} continue
3709 set doesmatch 1
3710 if {$ty == "Headline"} {
3711 drawcmitrow $l
3712 markmatches $canv $l $f $linehtag($l) $matches $mainfont
3713 } elseif {$ty == "Author"} {
3714 drawcmitrow $l
3715 markmatches $canv2 $l $f $linentag($l) $matches $mainfont
3716 } elseif {$ty == "Date"} {
3717 drawcmitrow $l
3718 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
3721 if {$doesmatch} {
3722 lappend matchinglines $l
3723 if {!$didsel && $l > $oldsel} {
3724 findselectline $l
3725 set didsel 1
3729 if {$matchinglines == {}} {
3730 bell
3731 } elseif {!$didsel} {
3732 findselectline [lindex $matchinglines 0]
3736 proc findselectline {l} {
3737 global findloc commentend ctext
3738 selectline $l 1
3739 if {$findloc == "All fields" || $findloc == "Comments"} {
3740 # highlight the matches in the comments
3741 set f [$ctext get 1.0 $commentend]
3742 set matches [findmatches $f]
3743 foreach match $matches {
3744 set start [lindex $match 0]
3745 set end [expr {[lindex $match 1] + 1}]
3746 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
3751 proc findnext {restart} {
3752 global matchinglines selectedline
3753 if {![info exists matchinglines]} {
3754 if {$restart} {
3755 dofind
3757 return
3759 if {![info exists selectedline]} return
3760 foreach l $matchinglines {
3761 if {$l > $selectedline} {
3762 findselectline $l
3763 return
3766 bell
3769 proc findprev {} {
3770 global matchinglines selectedline
3771 if {![info exists matchinglines]} {
3772 dofind
3773 return
3775 if {![info exists selectedline]} return
3776 set prev {}
3777 foreach l $matchinglines {
3778 if {$l >= $selectedline} break
3779 set prev $l
3781 if {$prev != {}} {
3782 findselectline $prev
3783 } else {
3784 bell
3788 proc stopfindproc {{done 0}} {
3789 global findprocpid findprocfile findids
3790 global ctext findoldcursor phase maincursor textcursor
3791 global findinprogress
3793 catch {unset findids}
3794 if {[info exists findprocpid]} {
3795 if {!$done} {
3796 catch {exec kill $findprocpid}
3798 catch {close $findprocfile}
3799 unset findprocpid
3801 catch {unset findinprogress}
3802 notbusy find
3805 # mark a commit as matching by putting a yellow background
3806 # behind the headline
3807 proc markheadline {l id} {
3808 global canv mainfont linehtag
3810 drawcmitrow $l
3811 set bbox [$canv bbox $linehtag($l)]
3812 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
3813 $canv lower $t
3816 # mark the bits of a headline, author or date that match a find string
3817 proc markmatches {canv l str tag matches font} {
3818 set bbox [$canv bbox $tag]
3819 set x0 [lindex $bbox 0]
3820 set y0 [lindex $bbox 1]
3821 set y1 [lindex $bbox 3]
3822 foreach match $matches {
3823 set start [lindex $match 0]
3824 set end [lindex $match 1]
3825 if {$start > $end} continue
3826 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
3827 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
3828 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
3829 [expr {$x0+$xlen+2}] $y1 \
3830 -outline {} -tags matches -fill yellow]
3831 $canv lower $t
3835 proc unmarkmatches {} {
3836 global matchinglines findids
3837 allcanvs delete matches
3838 catch {unset matchinglines}
3839 catch {unset findids}
3842 proc selcanvline {w x y} {
3843 global canv canvy0 ctext linespc
3844 global rowtextx
3845 set ymax [lindex [$canv cget -scrollregion] 3]
3846 if {$ymax == {}} return
3847 set yfrac [lindex [$canv yview] 0]
3848 set y [expr {$y + $yfrac * $ymax}]
3849 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
3850 if {$l < 0} {
3851 set l 0
3853 if {$w eq $canv} {
3854 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
3856 unmarkmatches
3857 selectline $l 1
3860 proc commit_descriptor {p} {
3861 global commitinfo
3862 if {![info exists commitinfo($p)]} {
3863 getcommit $p
3865 set l "..."
3866 if {[llength $commitinfo($p)] > 1} {
3867 set l [lindex $commitinfo($p) 0]
3869 return "$p ($l)\n"
3872 # append some text to the ctext widget, and make any SHA1 ID
3873 # that we know about be a clickable link.
3874 proc appendwithlinks {text tags} {
3875 global ctext commitrow linknum curview
3877 set start [$ctext index "end - 1c"]
3878 $ctext insert end $text $tags
3879 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
3880 foreach l $links {
3881 set s [lindex $l 0]
3882 set e [lindex $l 1]
3883 set linkid [string range $text $s $e]
3884 if {![info exists commitrow($curview,$linkid)]} continue
3885 incr e
3886 $ctext tag add link "$start + $s c" "$start + $e c"
3887 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
3888 $ctext tag bind link$linknum <1> \
3889 [list selectline $commitrow($curview,$linkid) 1]
3890 incr linknum
3892 $ctext tag conf link -foreground blue -underline 1
3893 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3894 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3897 proc viewnextline {dir} {
3898 global canv linespc
3900 $canv delete hover
3901 set ymax [lindex [$canv cget -scrollregion] 3]
3902 set wnow [$canv yview]
3903 set wtop [expr {[lindex $wnow 0] * $ymax}]
3904 set newtop [expr {$wtop + $dir * $linespc}]
3905 if {$newtop < 0} {
3906 set newtop 0
3907 } elseif {$newtop > $ymax} {
3908 set newtop $ymax
3910 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3913 # add a list of tag or branch names at position pos
3914 # returns the number of names inserted
3915 proc appendrefs {pos ids var} {
3916 global ctext commitrow linknum curview $var maxrefs
3918 if {[catch {$ctext index $pos}]} {
3919 return 0
3921 $ctext conf -state normal
3922 $ctext delete $pos "$pos lineend"
3923 set tags {}
3924 foreach id $ids {
3925 foreach tag [set $var\($id\)] {
3926 lappend tags [list $tag $id]
3929 if {[llength $tags] > $maxrefs} {
3930 $ctext insert $pos "many ([llength $tags])"
3931 } else {
3932 set tags [lsort -index 0 -decreasing $tags]
3933 set sep {}
3934 foreach ti $tags {
3935 set id [lindex $ti 1]
3936 set lk link$linknum
3937 incr linknum
3938 $ctext tag delete $lk
3939 $ctext insert $pos $sep
3940 $ctext insert $pos [lindex $ti 0] $lk
3941 if {[info exists commitrow($curview,$id)]} {
3942 $ctext tag conf $lk -foreground blue
3943 $ctext tag bind $lk <1> \
3944 [list selectline $commitrow($curview,$id) 1]
3945 $ctext tag conf $lk -underline 1
3946 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
3947 $ctext tag bind $lk <Leave> \
3948 { %W configure -cursor $curtextcursor }
3950 set sep ", "
3953 $ctext conf -state disabled
3954 return [llength $tags]
3957 # called when we have finished computing the nearby tags
3958 proc dispneartags {delay} {
3959 global selectedline currentid showneartags tagphase
3961 if {![info exists selectedline] || !$showneartags} return
3962 after cancel dispnexttag
3963 if {$delay} {
3964 after 200 dispnexttag
3965 set tagphase -1
3966 } else {
3967 after idle dispnexttag
3968 set tagphase 0
3972 proc dispnexttag {} {
3973 global selectedline currentid showneartags tagphase ctext
3975 if {![info exists selectedline] || !$showneartags} return
3976 switch -- $tagphase {
3978 set dtags [desctags $currentid]
3979 if {$dtags ne {}} {
3980 appendrefs precedes $dtags idtags
3984 set atags [anctags $currentid]
3985 if {$atags ne {}} {
3986 appendrefs follows $atags idtags
3990 set dheads [descheads $currentid]
3991 if {$dheads ne {}} {
3992 if {[appendrefs branch $dheads idheads] > 1
3993 && [$ctext get "branch -3c"] eq "h"} {
3994 # turn "Branch" into "Branches"
3995 $ctext conf -state normal
3996 $ctext insert "branch -2c" "es"
3997 $ctext conf -state disabled
4002 if {[incr tagphase] <= 2} {
4003 after idle dispnexttag
4007 proc selectline {l isnew} {
4008 global canv canv2 canv3 ctext commitinfo selectedline
4009 global displayorder linehtag linentag linedtag
4010 global canvy0 linespc parentlist childlist
4011 global currentid sha1entry
4012 global commentend idtags linknum
4013 global mergemax numcommits pending_select
4014 global cmitmode showneartags allcommits
4016 catch {unset pending_select}
4017 $canv delete hover
4018 normalline
4019 cancel_next_highlight
4020 if {$l < 0 || $l >= $numcommits} return
4021 set y [expr {$canvy0 + $l * $linespc}]
4022 set ymax [lindex [$canv cget -scrollregion] 3]
4023 set ytop [expr {$y - $linespc - 1}]
4024 set ybot [expr {$y + $linespc + 1}]
4025 set wnow [$canv yview]
4026 set wtop [expr {[lindex $wnow 0] * $ymax}]
4027 set wbot [expr {[lindex $wnow 1] * $ymax}]
4028 set wh [expr {$wbot - $wtop}]
4029 set newtop $wtop
4030 if {$ytop < $wtop} {
4031 if {$ybot < $wtop} {
4032 set newtop [expr {$y - $wh / 2.0}]
4033 } else {
4034 set newtop $ytop
4035 if {$newtop > $wtop - $linespc} {
4036 set newtop [expr {$wtop - $linespc}]
4039 } elseif {$ybot > $wbot} {
4040 if {$ytop > $wbot} {
4041 set newtop [expr {$y - $wh / 2.0}]
4042 } else {
4043 set newtop [expr {$ybot - $wh}]
4044 if {$newtop < $wtop + $linespc} {
4045 set newtop [expr {$wtop + $linespc}]
4049 if {$newtop != $wtop} {
4050 if {$newtop < 0} {
4051 set newtop 0
4053 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4054 drawvisible
4057 if {![info exists linehtag($l)]} return
4058 $canv delete secsel
4059 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4060 -tags secsel -fill [$canv cget -selectbackground]]
4061 $canv lower $t
4062 $canv2 delete secsel
4063 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4064 -tags secsel -fill [$canv2 cget -selectbackground]]
4065 $canv2 lower $t
4066 $canv3 delete secsel
4067 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4068 -tags secsel -fill [$canv3 cget -selectbackground]]
4069 $canv3 lower $t
4071 if {$isnew} {
4072 addtohistory [list selectline $l 0]
4075 set selectedline $l
4077 set id [lindex $displayorder $l]
4078 set currentid $id
4079 $sha1entry delete 0 end
4080 $sha1entry insert 0 $id
4081 $sha1entry selection from 0
4082 $sha1entry selection to end
4083 rhighlight_sel $id
4085 $ctext conf -state normal
4086 clear_ctext
4087 set linknum 0
4088 set info $commitinfo($id)
4089 set date [formatdate [lindex $info 2]]
4090 $ctext insert end "Author: [lindex $info 1] $date\n"
4091 set date [formatdate [lindex $info 4]]
4092 $ctext insert end "Committer: [lindex $info 3] $date\n"
4093 if {[info exists idtags($id)]} {
4094 $ctext insert end "Tags:"
4095 foreach tag $idtags($id) {
4096 $ctext insert end " $tag"
4098 $ctext insert end "\n"
4101 set headers {}
4102 set olds [lindex $parentlist $l]
4103 if {[llength $olds] > 1} {
4104 set np 0
4105 foreach p $olds {
4106 if {$np >= $mergemax} {
4107 set tag mmax
4108 } else {
4109 set tag m$np
4111 $ctext insert end "Parent: " $tag
4112 appendwithlinks [commit_descriptor $p] {}
4113 incr np
4115 } else {
4116 foreach p $olds {
4117 append headers "Parent: [commit_descriptor $p]"
4121 foreach c [lindex $childlist $l] {
4122 append headers "Child: [commit_descriptor $c]"
4125 # make anything that looks like a SHA1 ID be a clickable link
4126 appendwithlinks $headers {}
4127 if {$showneartags} {
4128 if {![info exists allcommits]} {
4129 getallcommits
4131 $ctext insert end "Branch: "
4132 $ctext mark set branch "end -1c"
4133 $ctext mark gravity branch left
4134 $ctext insert end "\nFollows: "
4135 $ctext mark set follows "end -1c"
4136 $ctext mark gravity follows left
4137 $ctext insert end "\nPrecedes: "
4138 $ctext mark set precedes "end -1c"
4139 $ctext mark gravity precedes left
4140 $ctext insert end "\n"
4141 dispneartags 1
4143 $ctext insert end "\n"
4144 set comment [lindex $info 5]
4145 if {[string first "\r" $comment] >= 0} {
4146 set comment [string map {"\r" "\n "} $comment]
4148 appendwithlinks $comment {comment}
4150 $ctext tag delete Comments
4151 $ctext tag remove found 1.0 end
4152 $ctext conf -state disabled
4153 set commentend [$ctext index "end - 1c"]
4155 init_flist "Comments"
4156 if {$cmitmode eq "tree"} {
4157 gettree $id
4158 } elseif {[llength $olds] <= 1} {
4159 startdiff $id
4160 } else {
4161 mergediff $id $l
4165 proc selfirstline {} {
4166 unmarkmatches
4167 selectline 0 1
4170 proc sellastline {} {
4171 global numcommits
4172 unmarkmatches
4173 set l [expr {$numcommits - 1}]
4174 selectline $l 1
4177 proc selnextline {dir} {
4178 global selectedline
4179 if {![info exists selectedline]} return
4180 set l [expr {$selectedline + $dir}]
4181 unmarkmatches
4182 selectline $l 1
4185 proc selnextpage {dir} {
4186 global canv linespc selectedline numcommits
4188 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4189 if {$lpp < 1} {
4190 set lpp 1
4192 allcanvs yview scroll [expr {$dir * $lpp}] units
4193 drawvisible
4194 if {![info exists selectedline]} return
4195 set l [expr {$selectedline + $dir * $lpp}]
4196 if {$l < 0} {
4197 set l 0
4198 } elseif {$l >= $numcommits} {
4199 set l [expr $numcommits - 1]
4201 unmarkmatches
4202 selectline $l 1
4205 proc unselectline {} {
4206 global selectedline currentid
4208 catch {unset selectedline}
4209 catch {unset currentid}
4210 allcanvs delete secsel
4211 rhighlight_none
4212 cancel_next_highlight
4215 proc reselectline {} {
4216 global selectedline
4218 if {[info exists selectedline]} {
4219 selectline $selectedline 0
4223 proc addtohistory {cmd} {
4224 global history historyindex curview
4226 set elt [list $curview $cmd]
4227 if {$historyindex > 0
4228 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4229 return
4232 if {$historyindex < [llength $history]} {
4233 set history [lreplace $history $historyindex end $elt]
4234 } else {
4235 lappend history $elt
4237 incr historyindex
4238 if {$historyindex > 1} {
4239 .tf.bar.leftbut conf -state normal
4240 } else {
4241 .tf.bar.leftbut conf -state disabled
4243 .tf.bar.rightbut conf -state disabled
4246 proc godo {elt} {
4247 global curview
4249 set view [lindex $elt 0]
4250 set cmd [lindex $elt 1]
4251 if {$curview != $view} {
4252 showview $view
4254 eval $cmd
4257 proc goback {} {
4258 global history historyindex
4260 if {$historyindex > 1} {
4261 incr historyindex -1
4262 godo [lindex $history [expr {$historyindex - 1}]]
4263 .tf.bar.rightbut conf -state normal
4265 if {$historyindex <= 1} {
4266 .tf.bar.leftbut conf -state disabled
4270 proc goforw {} {
4271 global history historyindex
4273 if {$historyindex < [llength $history]} {
4274 set cmd [lindex $history $historyindex]
4275 incr historyindex
4276 godo $cmd
4277 .tf.bar.leftbut conf -state normal
4279 if {$historyindex >= [llength $history]} {
4280 .tf.bar.rightbut conf -state disabled
4284 proc gettree {id} {
4285 global treefilelist treeidlist diffids diffmergeid treepending
4287 set diffids $id
4288 catch {unset diffmergeid}
4289 if {![info exists treefilelist($id)]} {
4290 if {![info exists treepending]} {
4291 if {[catch {set gtf [open [concat | git ls-tree -r $id] r]}]} {
4292 return
4294 set treepending $id
4295 set treefilelist($id) {}
4296 set treeidlist($id) {}
4297 fconfigure $gtf -blocking 0
4298 filerun $gtf [list gettreeline $gtf $id]
4300 } else {
4301 setfilelist $id
4305 proc gettreeline {gtf id} {
4306 global treefilelist treeidlist treepending cmitmode diffids
4308 set nl 0
4309 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4310 set tl [split $line "\t"]
4311 if {[lindex $tl 0 1] ne "blob"} continue
4312 set sha1 [lindex $tl 0 2]
4313 set fname [lindex $tl 1]
4314 if {[string index $fname 0] eq "\""} {
4315 set fname [lindex $fname 0]
4317 lappend treeidlist($id) $sha1
4318 lappend treefilelist($id) $fname
4320 if {![eof $gtf]} {
4321 return [expr {$nl >= 1000? 2: 1}]
4323 close $gtf
4324 unset treepending
4325 if {$cmitmode ne "tree"} {
4326 if {![info exists diffmergeid]} {
4327 gettreediffs $diffids
4329 } elseif {$id ne $diffids} {
4330 gettree $diffids
4331 } else {
4332 setfilelist $id
4334 return 0
4337 proc showfile {f} {
4338 global treefilelist treeidlist diffids
4339 global ctext commentend
4341 set i [lsearch -exact $treefilelist($diffids) $f]
4342 if {$i < 0} {
4343 puts "oops, $f not in list for id $diffids"
4344 return
4346 set blob [lindex $treeidlist($diffids) $i]
4347 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4348 puts "oops, error reading blob $blob: $err"
4349 return
4351 fconfigure $bf -blocking 0
4352 filerun $bf [list getblobline $bf $diffids]
4353 $ctext config -state normal
4354 clear_ctext $commentend
4355 $ctext insert end "\n"
4356 $ctext insert end "$f\n" filesep
4357 $ctext config -state disabled
4358 $ctext yview $commentend
4361 proc getblobline {bf id} {
4362 global diffids cmitmode ctext
4364 if {$id ne $diffids || $cmitmode ne "tree"} {
4365 catch {close $bf}
4366 return 0
4368 $ctext config -state normal
4369 set nl 0
4370 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4371 $ctext insert end "$line\n"
4373 if {[eof $bf]} {
4374 # delete last newline
4375 $ctext delete "end - 2c" "end - 1c"
4376 close $bf
4377 return 0
4379 $ctext config -state disabled
4380 return [expr {$nl >= 1000? 2: 1}]
4383 proc mergediff {id l} {
4384 global diffmergeid diffopts mdifffd
4385 global diffids
4386 global parentlist
4388 set diffmergeid $id
4389 set diffids $id
4390 # this doesn't seem to actually affect anything...
4391 set env(GIT_DIFF_OPTS) $diffopts
4392 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4393 if {[catch {set mdf [open $cmd r]} err]} {
4394 error_popup "Error getting merge diffs: $err"
4395 return
4397 fconfigure $mdf -blocking 0
4398 set mdifffd($id) $mdf
4399 set np [llength [lindex $parentlist $l]]
4400 filerun $mdf [list getmergediffline $mdf $id $np]
4403 proc getmergediffline {mdf id np} {
4404 global diffmergeid ctext cflist mergemax
4405 global difffilestart mdifffd
4407 $ctext conf -state normal
4408 set nr 0
4409 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4410 if {![info exists diffmergeid] || $id != $diffmergeid
4411 || $mdf != $mdifffd($id)} {
4412 close $mdf
4413 return 0
4415 if {[regexp {^diff --cc (.*)} $line match fname]} {
4416 # start of a new file
4417 $ctext insert end "\n"
4418 set here [$ctext index "end - 1c"]
4419 lappend difffilestart $here
4420 add_flist [list $fname]
4421 set l [expr {(78 - [string length $fname]) / 2}]
4422 set pad [string range "----------------------------------------" 1 $l]
4423 $ctext insert end "$pad $fname $pad\n" filesep
4424 } elseif {[regexp {^@@} $line]} {
4425 $ctext insert end "$line\n" hunksep
4426 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4427 # do nothing
4428 } else {
4429 # parse the prefix - one ' ', '-' or '+' for each parent
4430 set spaces {}
4431 set minuses {}
4432 set pluses {}
4433 set isbad 0
4434 for {set j 0} {$j < $np} {incr j} {
4435 set c [string range $line $j $j]
4436 if {$c == " "} {
4437 lappend spaces $j
4438 } elseif {$c == "-"} {
4439 lappend minuses $j
4440 } elseif {$c == "+"} {
4441 lappend pluses $j
4442 } else {
4443 set isbad 1
4444 break
4447 set tags {}
4448 set num {}
4449 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4450 # line doesn't appear in result, parents in $minuses have the line
4451 set num [lindex $minuses 0]
4452 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4453 # line appears in result, parents in $pluses don't have the line
4454 lappend tags mresult
4455 set num [lindex $spaces 0]
4457 if {$num ne {}} {
4458 if {$num >= $mergemax} {
4459 set num "max"
4461 lappend tags m$num
4463 $ctext insert end "$line\n" $tags
4466 $ctext conf -state disabled
4467 if {[eof $mdf]} {
4468 close $mdf
4469 return 0
4471 return [expr {$nr >= 1000? 2: 1}]
4474 proc startdiff {ids} {
4475 global treediffs diffids treepending diffmergeid
4477 set diffids $ids
4478 catch {unset diffmergeid}
4479 if {![info exists treediffs($ids)]} {
4480 if {![info exists treepending]} {
4481 gettreediffs $ids
4483 } else {
4484 addtocflist $ids
4488 proc addtocflist {ids} {
4489 global treediffs cflist
4490 add_flist $treediffs($ids)
4491 getblobdiffs $ids
4494 proc gettreediffs {ids} {
4495 global treediff treepending
4496 set treepending $ids
4497 set treediff {}
4498 if {[catch \
4499 {set gdtf [open [concat | git diff-tree --no-commit-id -r $ids] r]} \
4500 ]} return
4501 fconfigure $gdtf -blocking 0
4502 filerun $gdtf [list gettreediffline $gdtf $ids]
4505 proc gettreediffline {gdtf ids} {
4506 global treediff treediffs treepending diffids diffmergeid
4507 global cmitmode
4509 set nr 0
4510 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
4511 set file [lindex $line 5]
4512 lappend treediff $file
4514 if {![eof $gdtf]} {
4515 return [expr {$nr >= 1000? 2: 1}]
4517 close $gdtf
4518 set treediffs($ids) $treediff
4519 unset treepending
4520 if {$cmitmode eq "tree"} {
4521 gettree $diffids
4522 } elseif {$ids != $diffids} {
4523 if {![info exists diffmergeid]} {
4524 gettreediffs $diffids
4526 } else {
4527 addtocflist $ids
4529 return 0
4532 proc getblobdiffs {ids} {
4533 global diffopts blobdifffd diffids env curdifftag curtagstart
4534 global diffinhdr treediffs
4536 set env(GIT_DIFF_OPTS) $diffopts
4537 set cmd [concat | git diff-tree --no-commit-id -r -p -C $ids]
4538 if {[catch {set bdf [open $cmd r]} err]} {
4539 puts "error getting diffs: $err"
4540 return
4542 set diffinhdr 0
4543 fconfigure $bdf -blocking 0
4544 set blobdifffd($ids) $bdf
4545 set curdifftag Comments
4546 set curtagstart 0.0
4547 filerun $bdf [list getblobdiffline $bdf $diffids]
4550 proc setinlist {var i val} {
4551 global $var
4553 while {[llength [set $var]] < $i} {
4554 lappend $var {}
4556 if {[llength [set $var]] == $i} {
4557 lappend $var $val
4558 } else {
4559 lset $var $i $val
4563 proc getblobdiffline {bdf ids} {
4564 global diffids blobdifffd ctext curdifftag curtagstart
4565 global diffnexthead diffnextnote difffilestart
4566 global diffinhdr treediffs
4568 set nr 0
4569 $ctext conf -state normal
4570 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
4571 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4572 close $bdf
4573 return 0
4575 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
4576 # start of a new file
4577 $ctext insert end "\n"
4578 $ctext tag add $curdifftag $curtagstart end
4579 set here [$ctext index "end - 1c"]
4580 set curtagstart $here
4581 set header $newname
4582 set i [lsearch -exact $treediffs($ids) $fname]
4583 if {$i >= 0} {
4584 setinlist difffilestart $i $here
4586 if {$newname ne $fname} {
4587 set i [lsearch -exact $treediffs($ids) $newname]
4588 if {$i >= 0} {
4589 setinlist difffilestart $i $here
4592 set curdifftag "f:$fname"
4593 $ctext tag delete $curdifftag
4594 set l [expr {(78 - [string length $header]) / 2}]
4595 set pad [string range "----------------------------------------" \
4596 1 $l]
4597 $ctext insert end "$pad $header $pad\n" filesep
4598 set diffinhdr 1
4599 } elseif {$diffinhdr && [string compare -length 3 $line "---"] == 0} {
4600 # do nothing
4601 } elseif {$diffinhdr && [string compare -length 3 $line "+++"] == 0} {
4602 set diffinhdr 0
4603 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
4604 $line match f1l f1c f2l f2c rest]} {
4605 $ctext insert end "$line\n" hunksep
4606 set diffinhdr 0
4607 } else {
4608 set x [string range $line 0 0]
4609 if {$x == "-" || $x == "+"} {
4610 set tag [expr {$x == "+"}]
4611 $ctext insert end "$line\n" d$tag
4612 } elseif {$x == " "} {
4613 $ctext insert end "$line\n"
4614 } elseif {$diffinhdr || $x == "\\"} {
4615 # e.g. "\ No newline at end of file"
4616 $ctext insert end "$line\n" filesep
4617 } else {
4618 # Something else we don't recognize
4619 if {$curdifftag != "Comments"} {
4620 $ctext insert end "\n"
4621 $ctext tag add $curdifftag $curtagstart end
4622 set curtagstart [$ctext index "end - 1c"]
4623 set curdifftag Comments
4625 $ctext insert end "$line\n" filesep
4629 $ctext conf -state disabled
4630 if {[eof $bdf]} {
4631 close $bdf
4632 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
4633 $ctext tag add $curdifftag $curtagstart end
4635 return 0
4637 return [expr {$nr >= 1000? 2: 1}]
4640 proc changediffdisp {} {
4641 global ctext diffelide
4643 $ctext tag conf d0 -elide [lindex $diffelide 0]
4644 $ctext tag conf d1 -elide [lindex $diffelide 1]
4647 proc prevfile {} {
4648 global difffilestart ctext
4649 set prev [lindex $difffilestart 0]
4650 set here [$ctext index @0,0]
4651 foreach loc $difffilestart {
4652 if {[$ctext compare $loc >= $here]} {
4653 $ctext yview $prev
4654 return
4656 set prev $loc
4658 $ctext yview $prev
4661 proc nextfile {} {
4662 global difffilestart ctext
4663 set here [$ctext index @0,0]
4664 foreach loc $difffilestart {
4665 if {[$ctext compare $loc > $here]} {
4666 $ctext yview $loc
4667 return
4672 proc clear_ctext {{first 1.0}} {
4673 global ctext smarktop smarkbot
4675 set l [lindex [split $first .] 0]
4676 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
4677 set smarktop $l
4679 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
4680 set smarkbot $l
4682 $ctext delete $first end
4685 proc incrsearch {name ix op} {
4686 global ctext searchstring searchdirn
4688 $ctext tag remove found 1.0 end
4689 if {[catch {$ctext index anchor}]} {
4690 # no anchor set, use start of selection, or of visible area
4691 set sel [$ctext tag ranges sel]
4692 if {$sel ne {}} {
4693 $ctext mark set anchor [lindex $sel 0]
4694 } elseif {$searchdirn eq "-forwards"} {
4695 $ctext mark set anchor @0,0
4696 } else {
4697 $ctext mark set anchor @0,[winfo height $ctext]
4700 if {$searchstring ne {}} {
4701 set here [$ctext search $searchdirn -- $searchstring anchor]
4702 if {$here ne {}} {
4703 $ctext see $here
4705 searchmarkvisible 1
4709 proc dosearch {} {
4710 global sstring ctext searchstring searchdirn
4712 focus $sstring
4713 $sstring icursor end
4714 set searchdirn -forwards
4715 if {$searchstring ne {}} {
4716 set sel [$ctext tag ranges sel]
4717 if {$sel ne {}} {
4718 set start "[lindex $sel 0] + 1c"
4719 } elseif {[catch {set start [$ctext index anchor]}]} {
4720 set start "@0,0"
4722 set match [$ctext search -count mlen -- $searchstring $start]
4723 $ctext tag remove sel 1.0 end
4724 if {$match eq {}} {
4725 bell
4726 return
4728 $ctext see $match
4729 set mend "$match + $mlen c"
4730 $ctext tag add sel $match $mend
4731 $ctext mark unset anchor
4735 proc dosearchback {} {
4736 global sstring ctext searchstring searchdirn
4738 focus $sstring
4739 $sstring icursor end
4740 set searchdirn -backwards
4741 if {$searchstring ne {}} {
4742 set sel [$ctext tag ranges sel]
4743 if {$sel ne {}} {
4744 set start [lindex $sel 0]
4745 } elseif {[catch {set start [$ctext index anchor]}]} {
4746 set start @0,[winfo height $ctext]
4748 set match [$ctext search -backwards -count ml -- $searchstring $start]
4749 $ctext tag remove sel 1.0 end
4750 if {$match eq {}} {
4751 bell
4752 return
4754 $ctext see $match
4755 set mend "$match + $ml c"
4756 $ctext tag add sel $match $mend
4757 $ctext mark unset anchor
4761 proc searchmark {first last} {
4762 global ctext searchstring
4764 set mend $first.0
4765 while {1} {
4766 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
4767 if {$match eq {}} break
4768 set mend "$match + $mlen c"
4769 $ctext tag add found $match $mend
4773 proc searchmarkvisible {doall} {
4774 global ctext smarktop smarkbot
4776 set topline [lindex [split [$ctext index @0,0] .] 0]
4777 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
4778 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
4779 # no overlap with previous
4780 searchmark $topline $botline
4781 set smarktop $topline
4782 set smarkbot $botline
4783 } else {
4784 if {$topline < $smarktop} {
4785 searchmark $topline [expr {$smarktop-1}]
4786 set smarktop $topline
4788 if {$botline > $smarkbot} {
4789 searchmark [expr {$smarkbot+1}] $botline
4790 set smarkbot $botline
4795 proc scrolltext {f0 f1} {
4796 global searchstring
4798 .bleft.sb set $f0 $f1
4799 if {$searchstring ne {}} {
4800 searchmarkvisible 0
4804 proc setcoords {} {
4805 global linespc charspc canvx0 canvy0 mainfont
4806 global xspc1 xspc2 lthickness
4808 set linespc [font metrics $mainfont -linespace]
4809 set charspc [font measure $mainfont "m"]
4810 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
4811 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
4812 set lthickness [expr {int($linespc / 9) + 1}]
4813 set xspc1(0) $linespc
4814 set xspc2 $linespc
4817 proc redisplay {} {
4818 global canv
4819 global selectedline
4821 set ymax [lindex [$canv cget -scrollregion] 3]
4822 if {$ymax eq {} || $ymax == 0} return
4823 set span [$canv yview]
4824 clear_display
4825 setcanvscroll
4826 allcanvs yview moveto [lindex $span 0]
4827 drawvisible
4828 if {[info exists selectedline]} {
4829 selectline $selectedline 0
4830 allcanvs yview moveto [lindex $span 0]
4834 proc incrfont {inc} {
4835 global mainfont textfont ctext canv phase cflist
4836 global charspc tabstop
4837 global stopped entries
4838 unmarkmatches
4839 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
4840 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
4841 setcoords
4842 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
4843 $cflist conf -font $textfont
4844 $ctext tag conf filesep -font [concat $textfont bold]
4845 foreach e $entries {
4846 $e conf -font $mainfont
4848 if {$phase eq "getcommits"} {
4849 $canv itemconf textitems -font $mainfont
4851 redisplay
4854 proc clearsha1 {} {
4855 global sha1entry sha1string
4856 if {[string length $sha1string] == 40} {
4857 $sha1entry delete 0 end
4861 proc sha1change {n1 n2 op} {
4862 global sha1string currentid sha1but
4863 if {$sha1string == {}
4864 || ([info exists currentid] && $sha1string == $currentid)} {
4865 set state disabled
4866 } else {
4867 set state normal
4869 if {[$sha1but cget -state] == $state} return
4870 if {$state == "normal"} {
4871 $sha1but conf -state normal -relief raised -text "Goto: "
4872 } else {
4873 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
4877 proc gotocommit {} {
4878 global sha1string currentid commitrow tagids headids
4879 global displayorder numcommits curview
4881 if {$sha1string == {}
4882 || ([info exists currentid] && $sha1string == $currentid)} return
4883 if {[info exists tagids($sha1string)]} {
4884 set id $tagids($sha1string)
4885 } elseif {[info exists headids($sha1string)]} {
4886 set id $headids($sha1string)
4887 } else {
4888 set id [string tolower $sha1string]
4889 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
4890 set matches {}
4891 foreach i $displayorder {
4892 if {[string match $id* $i]} {
4893 lappend matches $i
4896 if {$matches ne {}} {
4897 if {[llength $matches] > 1} {
4898 error_popup "Short SHA1 id $id is ambiguous"
4899 return
4901 set id [lindex $matches 0]
4905 if {[info exists commitrow($curview,$id)]} {
4906 selectline $commitrow($curview,$id) 1
4907 return
4909 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
4910 set type "SHA1 id"
4911 } else {
4912 set type "Tag/Head"
4914 error_popup "$type $sha1string is not known"
4917 proc lineenter {x y id} {
4918 global hoverx hovery hoverid hovertimer
4919 global commitinfo canv
4921 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4922 set hoverx $x
4923 set hovery $y
4924 set hoverid $id
4925 if {[info exists hovertimer]} {
4926 after cancel $hovertimer
4928 set hovertimer [after 500 linehover]
4929 $canv delete hover
4932 proc linemotion {x y id} {
4933 global hoverx hovery hoverid hovertimer
4935 if {[info exists hoverid] && $id == $hoverid} {
4936 set hoverx $x
4937 set hovery $y
4938 if {[info exists hovertimer]} {
4939 after cancel $hovertimer
4941 set hovertimer [after 500 linehover]
4945 proc lineleave {id} {
4946 global hoverid hovertimer canv
4948 if {[info exists hoverid] && $id == $hoverid} {
4949 $canv delete hover
4950 if {[info exists hovertimer]} {
4951 after cancel $hovertimer
4952 unset hovertimer
4954 unset hoverid
4958 proc linehover {} {
4959 global hoverx hovery hoverid hovertimer
4960 global canv linespc lthickness
4961 global commitinfo mainfont
4963 set text [lindex $commitinfo($hoverid) 0]
4964 set ymax [lindex [$canv cget -scrollregion] 3]
4965 if {$ymax == {}} return
4966 set yfrac [lindex [$canv yview] 0]
4967 set x [expr {$hoverx + 2 * $linespc}]
4968 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
4969 set x0 [expr {$x - 2 * $lthickness}]
4970 set y0 [expr {$y - 2 * $lthickness}]
4971 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
4972 set y1 [expr {$y + $linespc + 2 * $lthickness}]
4973 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
4974 -fill \#ffff80 -outline black -width 1 -tags hover]
4975 $canv raise $t
4976 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
4977 -font $mainfont]
4978 $canv raise $t
4981 proc clickisonarrow {id y} {
4982 global lthickness
4984 set ranges [rowranges $id]
4985 set thresh [expr {2 * $lthickness + 6}]
4986 set n [expr {[llength $ranges] - 1}]
4987 for {set i 1} {$i < $n} {incr i} {
4988 set row [lindex $ranges $i]
4989 if {abs([yc $row] - $y) < $thresh} {
4990 return $i
4993 return {}
4996 proc arrowjump {id n y} {
4997 global canv
4999 # 1 <-> 2, 3 <-> 4, etc...
5000 set n [expr {(($n - 1) ^ 1) + 1}]
5001 set row [lindex [rowranges $id] $n]
5002 set yt [yc $row]
5003 set ymax [lindex [$canv cget -scrollregion] 3]
5004 if {$ymax eq {} || $ymax <= 0} return
5005 set view [$canv yview]
5006 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5007 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5008 if {$yfrac < 0} {
5009 set yfrac 0
5011 allcanvs yview moveto $yfrac
5014 proc lineclick {x y id isnew} {
5015 global ctext commitinfo children canv thickerline curview
5017 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5018 unmarkmatches
5019 unselectline
5020 normalline
5021 $canv delete hover
5022 # draw this line thicker than normal
5023 set thickerline $id
5024 drawlines $id
5025 if {$isnew} {
5026 set ymax [lindex [$canv cget -scrollregion] 3]
5027 if {$ymax eq {}} return
5028 set yfrac [lindex [$canv yview] 0]
5029 set y [expr {$y + $yfrac * $ymax}]
5031 set dirn [clickisonarrow $id $y]
5032 if {$dirn ne {}} {
5033 arrowjump $id $dirn $y
5034 return
5037 if {$isnew} {
5038 addtohistory [list lineclick $x $y $id 0]
5040 # fill the details pane with info about this line
5041 $ctext conf -state normal
5042 clear_ctext
5043 $ctext tag conf link -foreground blue -underline 1
5044 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5045 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5046 $ctext insert end "Parent:\t"
5047 $ctext insert end $id [list link link0]
5048 $ctext tag bind link0 <1> [list selbyid $id]
5049 set info $commitinfo($id)
5050 $ctext insert end "\n\t[lindex $info 0]\n"
5051 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5052 set date [formatdate [lindex $info 2]]
5053 $ctext insert end "\tDate:\t$date\n"
5054 set kids $children($curview,$id)
5055 if {$kids ne {}} {
5056 $ctext insert end "\nChildren:"
5057 set i 0
5058 foreach child $kids {
5059 incr i
5060 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5061 set info $commitinfo($child)
5062 $ctext insert end "\n\t"
5063 $ctext insert end $child [list link link$i]
5064 $ctext tag bind link$i <1> [list selbyid $child]
5065 $ctext insert end "\n\t[lindex $info 0]"
5066 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5067 set date [formatdate [lindex $info 2]]
5068 $ctext insert end "\n\tDate:\t$date\n"
5071 $ctext conf -state disabled
5072 init_flist {}
5075 proc normalline {} {
5076 global thickerline
5077 if {[info exists thickerline]} {
5078 set id $thickerline
5079 unset thickerline
5080 drawlines $id
5084 proc selbyid {id} {
5085 global commitrow curview
5086 if {[info exists commitrow($curview,$id)]} {
5087 selectline $commitrow($curview,$id) 1
5091 proc mstime {} {
5092 global startmstime
5093 if {![info exists startmstime]} {
5094 set startmstime [clock clicks -milliseconds]
5096 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5099 proc rowmenu {x y id} {
5100 global rowctxmenu commitrow selectedline rowmenuid curview
5102 if {![info exists selectedline]
5103 || $commitrow($curview,$id) eq $selectedline} {
5104 set state disabled
5105 } else {
5106 set state normal
5108 $rowctxmenu entryconfigure "Diff this*" -state $state
5109 $rowctxmenu entryconfigure "Diff selected*" -state $state
5110 $rowctxmenu entryconfigure "Make patch" -state $state
5111 set rowmenuid $id
5112 tk_popup $rowctxmenu $x $y
5115 proc diffvssel {dirn} {
5116 global rowmenuid selectedline displayorder
5118 if {![info exists selectedline]} return
5119 if {$dirn} {
5120 set oldid [lindex $displayorder $selectedline]
5121 set newid $rowmenuid
5122 } else {
5123 set oldid $rowmenuid
5124 set newid [lindex $displayorder $selectedline]
5126 addtohistory [list doseldiff $oldid $newid]
5127 doseldiff $oldid $newid
5130 proc doseldiff {oldid newid} {
5131 global ctext
5132 global commitinfo
5134 $ctext conf -state normal
5135 clear_ctext
5136 init_flist "Top"
5137 $ctext insert end "From "
5138 $ctext tag conf link -foreground blue -underline 1
5139 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5140 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5141 $ctext tag bind link0 <1> [list selbyid $oldid]
5142 $ctext insert end $oldid [list link link0]
5143 $ctext insert end "\n "
5144 $ctext insert end [lindex $commitinfo($oldid) 0]
5145 $ctext insert end "\n\nTo "
5146 $ctext tag bind link1 <1> [list selbyid $newid]
5147 $ctext insert end $newid [list link link1]
5148 $ctext insert end "\n "
5149 $ctext insert end [lindex $commitinfo($newid) 0]
5150 $ctext insert end "\n"
5151 $ctext conf -state disabled
5152 $ctext tag delete Comments
5153 $ctext tag remove found 1.0 end
5154 startdiff [list $oldid $newid]
5157 proc mkpatch {} {
5158 global rowmenuid currentid commitinfo patchtop patchnum
5160 if {![info exists currentid]} return
5161 set oldid $currentid
5162 set oldhead [lindex $commitinfo($oldid) 0]
5163 set newid $rowmenuid
5164 set newhead [lindex $commitinfo($newid) 0]
5165 set top .patch
5166 set patchtop $top
5167 catch {destroy $top}
5168 toplevel $top
5169 label $top.title -text "Generate patch"
5170 grid $top.title - -pady 10
5171 label $top.from -text "From:"
5172 entry $top.fromsha1 -width 40 -relief flat
5173 $top.fromsha1 insert 0 $oldid
5174 $top.fromsha1 conf -state readonly
5175 grid $top.from $top.fromsha1 -sticky w
5176 entry $top.fromhead -width 60 -relief flat
5177 $top.fromhead insert 0 $oldhead
5178 $top.fromhead conf -state readonly
5179 grid x $top.fromhead -sticky w
5180 label $top.to -text "To:"
5181 entry $top.tosha1 -width 40 -relief flat
5182 $top.tosha1 insert 0 $newid
5183 $top.tosha1 conf -state readonly
5184 grid $top.to $top.tosha1 -sticky w
5185 entry $top.tohead -width 60 -relief flat
5186 $top.tohead insert 0 $newhead
5187 $top.tohead conf -state readonly
5188 grid x $top.tohead -sticky w
5189 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5190 grid $top.rev x -pady 10
5191 label $top.flab -text "Output file:"
5192 entry $top.fname -width 60
5193 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5194 incr patchnum
5195 grid $top.flab $top.fname -sticky w
5196 frame $top.buts
5197 button $top.buts.gen -text "Generate" -command mkpatchgo
5198 button $top.buts.can -text "Cancel" -command mkpatchcan
5199 grid $top.buts.gen $top.buts.can
5200 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5201 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5202 grid $top.buts - -pady 10 -sticky ew
5203 focus $top.fname
5206 proc mkpatchrev {} {
5207 global patchtop
5209 set oldid [$patchtop.fromsha1 get]
5210 set oldhead [$patchtop.fromhead get]
5211 set newid [$patchtop.tosha1 get]
5212 set newhead [$patchtop.tohead get]
5213 foreach e [list fromsha1 fromhead tosha1 tohead] \
5214 v [list $newid $newhead $oldid $oldhead] {
5215 $patchtop.$e conf -state normal
5216 $patchtop.$e delete 0 end
5217 $patchtop.$e insert 0 $v
5218 $patchtop.$e conf -state readonly
5222 proc mkpatchgo {} {
5223 global patchtop
5225 set oldid [$patchtop.fromsha1 get]
5226 set newid [$patchtop.tosha1 get]
5227 set fname [$patchtop.fname get]
5228 if {[catch {exec git diff-tree -p $oldid $newid >$fname &} err]} {
5229 error_popup "Error creating patch: $err"
5231 catch {destroy $patchtop}
5232 unset patchtop
5235 proc mkpatchcan {} {
5236 global patchtop
5238 catch {destroy $patchtop}
5239 unset patchtop
5242 proc mktag {} {
5243 global rowmenuid mktagtop commitinfo
5245 set top .maketag
5246 set mktagtop $top
5247 catch {destroy $top}
5248 toplevel $top
5249 label $top.title -text "Create tag"
5250 grid $top.title - -pady 10
5251 label $top.id -text "ID:"
5252 entry $top.sha1 -width 40 -relief flat
5253 $top.sha1 insert 0 $rowmenuid
5254 $top.sha1 conf -state readonly
5255 grid $top.id $top.sha1 -sticky w
5256 entry $top.head -width 60 -relief flat
5257 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5258 $top.head conf -state readonly
5259 grid x $top.head -sticky w
5260 label $top.tlab -text "Tag name:"
5261 entry $top.tag -width 60
5262 grid $top.tlab $top.tag -sticky w
5263 frame $top.buts
5264 button $top.buts.gen -text "Create" -command mktaggo
5265 button $top.buts.can -text "Cancel" -command mktagcan
5266 grid $top.buts.gen $top.buts.can
5267 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5268 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5269 grid $top.buts - -pady 10 -sticky ew
5270 focus $top.tag
5273 proc domktag {} {
5274 global mktagtop env tagids idtags
5276 set id [$mktagtop.sha1 get]
5277 set tag [$mktagtop.tag get]
5278 if {$tag == {}} {
5279 error_popup "No tag name specified"
5280 return
5282 if {[info exists tagids($tag)]} {
5283 error_popup "Tag \"$tag\" already exists"
5284 return
5286 if {[catch {
5287 set dir [gitdir]
5288 set fname [file join $dir "refs/tags" $tag]
5289 set f [open $fname w]
5290 puts $f $id
5291 close $f
5292 } err]} {
5293 error_popup "Error creating tag: $err"
5294 return
5297 set tagids($tag) $id
5298 lappend idtags($id) $tag
5299 redrawtags $id
5300 addedtag $id
5303 proc redrawtags {id} {
5304 global canv linehtag commitrow idpos selectedline curview
5305 global mainfont canvxmax
5307 if {![info exists commitrow($curview,$id)]} return
5308 drawcmitrow $commitrow($curview,$id)
5309 $canv delete tag.$id
5310 set xt [eval drawtags $id $idpos($id)]
5311 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5312 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5313 set xr [expr {$xt + [font measure $mainfont $text]}]
5314 if {$xr > $canvxmax} {
5315 set canvxmax $xr
5316 setcanvscroll
5318 if {[info exists selectedline]
5319 && $selectedline == $commitrow($curview,$id)} {
5320 selectline $selectedline 0
5324 proc mktagcan {} {
5325 global mktagtop
5327 catch {destroy $mktagtop}
5328 unset mktagtop
5331 proc mktaggo {} {
5332 domktag
5333 mktagcan
5336 proc writecommit {} {
5337 global rowmenuid wrcomtop commitinfo wrcomcmd
5339 set top .writecommit
5340 set wrcomtop $top
5341 catch {destroy $top}
5342 toplevel $top
5343 label $top.title -text "Write commit to file"
5344 grid $top.title - -pady 10
5345 label $top.id -text "ID:"
5346 entry $top.sha1 -width 40 -relief flat
5347 $top.sha1 insert 0 $rowmenuid
5348 $top.sha1 conf -state readonly
5349 grid $top.id $top.sha1 -sticky w
5350 entry $top.head -width 60 -relief flat
5351 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5352 $top.head conf -state readonly
5353 grid x $top.head -sticky w
5354 label $top.clab -text "Command:"
5355 entry $top.cmd -width 60 -textvariable wrcomcmd
5356 grid $top.clab $top.cmd -sticky w -pady 10
5357 label $top.flab -text "Output file:"
5358 entry $top.fname -width 60
5359 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5360 grid $top.flab $top.fname -sticky w
5361 frame $top.buts
5362 button $top.buts.gen -text "Write" -command wrcomgo
5363 button $top.buts.can -text "Cancel" -command wrcomcan
5364 grid $top.buts.gen $top.buts.can
5365 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5366 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5367 grid $top.buts - -pady 10 -sticky ew
5368 focus $top.fname
5371 proc wrcomgo {} {
5372 global wrcomtop
5374 set id [$wrcomtop.sha1 get]
5375 set cmd "echo $id | [$wrcomtop.cmd get]"
5376 set fname [$wrcomtop.fname get]
5377 if {[catch {exec sh -c $cmd >$fname &} err]} {
5378 error_popup "Error writing commit: $err"
5380 catch {destroy $wrcomtop}
5381 unset wrcomtop
5384 proc wrcomcan {} {
5385 global wrcomtop
5387 catch {destroy $wrcomtop}
5388 unset wrcomtop
5391 proc mkbranch {} {
5392 global rowmenuid mkbrtop
5394 set top .makebranch
5395 catch {destroy $top}
5396 toplevel $top
5397 label $top.title -text "Create new branch"
5398 grid $top.title - -pady 10
5399 label $top.id -text "ID:"
5400 entry $top.sha1 -width 40 -relief flat
5401 $top.sha1 insert 0 $rowmenuid
5402 $top.sha1 conf -state readonly
5403 grid $top.id $top.sha1 -sticky w
5404 label $top.nlab -text "Name:"
5405 entry $top.name -width 40
5406 grid $top.nlab $top.name -sticky w
5407 frame $top.buts
5408 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5409 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5410 grid $top.buts.go $top.buts.can
5411 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5412 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5413 grid $top.buts - -pady 10 -sticky ew
5414 focus $top.name
5417 proc mkbrgo {top} {
5418 global headids idheads
5420 set name [$top.name get]
5421 set id [$top.sha1 get]
5422 if {$name eq {}} {
5423 error_popup "Please specify a name for the new branch"
5424 return
5426 catch {destroy $top}
5427 nowbusy newbranch
5428 update
5429 if {[catch {
5430 exec git branch $name $id
5431 } err]} {
5432 notbusy newbranch
5433 error_popup $err
5434 } else {
5435 set headids($name) $id
5436 lappend idheads($id) $name
5437 addedhead $id $name
5438 notbusy newbranch
5439 redrawtags $id
5440 dispneartags 0
5444 proc cherrypick {} {
5445 global rowmenuid curview commitrow
5446 global mainhead
5448 set oldhead [exec git rev-parse HEAD]
5449 set dheads [descheads $rowmenuid]
5450 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
5451 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5452 included in branch $mainhead -- really re-apply it?"]
5453 if {!$ok} return
5455 nowbusy cherrypick
5456 update
5457 # Unfortunately git-cherry-pick writes stuff to stderr even when
5458 # no error occurs, and exec takes that as an indication of error...
5459 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5460 notbusy cherrypick
5461 error_popup $err
5462 return
5464 set newhead [exec git rev-parse HEAD]
5465 if {$newhead eq $oldhead} {
5466 notbusy cherrypick
5467 error_popup "No changes committed"
5468 return
5470 addnewchild $newhead $oldhead
5471 if {[info exists commitrow($curview,$oldhead)]} {
5472 insertrow $commitrow($curview,$oldhead) $newhead
5473 if {$mainhead ne {}} {
5474 movehead $newhead $mainhead
5475 movedhead $newhead $mainhead
5477 redrawtags $oldhead
5478 redrawtags $newhead
5480 notbusy cherrypick
5483 # context menu for a head
5484 proc headmenu {x y id head} {
5485 global headmenuid headmenuhead headctxmenu mainhead
5487 set headmenuid $id
5488 set headmenuhead $head
5489 set state normal
5490 if {$head eq $mainhead} {
5491 set state disabled
5493 $headctxmenu entryconfigure 0 -state $state
5494 $headctxmenu entryconfigure 1 -state $state
5495 tk_popup $headctxmenu $x $y
5498 proc cobranch {} {
5499 global headmenuid headmenuhead mainhead headids
5501 # check the tree is clean first??
5502 set oldmainhead $mainhead
5503 nowbusy checkout
5504 update
5505 if {[catch {
5506 exec git checkout -q $headmenuhead
5507 } err]} {
5508 notbusy checkout
5509 error_popup $err
5510 } else {
5511 notbusy checkout
5512 set mainhead $headmenuhead
5513 if {[info exists headids($oldmainhead)]} {
5514 redrawtags $headids($oldmainhead)
5516 redrawtags $headmenuid
5520 proc rmbranch {} {
5521 global headmenuid headmenuhead mainhead
5522 global headids idheads
5524 set head $headmenuhead
5525 set id $headmenuid
5526 # this check shouldn't be needed any more...
5527 if {$head eq $mainhead} {
5528 error_popup "Cannot delete the currently checked-out branch"
5529 return
5531 set dheads [descheads $id]
5532 if {$dheads eq $headids($head)} {
5533 # the stuff on this branch isn't on any other branch
5534 if {![confirm_popup "The commits on branch $head aren't on any other\
5535 branch.\nReally delete branch $head?"]} return
5537 nowbusy rmbranch
5538 update
5539 if {[catch {exec git branch -D $head} err]} {
5540 notbusy rmbranch
5541 error_popup $err
5542 return
5544 removehead $id $head
5545 removedhead $id $head
5546 redrawtags $id
5547 notbusy rmbranch
5548 dispneartags 0
5551 # Stuff for finding nearby tags
5552 proc getallcommits {} {
5553 global allcommits allids nbmp nextarc seeds
5555 set allids {}
5556 set nbmp 0
5557 set nextarc 0
5558 set allcommits 0
5559 set seeds {}
5560 regetallcommits
5563 # Called when the graph might have changed
5564 proc regetallcommits {} {
5565 global allcommits seeds
5567 set cmd [concat | git rev-list --all --parents]
5568 foreach id $seeds {
5569 lappend cmd "^$id"
5571 set fd [open $cmd r]
5572 fconfigure $fd -blocking 0
5573 incr allcommits
5574 nowbusy allcommits
5575 filerun $fd [list getallclines $fd]
5578 # Since most commits have 1 parent and 1 child, we group strings of
5579 # such commits into "arcs" joining branch/merge points (BMPs), which
5580 # are commits that either don't have 1 parent or don't have 1 child.
5582 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
5583 # arcout(id) - outgoing arcs for BMP
5584 # arcids(a) - list of IDs on arc including end but not start
5585 # arcstart(a) - BMP ID at start of arc
5586 # arcend(a) - BMP ID at end of arc
5587 # growing(a) - arc a is still growing
5588 # arctags(a) - IDs out of arcids (excluding end) that have tags
5589 # archeads(a) - IDs out of arcids (excluding end) that have heads
5590 # The start of an arc is at the descendent end, so "incoming" means
5591 # coming from descendents, and "outgoing" means going towards ancestors.
5593 proc getallclines {fd} {
5594 global allids allparents allchildren idtags nextarc nbmp
5595 global arcnos arcids arctags arcout arcend arcstart archeads growing
5596 global seeds allcommits
5598 set nid 0
5599 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
5600 set id [lindex $line 0]
5601 if {[info exists allparents($id)]} {
5602 # seen it already
5603 continue
5605 lappend allids $id
5606 set olds [lrange $line 1 end]
5607 set allparents($id) $olds
5608 if {![info exists allchildren($id)]} {
5609 set allchildren($id) {}
5610 set arcnos($id) {}
5611 lappend seeds $id
5612 } else {
5613 set a $arcnos($id)
5614 if {[llength $olds] == 1 && [llength $a] == 1} {
5615 lappend arcids($a) $id
5616 if {[info exists idtags($id)]} {
5617 lappend arctags($a) $id
5619 if {[info exists idheads($id)]} {
5620 lappend archeads($a) $id
5622 if {[info exists allparents($olds)]} {
5623 # seen parent already
5624 if {![info exists arcout($olds)]} {
5625 splitarc $olds
5627 lappend arcids($a) $olds
5628 set arcend($a) $olds
5629 unset growing($a)
5631 lappend allchildren($olds) $id
5632 lappend arcnos($olds) $a
5633 continue
5636 incr nbmp
5637 foreach a $arcnos($id) {
5638 lappend arcids($a) $id
5639 set arcend($a) $id
5640 unset growing($a)
5643 set ao {}
5644 foreach p $olds {
5645 lappend allchildren($p) $id
5646 set a [incr nextarc]
5647 set arcstart($a) $id
5648 set archeads($a) {}
5649 set arctags($a) {}
5650 set archeads($a) {}
5651 set arcids($a) {}
5652 lappend ao $a
5653 set growing($a) 1
5654 if {[info exists allparents($p)]} {
5655 # seen it already, may need to make a new branch
5656 if {![info exists arcout($p)]} {
5657 splitarc $p
5659 lappend arcids($a) $p
5660 set arcend($a) $p
5661 unset growing($a)
5663 lappend arcnos($p) $a
5665 set arcout($id) $ao
5667 if {![eof $fd]} {
5668 return [expr {$nid >= 1000? 2: 1}]
5670 close $fd
5671 if {[incr allcommits -1] == 0} {
5672 notbusy allcommits
5674 dispneartags 0
5675 return 0
5678 proc recalcarc {a} {
5679 global arctags archeads arcids idtags idheads
5681 set at {}
5682 set ah {}
5683 foreach id [lrange $arcids($a) 0 end-1] {
5684 if {[info exists idtags($id)]} {
5685 lappend at $id
5687 if {[info exists idheads($id)]} {
5688 lappend ah $id
5691 set arctags($a) $at
5692 set archeads($a) $ah
5695 proc splitarc {p} {
5696 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
5697 global arcstart arcend arcout allparents growing
5699 set a $arcnos($p)
5700 if {[llength $a] != 1} {
5701 puts "oops splitarc called but [llength $a] arcs already"
5702 return
5704 set a [lindex $a 0]
5705 set i [lsearch -exact $arcids($a) $p]
5706 if {$i < 0} {
5707 puts "oops splitarc $p not in arc $a"
5708 return
5710 set na [incr nextarc]
5711 if {[info exists arcend($a)]} {
5712 set arcend($na) $arcend($a)
5713 } else {
5714 set l [lindex $allparents([lindex $arcids($a) end]) 0]
5715 set j [lsearch -exact $arcnos($l) $a]
5716 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
5718 set tail [lrange $arcids($a) [expr {$i+1}] end]
5719 set arcids($a) [lrange $arcids($a) 0 $i]
5720 set arcend($a) $p
5721 set arcstart($na) $p
5722 set arcout($p) $na
5723 set arcids($na) $tail
5724 if {[info exists growing($a)]} {
5725 set growing($na) 1
5726 unset growing($a)
5728 incr nbmp
5730 foreach id $tail {
5731 if {[llength $arcnos($id)] == 1} {
5732 set arcnos($id) $na
5733 } else {
5734 set j [lsearch -exact $arcnos($id) $a]
5735 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
5739 # reconstruct tags and heads lists
5740 if {$arctags($a) ne {} || $archeads($a) ne {}} {
5741 recalcarc $a
5742 recalcarc $na
5743 } else {
5744 set arctags($na) {}
5745 set archeads($na) {}
5749 # Update things for a new commit added that is a child of one
5750 # existing commit. Used when cherry-picking.
5751 proc addnewchild {id p} {
5752 global allids allparents allchildren idtags nextarc nbmp
5753 global arcnos arcids arctags arcout arcend arcstart archeads growing
5754 global seeds
5756 lappend allids $id
5757 set allparents($id) [list $p]
5758 set allchildren($id) {}
5759 set arcnos($id) {}
5760 lappend seeds $id
5761 incr nbmp
5762 lappend allchildren($p) $id
5763 set a [incr nextarc]
5764 set arcstart($a) $id
5765 set archeads($a) {}
5766 set arctags($a) {}
5767 set arcids($a) [list $p]
5768 set arcend($a) $p
5769 if {![info exists arcout($p)]} {
5770 splitarc $p
5772 lappend arcnos($p) $a
5773 set arcout($id) [list $a]
5776 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
5777 # or 0 if neither is true.
5778 proc anc_or_desc {a b} {
5779 global arcout arcstart arcend arcnos cached_isanc
5781 if {$arcnos($a) eq $arcnos($b)} {
5782 # Both are on the same arc(s); either both are the same BMP,
5783 # or if one is not a BMP, the other is also not a BMP or is
5784 # the BMP at end of the arc (and it only has 1 incoming arc).
5785 if {$a eq $b} {
5786 return 0
5788 # assert {[llength $arcnos($a)] == 1}
5789 set arc [lindex $arcnos($a) 0]
5790 set i [lsearch -exact $arcids($arc) $a]
5791 set j [lsearch -exact $arcids($arc) $b]
5792 if {$i < 0 || $i > $j} {
5793 return 1
5794 } else {
5795 return -1
5799 if {![info exists arcout($a)]} {
5800 set arc [lindex $arcnos($a) 0]
5801 if {[info exists arcend($arc)]} {
5802 set aend $arcend($arc)
5803 } else {
5804 set aend {}
5806 set a $arcstart($arc)
5807 } else {
5808 set aend $a
5810 if {![info exists arcout($b)]} {
5811 set arc [lindex $arcnos($b) 0]
5812 if {[info exists arcend($arc)]} {
5813 set bend $arcend($arc)
5814 } else {
5815 set bend {}
5817 set b $arcstart($arc)
5818 } else {
5819 set bend $b
5821 if {$a eq $bend} {
5822 return 1
5824 if {$b eq $aend} {
5825 return -1
5827 if {[info exists cached_isanc($a,$bend)]} {
5828 if {$cached_isanc($a,$bend)} {
5829 return 1
5832 if {[info exists cached_isanc($b,$aend)]} {
5833 if {$cached_isanc($b,$aend)} {
5834 return -1
5836 if {[info exists cached_isanc($a,$bend)]} {
5837 return 0
5841 set todo [list $a $b]
5842 set anc($a) a
5843 set anc($b) b
5844 for {set i 0} {$i < [llength $todo]} {incr i} {
5845 set x [lindex $todo $i]
5846 if {$anc($x) eq {}} {
5847 continue
5849 foreach arc $arcnos($x) {
5850 set xd $arcstart($arc)
5851 if {$xd eq $bend} {
5852 set cached_isanc($a,$bend) 1
5853 set cached_isanc($b,$aend) 0
5854 return 1
5855 } elseif {$xd eq $aend} {
5856 set cached_isanc($b,$aend) 1
5857 set cached_isanc($a,$bend) 0
5858 return -1
5860 if {![info exists anc($xd)]} {
5861 set anc($xd) $anc($x)
5862 lappend todo $xd
5863 } elseif {$anc($xd) ne $anc($x)} {
5864 set anc($xd) {}
5868 set cached_isanc($a,$bend) 0
5869 set cached_isanc($b,$aend) 0
5870 return 0
5873 # This identifies whether $desc has an ancestor that is
5874 # a growing tip of the graph and which is not an ancestor of $anc
5875 # and returns 0 if so and 1 if not.
5876 # If we subsequently discover a tag on such a growing tip, and that
5877 # turns out to be a descendent of $anc (which it could, since we
5878 # don't necessarily see children before parents), then $desc
5879 # isn't a good choice to display as a descendent tag of
5880 # $anc (since it is the descendent of another tag which is
5881 # a descendent of $anc). Similarly, $anc isn't a good choice to
5882 # display as a ancestor tag of $desc.
5884 proc is_certain {desc anc} {
5885 global arcnos arcout arcstart arcend growing problems
5887 set certain {}
5888 if {[llength $arcnos($anc)] == 1} {
5889 # tags on the same arc are certain
5890 if {$arcnos($desc) eq $arcnos($anc)} {
5891 return 1
5893 if {![info exists arcout($anc)]} {
5894 # if $anc is partway along an arc, use the start of the arc instead
5895 set a [lindex $arcnos($anc) 0]
5896 set anc $arcstart($a)
5899 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
5900 set x $desc
5901 } else {
5902 set a [lindex $arcnos($desc) 0]
5903 set x $arcend($a)
5905 if {$x == $anc} {
5906 return 1
5908 set anclist [list $x]
5909 set dl($x) 1
5910 set nnh 1
5911 set ngrowanc 0
5912 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
5913 set x [lindex $anclist $i]
5914 if {$dl($x)} {
5915 incr nnh -1
5917 set done($x) 1
5918 foreach a $arcout($x) {
5919 if {[info exists growing($a)]} {
5920 if {![info exists growanc($x)] && $dl($x)} {
5921 set growanc($x) 1
5922 incr ngrowanc
5924 } else {
5925 set y $arcend($a)
5926 if {[info exists dl($y)]} {
5927 if {$dl($y)} {
5928 if {!$dl($x)} {
5929 set dl($y) 0
5930 if {![info exists done($y)]} {
5931 incr nnh -1
5933 if {[info exists growanc($x)]} {
5934 incr ngrowanc -1
5936 set xl [list $y]
5937 for {set k 0} {$k < [llength $xl]} {incr k} {
5938 set z [lindex $xl $k]
5939 foreach c $arcout($z) {
5940 if {[info exists arcend($c)]} {
5941 set v $arcend($c)
5942 if {[info exists dl($v)] && $dl($v)} {
5943 set dl($v) 0
5944 if {![info exists done($v)]} {
5945 incr nnh -1
5947 if {[info exists growanc($v)]} {
5948 incr ngrowanc -1
5950 lappend xl $v
5957 } elseif {$y eq $anc || !$dl($x)} {
5958 set dl($y) 0
5959 lappend anclist $y
5960 } else {
5961 set dl($y) 1
5962 lappend anclist $y
5963 incr nnh
5968 foreach x [array names growanc] {
5969 if {$dl($x)} {
5970 return 0
5972 return 0
5974 return 1
5977 proc validate_arctags {a} {
5978 global arctags idtags
5980 set i -1
5981 set na $arctags($a)
5982 foreach id $arctags($a) {
5983 incr i
5984 if {![info exists idtags($id)]} {
5985 set na [lreplace $na $i $i]
5986 incr i -1
5989 set arctags($a) $na
5992 proc validate_archeads {a} {
5993 global archeads idheads
5995 set i -1
5996 set na $archeads($a)
5997 foreach id $archeads($a) {
5998 incr i
5999 if {![info exists idheads($id)]} {
6000 set na [lreplace $na $i $i]
6001 incr i -1
6004 set archeads($a) $na
6007 # Return the list of IDs that have tags that are descendents of id,
6008 # ignoring IDs that are descendents of IDs already reported.
6009 proc desctags {id} {
6010 global arcnos arcstart arcids arctags idtags allparents
6011 global growing cached_dtags
6013 if {![info exists allparents($id)]} {
6014 return {}
6016 set t1 [clock clicks -milliseconds]
6017 set argid $id
6018 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6019 # part-way along an arc; check that arc first
6020 set a [lindex $arcnos($id) 0]
6021 if {$arctags($a) ne {}} {
6022 validate_arctags $a
6023 set i [lsearch -exact $arcids($a) $id]
6024 set tid {}
6025 foreach t $arctags($a) {
6026 set j [lsearch -exact $arcids($a) $t]
6027 if {$j >= $i} break
6028 set tid $t
6030 if {$tid ne {}} {
6031 return $tid
6034 set id $arcstart($a)
6035 if {[info exists idtags($id)]} {
6036 return $id
6039 if {[info exists cached_dtags($id)]} {
6040 return $cached_dtags($id)
6043 set origid $id
6044 set todo [list $id]
6045 set queued($id) 1
6046 set nc 1
6047 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6048 set id [lindex $todo $i]
6049 set done($id) 1
6050 set ta [info exists hastaggedancestor($id)]
6051 if {!$ta} {
6052 incr nc -1
6054 # ignore tags on starting node
6055 if {!$ta && $i > 0} {
6056 if {[info exists idtags($id)]} {
6057 set tagloc($id) $id
6058 set ta 1
6059 } elseif {[info exists cached_dtags($id)]} {
6060 set tagloc($id) $cached_dtags($id)
6061 set ta 1
6064 foreach a $arcnos($id) {
6065 set d $arcstart($a)
6066 if {!$ta && $arctags($a) ne {}} {
6067 validate_arctags $a
6068 if {$arctags($a) ne {}} {
6069 lappend tagloc($id) [lindex $arctags($a) end]
6072 if {$ta || $arctags($a) ne {}} {
6073 set tomark [list $d]
6074 for {set j 0} {$j < [llength $tomark]} {incr j} {
6075 set dd [lindex $tomark $j]
6076 if {![info exists hastaggedancestor($dd)]} {
6077 if {[info exists done($dd)]} {
6078 foreach b $arcnos($dd) {
6079 lappend tomark $arcstart($b)
6081 if {[info exists tagloc($dd)]} {
6082 unset tagloc($dd)
6084 } elseif {[info exists queued($dd)]} {
6085 incr nc -1
6087 set hastaggedancestor($dd) 1
6091 if {![info exists queued($d)]} {
6092 lappend todo $d
6093 set queued($d) 1
6094 if {![info exists hastaggedancestor($d)]} {
6095 incr nc
6100 set tags {}
6101 foreach id [array names tagloc] {
6102 if {![info exists hastaggedancestor($id)]} {
6103 foreach t $tagloc($id) {
6104 if {[lsearch -exact $tags $t] < 0} {
6105 lappend tags $t
6110 set t2 [clock clicks -milliseconds]
6111 set loopix $i
6113 # remove tags that are descendents of other tags
6114 for {set i 0} {$i < [llength $tags]} {incr i} {
6115 set a [lindex $tags $i]
6116 for {set j 0} {$j < $i} {incr j} {
6117 set b [lindex $tags $j]
6118 set r [anc_or_desc $a $b]
6119 if {$r == 1} {
6120 set tags [lreplace $tags $j $j]
6121 incr j -1
6122 incr i -1
6123 } elseif {$r == -1} {
6124 set tags [lreplace $tags $i $i]
6125 incr i -1
6126 break
6131 if {[array names growing] ne {}} {
6132 # graph isn't finished, need to check if any tag could get
6133 # eclipsed by another tag coming later. Simply ignore any
6134 # tags that could later get eclipsed.
6135 set ctags {}
6136 foreach t $tags {
6137 if {[is_certain $t $origid]} {
6138 lappend ctags $t
6141 if {$tags eq $ctags} {
6142 set cached_dtags($origid) $tags
6143 } else {
6144 set tags $ctags
6146 } else {
6147 set cached_dtags($origid) $tags
6149 set t3 [clock clicks -milliseconds]
6150 if {0 && $t3 - $t1 >= 100} {
6151 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
6152 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6154 return $tags
6157 proc anctags {id} {
6158 global arcnos arcids arcout arcend arctags idtags allparents
6159 global growing cached_atags
6161 if {![info exists allparents($id)]} {
6162 return {}
6164 set t1 [clock clicks -milliseconds]
6165 set argid $id
6166 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6167 # part-way along an arc; check that arc first
6168 set a [lindex $arcnos($id) 0]
6169 if {$arctags($a) ne {}} {
6170 validate_arctags $a
6171 set i [lsearch -exact $arcids($a) $id]
6172 foreach t $arctags($a) {
6173 set j [lsearch -exact $arcids($a) $t]
6174 if {$j > $i} {
6175 return $t
6179 if {![info exists arcend($a)]} {
6180 return {}
6182 set id $arcend($a)
6183 if {[info exists idtags($id)]} {
6184 return $id
6187 if {[info exists cached_atags($id)]} {
6188 return $cached_atags($id)
6191 set origid $id
6192 set todo [list $id]
6193 set queued($id) 1
6194 set taglist {}
6195 set nc 1
6196 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6197 set id [lindex $todo $i]
6198 set done($id) 1
6199 set td [info exists hastaggeddescendent($id)]
6200 if {!$td} {
6201 incr nc -1
6203 # ignore tags on starting node
6204 if {!$td && $i > 0} {
6205 if {[info exists idtags($id)]} {
6206 set tagloc($id) $id
6207 set td 1
6208 } elseif {[info exists cached_atags($id)]} {
6209 set tagloc($id) $cached_atags($id)
6210 set td 1
6213 foreach a $arcout($id) {
6214 if {!$td && $arctags($a) ne {}} {
6215 validate_arctags $a
6216 if {$arctags($a) ne {}} {
6217 lappend tagloc($id) [lindex $arctags($a) 0]
6220 if {![info exists arcend($a)]} continue
6221 set d $arcend($a)
6222 if {$td || $arctags($a) ne {}} {
6223 set tomark [list $d]
6224 for {set j 0} {$j < [llength $tomark]} {incr j} {
6225 set dd [lindex $tomark $j]
6226 if {![info exists hastaggeddescendent($dd)]} {
6227 if {[info exists done($dd)]} {
6228 foreach b $arcout($dd) {
6229 if {[info exists arcend($b)]} {
6230 lappend tomark $arcend($b)
6233 if {[info exists tagloc($dd)]} {
6234 unset tagloc($dd)
6236 } elseif {[info exists queued($dd)]} {
6237 incr nc -1
6239 set hastaggeddescendent($dd) 1
6243 if {![info exists queued($d)]} {
6244 lappend todo $d
6245 set queued($d) 1
6246 if {![info exists hastaggeddescendent($d)]} {
6247 incr nc
6252 set t2 [clock clicks -milliseconds]
6253 set loopix $i
6254 set tags {}
6255 foreach id [array names tagloc] {
6256 if {![info exists hastaggeddescendent($id)]} {
6257 foreach t $tagloc($id) {
6258 if {[lsearch -exact $tags $t] < 0} {
6259 lappend tags $t
6265 # remove tags that are ancestors of other tags
6266 for {set i 0} {$i < [llength $tags]} {incr i} {
6267 set a [lindex $tags $i]
6268 for {set j 0} {$j < $i} {incr j} {
6269 set b [lindex $tags $j]
6270 set r [anc_or_desc $a $b]
6271 if {$r == -1} {
6272 set tags [lreplace $tags $j $j]
6273 incr j -1
6274 incr i -1
6275 } elseif {$r == 1} {
6276 set tags [lreplace $tags $i $i]
6277 incr i -1
6278 break
6283 if {[array names growing] ne {}} {
6284 # graph isn't finished, need to check if any tag could get
6285 # eclipsed by another tag coming later. Simply ignore any
6286 # tags that could later get eclipsed.
6287 set ctags {}
6288 foreach t $tags {
6289 if {[is_certain $origid $t]} {
6290 lappend ctags $t
6293 if {$tags eq $ctags} {
6294 set cached_atags($origid) $tags
6295 } else {
6296 set tags $ctags
6298 } else {
6299 set cached_atags($origid) $tags
6301 set t3 [clock clicks -milliseconds]
6302 if {0 && $t3 - $t1 >= 100} {
6303 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
6304 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
6306 return $tags
6309 # Return the list of IDs that have heads that are descendents of id,
6310 # including id itself if it has a head.
6311 proc descheads {id} {
6312 global arcnos arcstart arcids archeads idheads cached_dheads
6313 global allparents
6315 if {![info exists allparents($id)]} {
6316 return {}
6318 set ret {}
6319 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6320 # part-way along an arc; check it first
6321 set a [lindex $arcnos($id) 0]
6322 if {$archeads($a) ne {}} {
6323 validate_archeads $a
6324 set i [lsearch -exact $arcids($a) $id]
6325 foreach t $archeads($a) {
6326 set j [lsearch -exact $arcids($a) $t]
6327 if {$j > $i} break
6328 lappend $ret $t
6331 set id $arcstart($a)
6333 set origid $id
6334 set todo [list $id]
6335 set seen($id) 1
6336 for {set i 0} {$i < [llength $todo]} {incr i} {
6337 set id [lindex $todo $i]
6338 if {[info exists cached_dheads($id)]} {
6339 set ret [concat $ret $cached_dheads($id)]
6340 } else {
6341 if {[info exists idheads($id)]} {
6342 lappend ret $id
6344 foreach a $arcnos($id) {
6345 if {$archeads($a) ne {}} {
6346 set ret [concat $ret $archeads($a)]
6348 set d $arcstart($a)
6349 if {![info exists seen($d)]} {
6350 lappend todo $d
6351 set seen($d) 1
6356 set ret [lsort -unique $ret]
6357 set cached_dheads($origid) $ret
6360 proc addedtag {id} {
6361 global arcnos arcout cached_dtags cached_atags
6363 if {![info exists arcnos($id)]} return
6364 if {![info exists arcout($id)]} {
6365 recalcarc [lindex $arcnos($id) 0]
6367 catch {unset cached_dtags}
6368 catch {unset cached_atags}
6371 proc addedhead {hid head} {
6372 global arcnos arcout cached_dheads
6374 if {![info exists arcnos($hid)]} return
6375 if {![info exists arcout($hid)]} {
6376 recalcarc [lindex $arcnos($hid) 0]
6378 catch {unset cached_dheads}
6381 proc removedhead {hid head} {
6382 global cached_dheads
6384 catch {unset cached_dheads}
6387 proc movedhead {hid head} {
6388 global arcnos arcout cached_dheads
6390 if {![info exists arcnos($hid)]} return
6391 if {![info exists arcout($hid)]} {
6392 recalcarc [lindex $arcnos($hid) 0]
6394 catch {unset cached_dheads}
6397 proc changedrefs {} {
6398 global cached_dheads cached_dtags cached_atags
6399 global arctags archeads arcnos arcout idheads idtags
6401 foreach id [concat [array names idheads] [array names idtags]] {
6402 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
6403 set a [lindex $arcnos($id) 0]
6404 if {![info exists donearc($a)]} {
6405 recalcarc $a
6406 set donearc($a) 1
6410 catch {unset cached_dtags}
6411 catch {unset cached_atags}
6412 catch {unset cached_dheads}
6415 proc rereadrefs {} {
6416 global idtags idheads idotherrefs mainhead
6418 set refids [concat [array names idtags] \
6419 [array names idheads] [array names idotherrefs]]
6420 foreach id $refids {
6421 if {![info exists ref($id)]} {
6422 set ref($id) [listrefs $id]
6425 set oldmainhead $mainhead
6426 readrefs
6427 changedrefs
6428 set refids [lsort -unique [concat $refids [array names idtags] \
6429 [array names idheads] [array names idotherrefs]]]
6430 foreach id $refids {
6431 set v [listrefs $id]
6432 if {![info exists ref($id)] || $ref($id) != $v ||
6433 ($id eq $oldmainhead && $id ne $mainhead) ||
6434 ($id eq $mainhead && $id ne $oldmainhead)} {
6435 redrawtags $id
6440 proc listrefs {id} {
6441 global idtags idheads idotherrefs
6443 set x {}
6444 if {[info exists idtags($id)]} {
6445 set x $idtags($id)
6447 set y {}
6448 if {[info exists idheads($id)]} {
6449 set y $idheads($id)
6451 set z {}
6452 if {[info exists idotherrefs($id)]} {
6453 set z $idotherrefs($id)
6455 return [list $x $y $z]
6458 proc showtag {tag isnew} {
6459 global ctext tagcontents tagids linknum
6461 if {$isnew} {
6462 addtohistory [list showtag $tag 0]
6464 $ctext conf -state normal
6465 clear_ctext
6466 set linknum 0
6467 if {[info exists tagcontents($tag)]} {
6468 set text $tagcontents($tag)
6469 } else {
6470 set text "Tag: $tag\nId: $tagids($tag)"
6472 appendwithlinks $text {}
6473 $ctext conf -state disabled
6474 init_flist {}
6477 proc doquit {} {
6478 global stopped
6479 set stopped 100
6480 savestuff .
6481 destroy .
6484 proc doprefs {} {
6485 global maxwidth maxgraphpct diffopts
6486 global oldprefs prefstop showneartags
6487 global bgcolor fgcolor ctext diffcolors selectbgcolor
6488 global uifont tabstop
6490 set top .gitkprefs
6491 set prefstop $top
6492 if {[winfo exists $top]} {
6493 raise $top
6494 return
6496 foreach v {maxwidth maxgraphpct diffopts showneartags} {
6497 set oldprefs($v) [set $v]
6499 toplevel $top
6500 wm title $top "Gitk preferences"
6501 label $top.ldisp -text "Commit list display options"
6502 $top.ldisp configure -font $uifont
6503 grid $top.ldisp - -sticky w -pady 10
6504 label $top.spacer -text " "
6505 label $top.maxwidthl -text "Maximum graph width (lines)" \
6506 -font optionfont
6507 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
6508 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
6509 label $top.maxpctl -text "Maximum graph width (% of pane)" \
6510 -font optionfont
6511 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
6512 grid x $top.maxpctl $top.maxpct -sticky w
6514 label $top.ddisp -text "Diff display options"
6515 $top.ddisp configure -font $uifont
6516 grid $top.ddisp - -sticky w -pady 10
6517 label $top.diffoptl -text "Options for diff program" \
6518 -font optionfont
6519 entry $top.diffopt -width 20 -textvariable diffopts
6520 grid x $top.diffoptl $top.diffopt -sticky w
6521 frame $top.ntag
6522 label $top.ntag.l -text "Display nearby tags" -font optionfont
6523 checkbutton $top.ntag.b -variable showneartags
6524 pack $top.ntag.b $top.ntag.l -side left
6525 grid x $top.ntag -sticky w
6526 label $top.tabstopl -text "tabstop" -font optionfont
6527 entry $top.tabstop -width 10 -textvariable tabstop
6528 grid x $top.tabstopl $top.tabstop -sticky w
6530 label $top.cdisp -text "Colors: press to choose"
6531 $top.cdisp configure -font $uifont
6532 grid $top.cdisp - -sticky w -pady 10
6533 label $top.bg -padx 40 -relief sunk -background $bgcolor
6534 button $top.bgbut -text "Background" -font optionfont \
6535 -command [list choosecolor bgcolor 0 $top.bg background setbg]
6536 grid x $top.bgbut $top.bg -sticky w
6537 label $top.fg -padx 40 -relief sunk -background $fgcolor
6538 button $top.fgbut -text "Foreground" -font optionfont \
6539 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
6540 grid x $top.fgbut $top.fg -sticky w
6541 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
6542 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
6543 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
6544 [list $ctext tag conf d0 -foreground]]
6545 grid x $top.diffoldbut $top.diffold -sticky w
6546 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
6547 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
6548 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
6549 [list $ctext tag conf d1 -foreground]]
6550 grid x $top.diffnewbut $top.diffnew -sticky w
6551 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
6552 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
6553 -command [list choosecolor diffcolors 2 $top.hunksep \
6554 "diff hunk header" \
6555 [list $ctext tag conf hunksep -foreground]]
6556 grid x $top.hunksepbut $top.hunksep -sticky w
6557 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
6558 button $top.selbgbut -text "Select bg" -font optionfont \
6559 -command [list choosecolor selectbgcolor 0 $top.bg background setselbg]
6560 grid x $top.selbgbut $top.selbgsep -sticky w
6562 frame $top.buts
6563 button $top.buts.ok -text "OK" -command prefsok -default active
6564 $top.buts.ok configure -font $uifont
6565 button $top.buts.can -text "Cancel" -command prefscan -default normal
6566 $top.buts.can configure -font $uifont
6567 grid $top.buts.ok $top.buts.can
6568 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6569 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6570 grid $top.buts - - -pady 10 -sticky ew
6571 bind $top <Visibility> "focus $top.buts.ok"
6574 proc choosecolor {v vi w x cmd} {
6575 global $v
6577 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
6578 -title "Gitk: choose color for $x"]
6579 if {$c eq {}} return
6580 $w conf -background $c
6581 lset $v $vi $c
6582 eval $cmd $c
6585 proc setselbg {c} {
6586 global bglist cflist
6587 foreach w $bglist {
6588 $w configure -selectbackground $c
6590 $cflist tag configure highlight \
6591 -background [$cflist cget -selectbackground]
6592 allcanvs itemconf secsel -fill $c
6595 proc setbg {c} {
6596 global bglist
6598 foreach w $bglist {
6599 $w conf -background $c
6603 proc setfg {c} {
6604 global fglist canv
6606 foreach w $fglist {
6607 $w conf -foreground $c
6609 allcanvs itemconf text -fill $c
6610 $canv itemconf circle -outline $c
6613 proc prefscan {} {
6614 global maxwidth maxgraphpct diffopts
6615 global oldprefs prefstop showneartags
6617 foreach v {maxwidth maxgraphpct diffopts showneartags} {
6618 set $v $oldprefs($v)
6620 catch {destroy $prefstop}
6621 unset prefstop
6624 proc prefsok {} {
6625 global maxwidth maxgraphpct
6626 global oldprefs prefstop showneartags
6627 global charspc ctext tabstop
6629 catch {destroy $prefstop}
6630 unset prefstop
6631 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
6632 if {$maxwidth != $oldprefs(maxwidth)
6633 || $maxgraphpct != $oldprefs(maxgraphpct)} {
6634 redisplay
6635 } elseif {$showneartags != $oldprefs(showneartags)} {
6636 reselectline
6640 proc formatdate {d} {
6641 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
6644 # This list of encoding names and aliases is distilled from
6645 # http://www.iana.org/assignments/character-sets.
6646 # Not all of them are supported by Tcl.
6647 set encoding_aliases {
6648 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
6649 ISO646-US US-ASCII us IBM367 cp367 csASCII }
6650 { ISO-10646-UTF-1 csISO10646UTF1 }
6651 { ISO_646.basic:1983 ref csISO646basic1983 }
6652 { INVARIANT csINVARIANT }
6653 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
6654 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
6655 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
6656 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
6657 { NATS-DANO iso-ir-9-1 csNATSDANO }
6658 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
6659 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
6660 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
6661 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
6662 { ISO-2022-KR csISO2022KR }
6663 { EUC-KR csEUCKR }
6664 { ISO-2022-JP csISO2022JP }
6665 { ISO-2022-JP-2 csISO2022JP2 }
6666 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
6667 csISO13JISC6220jp }
6668 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
6669 { IT iso-ir-15 ISO646-IT csISO15Italian }
6670 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
6671 { ES iso-ir-17 ISO646-ES csISO17Spanish }
6672 { greek7-old iso-ir-18 csISO18Greek7Old }
6673 { latin-greek iso-ir-19 csISO19LatinGreek }
6674 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
6675 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
6676 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
6677 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
6678 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
6679 { BS_viewdata iso-ir-47 csISO47BSViewdata }
6680 { INIS iso-ir-49 csISO49INIS }
6681 { INIS-8 iso-ir-50 csISO50INIS8 }
6682 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
6683 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
6684 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
6685 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
6686 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
6687 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
6688 csISO60Norwegian1 }
6689 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
6690 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
6691 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
6692 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
6693 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
6694 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
6695 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
6696 { greek7 iso-ir-88 csISO88Greek7 }
6697 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
6698 { iso-ir-90 csISO90 }
6699 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
6700 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
6701 csISO92JISC62991984b }
6702 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
6703 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
6704 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
6705 csISO95JIS62291984handadd }
6706 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
6707 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
6708 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
6709 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
6710 CP819 csISOLatin1 }
6711 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
6712 { T.61-7bit iso-ir-102 csISO102T617bit }
6713 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
6714 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
6715 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
6716 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
6717 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
6718 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
6719 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
6720 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
6721 arabic csISOLatinArabic }
6722 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
6723 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
6724 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
6725 greek greek8 csISOLatinGreek }
6726 { T.101-G2 iso-ir-128 csISO128T101G2 }
6727 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
6728 csISOLatinHebrew }
6729 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
6730 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
6731 { CSN_369103 iso-ir-139 csISO139CSN369103 }
6732 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
6733 { ISO_6937-2-add iso-ir-142 csISOTextComm }
6734 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
6735 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
6736 csISOLatinCyrillic }
6737 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
6738 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
6739 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
6740 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
6741 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
6742 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
6743 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
6744 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
6745 { ISO_10367-box iso-ir-155 csISO10367Box }
6746 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
6747 { latin-lap lap iso-ir-158 csISO158Lap }
6748 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
6749 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
6750 { us-dk csUSDK }
6751 { dk-us csDKUS }
6752 { JIS_X0201 X0201 csHalfWidthKatakana }
6753 { KSC5636 ISO646-KR csKSC5636 }
6754 { ISO-10646-UCS-2 csUnicode }
6755 { ISO-10646-UCS-4 csUCS4 }
6756 { DEC-MCS dec csDECMCS }
6757 { hp-roman8 roman8 r8 csHPRoman8 }
6758 { macintosh mac csMacintosh }
6759 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
6760 csIBM037 }
6761 { IBM038 EBCDIC-INT cp038 csIBM038 }
6762 { IBM273 CP273 csIBM273 }
6763 { IBM274 EBCDIC-BE CP274 csIBM274 }
6764 { IBM275 EBCDIC-BR cp275 csIBM275 }
6765 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
6766 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
6767 { IBM280 CP280 ebcdic-cp-it csIBM280 }
6768 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
6769 { IBM284 CP284 ebcdic-cp-es csIBM284 }
6770 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
6771 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
6772 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
6773 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
6774 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
6775 { IBM424 cp424 ebcdic-cp-he csIBM424 }
6776 { IBM437 cp437 437 csPC8CodePage437 }
6777 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
6778 { IBM775 cp775 csPC775Baltic }
6779 { IBM850 cp850 850 csPC850Multilingual }
6780 { IBM851 cp851 851 csIBM851 }
6781 { IBM852 cp852 852 csPCp852 }
6782 { IBM855 cp855 855 csIBM855 }
6783 { IBM857 cp857 857 csIBM857 }
6784 { IBM860 cp860 860 csIBM860 }
6785 { IBM861 cp861 861 cp-is csIBM861 }
6786 { IBM862 cp862 862 csPC862LatinHebrew }
6787 { IBM863 cp863 863 csIBM863 }
6788 { IBM864 cp864 csIBM864 }
6789 { IBM865 cp865 865 csIBM865 }
6790 { IBM866 cp866 866 csIBM866 }
6791 { IBM868 CP868 cp-ar csIBM868 }
6792 { IBM869 cp869 869 cp-gr csIBM869 }
6793 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
6794 { IBM871 CP871 ebcdic-cp-is csIBM871 }
6795 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
6796 { IBM891 cp891 csIBM891 }
6797 { IBM903 cp903 csIBM903 }
6798 { IBM904 cp904 904 csIBBM904 }
6799 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
6800 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
6801 { IBM1026 CP1026 csIBM1026 }
6802 { EBCDIC-AT-DE csIBMEBCDICATDE }
6803 { EBCDIC-AT-DE-A csEBCDICATDEA }
6804 { EBCDIC-CA-FR csEBCDICCAFR }
6805 { EBCDIC-DK-NO csEBCDICDKNO }
6806 { EBCDIC-DK-NO-A csEBCDICDKNOA }
6807 { EBCDIC-FI-SE csEBCDICFISE }
6808 { EBCDIC-FI-SE-A csEBCDICFISEA }
6809 { EBCDIC-FR csEBCDICFR }
6810 { EBCDIC-IT csEBCDICIT }
6811 { EBCDIC-PT csEBCDICPT }
6812 { EBCDIC-ES csEBCDICES }
6813 { EBCDIC-ES-A csEBCDICESA }
6814 { EBCDIC-ES-S csEBCDICESS }
6815 { EBCDIC-UK csEBCDICUK }
6816 { EBCDIC-US csEBCDICUS }
6817 { UNKNOWN-8BIT csUnknown8BiT }
6818 { MNEMONIC csMnemonic }
6819 { MNEM csMnem }
6820 { VISCII csVISCII }
6821 { VIQR csVIQR }
6822 { KOI8-R csKOI8R }
6823 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
6824 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
6825 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
6826 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
6827 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
6828 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
6829 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
6830 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
6831 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
6832 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
6833 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
6834 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
6835 { IBM1047 IBM-1047 }
6836 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
6837 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
6838 { UNICODE-1-1 csUnicode11 }
6839 { CESU-8 csCESU-8 }
6840 { BOCU-1 csBOCU-1 }
6841 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
6842 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
6843 l8 }
6844 { ISO-8859-15 ISO_8859-15 Latin-9 }
6845 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
6846 { GBK CP936 MS936 windows-936 }
6847 { JIS_Encoding csJISEncoding }
6848 { Shift_JIS MS_Kanji csShiftJIS }
6849 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
6850 EUC-JP }
6851 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
6852 { ISO-10646-UCS-Basic csUnicodeASCII }
6853 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
6854 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
6855 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
6856 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
6857 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
6858 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
6859 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
6860 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
6861 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
6862 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
6863 { Adobe-Standard-Encoding csAdobeStandardEncoding }
6864 { Ventura-US csVenturaUS }
6865 { Ventura-International csVenturaInternational }
6866 { PC8-Danish-Norwegian csPC8DanishNorwegian }
6867 { PC8-Turkish csPC8Turkish }
6868 { IBM-Symbols csIBMSymbols }
6869 { IBM-Thai csIBMThai }
6870 { HP-Legal csHPLegal }
6871 { HP-Pi-font csHPPiFont }
6872 { HP-Math8 csHPMath8 }
6873 { Adobe-Symbol-Encoding csHPPSMath }
6874 { HP-DeskTop csHPDesktop }
6875 { Ventura-Math csVenturaMath }
6876 { Microsoft-Publishing csMicrosoftPublishing }
6877 { Windows-31J csWindows31J }
6878 { GB2312 csGB2312 }
6879 { Big5 csBig5 }
6882 proc tcl_encoding {enc} {
6883 global encoding_aliases
6884 set names [encoding names]
6885 set lcnames [string tolower $names]
6886 set enc [string tolower $enc]
6887 set i [lsearch -exact $lcnames $enc]
6888 if {$i < 0} {
6889 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
6890 if {[regsub {^iso[-_]} $enc iso encx]} {
6891 set i [lsearch -exact $lcnames $encx]
6894 if {$i < 0} {
6895 foreach l $encoding_aliases {
6896 set ll [string tolower $l]
6897 if {[lsearch -exact $ll $enc] < 0} continue
6898 # look through the aliases for one that tcl knows about
6899 foreach e $ll {
6900 set i [lsearch -exact $lcnames $e]
6901 if {$i < 0} {
6902 if {[regsub {^iso[-_]} $e iso ex]} {
6903 set i [lsearch -exact $lcnames $ex]
6906 if {$i >= 0} break
6908 break
6911 if {$i >= 0} {
6912 return [lindex $names $i]
6914 return {}
6917 # defaults...
6918 set datemode 0
6919 set diffopts "-U 5 -p"
6920 set wrcomcmd "git diff-tree --stdin -p --pretty"
6922 set gitencoding {}
6923 catch {
6924 set gitencoding [exec git config --get i18n.commitencoding]
6926 if {$gitencoding == ""} {
6927 set gitencoding "utf-8"
6929 set tclencoding [tcl_encoding $gitencoding]
6930 if {$tclencoding == {}} {
6931 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
6934 set mainfont {Helvetica 9}
6935 set textfont {Courier 9}
6936 set uifont {Helvetica 9 bold}
6937 set tabstop 8
6938 set findmergefiles 0
6939 set maxgraphpct 50
6940 set maxwidth 16
6941 set revlistorder 0
6942 set fastdate 0
6943 set uparrowlen 7
6944 set downarrowlen 7
6945 set mingaplen 30
6946 set cmitmode "patch"
6947 set wrapcomment "none"
6948 set showneartags 1
6949 set maxrefs 20
6951 set colors {green red blue magenta darkgrey brown orange}
6952 set bgcolor white
6953 set fgcolor black
6954 set diffcolors {red "#00a000" blue}
6955 set selectbgcolor gray85
6957 catch {source ~/.gitk}
6959 font create optionfont -family sans-serif -size -12
6961 set revtreeargs {}
6962 foreach arg $argv {
6963 switch -regexp -- $arg {
6964 "^$" { }
6965 "^-d" { set datemode 1 }
6966 default {
6967 lappend revtreeargs $arg
6972 # check that we can find a .git directory somewhere...
6973 set gitdir [gitdir]
6974 if {![file isdirectory $gitdir]} {
6975 show_error {} . "Cannot find the git directory \"$gitdir\"."
6976 exit 1
6979 set cmdline_files {}
6980 set i [lsearch -exact $revtreeargs "--"]
6981 if {$i >= 0} {
6982 set cmdline_files [lrange $revtreeargs [expr {$i + 1}] end]
6983 set revtreeargs [lrange $revtreeargs 0 [expr {$i - 1}]]
6984 } elseif {$revtreeargs ne {}} {
6985 if {[catch {
6986 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
6987 set cmdline_files [split $f "\n"]
6988 set n [llength $cmdline_files]
6989 set revtreeargs [lrange $revtreeargs 0 end-$n]
6990 } err]} {
6991 # unfortunately we get both stdout and stderr in $err,
6992 # so look for "fatal:".
6993 set i [string first "fatal:" $err]
6994 if {$i > 0} {
6995 set err [string range $err [expr {$i + 6}] end]
6997 show_error {} . "Bad arguments to gitk:\n$err"
6998 exit 1
7002 set runq {}
7003 set history {}
7004 set historyindex 0
7005 set fh_serial 0
7006 set nhl_names {}
7007 set highlight_paths {}
7008 set searchdirn -forwards
7009 set boldrows {}
7010 set boldnamerows {}
7011 set diffelide {0 0}
7013 set optim_delay 16
7015 set nextviewnum 1
7016 set curview 0
7017 set selectedview 0
7018 set selectedhlview None
7019 set viewfiles(0) {}
7020 set viewperm(0) 0
7021 set viewargs(0) {}
7023 set cmdlineok 0
7024 set stopped 0
7025 set stuffsaved 0
7026 set patchnum 0
7027 setcoords
7028 makewindow
7029 wm title . "[file tail $argv0]: [file tail [pwd]]"
7030 readrefs
7032 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7033 # create a view for the files/dirs specified on the command line
7034 set curview 1
7035 set selectedview 1
7036 set nextviewnum 2
7037 set viewname(1) "Command line"
7038 set viewfiles(1) $cmdline_files
7039 set viewargs(1) $revtreeargs
7040 set viewperm(1) 0
7041 addviewmenu 1
7042 .bar.view entryconf Edit* -state normal
7043 .bar.view entryconf Delete* -state normal
7046 if {[info exists permviews]} {
7047 foreach v $permviews {
7048 set n $nextviewnum
7049 incr nextviewnum
7050 set viewname($n) [lindex $v 0]
7051 set viewfiles($n) [lindex $v 1]
7052 set viewargs($n) [lindex $v 2]
7053 set viewperm($n) 1
7054 addviewmenu $n
7057 getcommits