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