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