Merge branch 'maint'
[git.git] / gitk
blob300fdceb350ca6d0419ef3b0bf3f1e7b82700a59
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 -eofchar {}
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 # git log doesn't terminate the last commit with a null...
143 if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
144 set stuff "\0"
146 if {$stuff == {}} {
147 if {![eof $fd]} {
148 return 1
150 global viewname
151 unset commfd($view)
152 notbusy $view
153 # set it blocking so we wait for the process to terminate
154 fconfigure $fd -blocking 1
155 if {[catch {close $fd} err]} {
156 set fv {}
157 if {$view != $curview} {
158 set fv " for the \"$viewname($view)\" view"
160 if {[string range $err 0 4] == "usage"} {
161 set err "Gitk: error reading commits$fv:\
162 bad arguments to git rev-list."
163 if {$viewname($view) eq "Command line"} {
164 append err \
165 " (Note: arguments to gitk are passed to git rev-list\
166 to allow selection of commits to be displayed.)"
168 } else {
169 set err "Error reading commits$fv: $err"
171 error_popup $err
173 if {$view == $curview} {
174 run chewcommits $view
176 return 0
178 set start 0
179 set gotsome 0
180 while 1 {
181 set i [string first "\0" $stuff $start]
182 if {$i < 0} {
183 append leftover($view) [string range $stuff $start end]
184 break
186 if {$start == 0} {
187 set cmit $leftover($view)
188 append cmit [string range $stuff 0 [expr {$i - 1}]]
189 set leftover($view) {}
190 } else {
191 set cmit [string range $stuff $start [expr {$i - 1}]]
193 set start [expr {$i + 1}]
194 set j [string first "\n" $cmit]
195 set ok 0
196 set listed 1
197 if {$j >= 0 && [string match "commit *" $cmit]} {
198 set ids [string range $cmit 7 [expr {$j - 1}]]
199 if {[string match {[-<>]*} $ids]} {
200 switch -- [string index $ids 0] {
201 "-" {set listed 0}
202 "<" {set listed 2}
203 ">" {set listed 3}
205 set ids [string range $ids 1 end]
207 set ok 1
208 foreach id $ids {
209 if {[string length $id] != 40} {
210 set ok 0
211 break
215 if {!$ok} {
216 set shortcmit $cmit
217 if {[string length $shortcmit] > 80} {
218 set shortcmit "[string range $shortcmit 0 80]..."
220 error_popup "Can't parse git log output: {$shortcmit}"
221 exit 1
223 set id [lindex $ids 0]
224 if {$listed} {
225 set olds [lrange $ids 1 end]
226 set i 0
227 foreach p $olds {
228 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
229 lappend children($view,$p) $id
231 incr i
233 } else {
234 set olds {}
236 if {![info exists children($view,$id)]} {
237 set children($view,$id) {}
239 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
240 set commitrow($view,$id) $commitidx($view)
241 incr commitidx($view)
242 if {$view == $curview} {
243 lappend parentlist $olds
244 lappend displayorder $id
245 lappend commitlisted $listed
246 } else {
247 lappend vparentlist($view) $olds
248 lappend vdisporder($view) $id
249 lappend vcmitlisted($view) $listed
251 set gotsome 1
253 if {$gotsome} {
254 run chewcommits $view
256 return 2
259 proc chewcommits {view} {
260 global curview hlview commfd
261 global selectedline pending_select
263 set more 0
264 if {$view == $curview} {
265 set allread [expr {![info exists commfd($view)]}]
266 set tlimit [expr {[clock clicks -milliseconds] + 50}]
267 set more [layoutmore $tlimit $allread]
268 if {$allread && !$more} {
269 global displayorder commitidx phase
270 global numcommits startmsecs
272 if {[info exists pending_select]} {
273 set row [first_real_row]
274 selectline $row 1
276 if {$commitidx($curview) > 0} {
277 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
278 #puts "overall $ms ms for $numcommits commits"
279 } else {
280 show_status "No commits selected"
282 notbusy layout
283 set phase {}
286 if {[info exists hlview] && $view == $hlview} {
287 vhighlightmore
289 return $more
292 proc readcommit {id} {
293 if {[catch {set contents [exec git cat-file commit $id]}]} return
294 parsecommit $id $contents 0
297 proc updatecommits {} {
298 global viewdata curview phase displayorder
299 global children commitrow selectedline thickerline showneartags
301 if {$phase ne {}} {
302 stop_rev_list
303 set phase {}
305 set n $curview
306 foreach id $displayorder {
307 catch {unset children($n,$id)}
308 catch {unset commitrow($n,$id)}
310 set curview -1
311 catch {unset selectedline}
312 catch {unset thickerline}
313 catch {unset viewdata($n)}
314 readrefs
315 changedrefs
316 if {$showneartags} {
317 getallcommits
319 showview $n
322 proc parsecommit {id contents listed} {
323 global commitinfo cdate
325 set inhdr 1
326 set comment {}
327 set headline {}
328 set auname {}
329 set audate {}
330 set comname {}
331 set comdate {}
332 set hdrend [string first "\n\n" $contents]
333 if {$hdrend < 0} {
334 # should never happen...
335 set hdrend [string length $contents]
337 set header [string range $contents 0 [expr {$hdrend - 1}]]
338 set comment [string range $contents [expr {$hdrend + 2}] end]
339 foreach line [split $header "\n"] {
340 set tag [lindex $line 0]
341 if {$tag == "author"} {
342 set audate [lindex $line end-1]
343 set auname [lrange $line 1 end-2]
344 } elseif {$tag == "committer"} {
345 set comdate [lindex $line end-1]
346 set comname [lrange $line 1 end-2]
349 set headline {}
350 # take the first non-blank line of the comment as the headline
351 set headline [string trimleft $comment]
352 set i [string first "\n" $headline]
353 if {$i >= 0} {
354 set headline [string range $headline 0 $i]
356 set headline [string trimright $headline]
357 set i [string first "\r" $headline]
358 if {$i >= 0} {
359 set headline [string trimright [string range $headline 0 $i]]
361 if {!$listed} {
362 # git rev-list indents the comment by 4 spaces;
363 # if we got this via git cat-file, add the indentation
364 set newcomment {}
365 foreach line [split $comment "\n"] {
366 append newcomment " "
367 append newcomment $line
368 append newcomment "\n"
370 set comment $newcomment
372 if {$comdate != {}} {
373 set cdate($id) $comdate
375 set commitinfo($id) [list $headline $auname $audate \
376 $comname $comdate $comment]
379 proc getcommit {id} {
380 global commitdata commitinfo
382 if {[info exists commitdata($id)]} {
383 parsecommit $id $commitdata($id) 1
384 } else {
385 readcommit $id
386 if {![info exists commitinfo($id)]} {
387 set commitinfo($id) {"No commit information available"}
390 return 1
393 proc readrefs {} {
394 global tagids idtags headids idheads tagobjid
395 global otherrefids idotherrefs mainhead mainheadid
397 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
398 catch {unset $v}
400 set refd [open [list | git show-ref -d] r]
401 while {[gets $refd line] >= 0} {
402 if {[string index $line 40] ne " "} continue
403 set id [string range $line 0 39]
404 set ref [string range $line 41 end]
405 if {![string match "refs/*" $ref]} continue
406 set name [string range $ref 5 end]
407 if {[string match "remotes/*" $name]} {
408 if {![string match "*/HEAD" $name]} {
409 set headids($name) $id
410 lappend idheads($id) $name
412 } elseif {[string match "heads/*" $name]} {
413 set name [string range $name 6 end]
414 set headids($name) $id
415 lappend idheads($id) $name
416 } elseif {[string match "tags/*" $name]} {
417 # this lets refs/tags/foo^{} overwrite refs/tags/foo,
418 # which is what we want since the former is the commit ID
419 set name [string range $name 5 end]
420 if {[string match "*^{}" $name]} {
421 set name [string range $name 0 end-3]
422 } else {
423 set tagobjid($name) $id
425 set tagids($name) $id
426 lappend idtags($id) $name
427 } else {
428 set otherrefids($name) $id
429 lappend idotherrefs($id) $name
432 catch {close $refd}
433 set mainhead {}
434 set mainheadid {}
435 catch {
436 set thehead [exec git symbolic-ref HEAD]
437 if {[string match "refs/heads/*" $thehead]} {
438 set mainhead [string range $thehead 11 end]
439 if {[info exists headids($mainhead)]} {
440 set mainheadid $headids($mainhead)
446 # skip over fake commits
447 proc first_real_row {} {
448 global nullid nullid2 displayorder numcommits
450 for {set row 0} {$row < $numcommits} {incr row} {
451 set id [lindex $displayorder $row]
452 if {$id ne $nullid && $id ne $nullid2} {
453 break
456 return $row
459 # update things for a head moved to a child of its previous location
460 proc movehead {id name} {
461 global headids idheads
463 removehead $headids($name) $name
464 set headids($name) $id
465 lappend idheads($id) $name
468 # update things when a head has been removed
469 proc removehead {id name} {
470 global headids idheads
472 if {$idheads($id) eq $name} {
473 unset idheads($id)
474 } else {
475 set i [lsearch -exact $idheads($id) $name]
476 if {$i >= 0} {
477 set idheads($id) [lreplace $idheads($id) $i $i]
480 unset headids($name)
483 proc show_error {w top msg} {
484 message $w.m -text $msg -justify center -aspect 400
485 pack $w.m -side top -fill x -padx 20 -pady 20
486 button $w.ok -text OK -command "destroy $top"
487 pack $w.ok -side bottom -fill x
488 bind $top <Visibility> "grab $top; focus $top"
489 bind $top <Key-Return> "destroy $top"
490 tkwait window $top
493 proc error_popup msg {
494 set w .error
495 toplevel $w
496 wm transient $w .
497 show_error $w $w $msg
500 proc confirm_popup msg {
501 global confirm_ok
502 set confirm_ok 0
503 set w .confirm
504 toplevel $w
505 wm transient $w .
506 message $w.m -text $msg -justify center -aspect 400
507 pack $w.m -side top -fill x -padx 20 -pady 20
508 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
509 pack $w.ok -side left -fill x
510 button $w.cancel -text Cancel -command "destroy $w"
511 pack $w.cancel -side right -fill x
512 bind $w <Visibility> "grab $w; focus $w"
513 tkwait window $w
514 return $confirm_ok
517 proc makewindow {} {
518 global canv canv2 canv3 linespc charspc ctext cflist
519 global textfont mainfont uifont tabstop
520 global findtype findtypemenu findloc findstring fstring geometry
521 global entries sha1entry sha1string sha1but
522 global diffcontextstring diffcontext
523 global maincursor textcursor curtextcursor
524 global rowctxmenu fakerowmenu mergemax wrapcomment
525 global highlight_files gdttype
526 global searchstring sstring
527 global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
528 global headctxmenu
530 menu .bar
531 .bar add cascade -label "File" -menu .bar.file
532 .bar configure -font $uifont
533 menu .bar.file
534 .bar.file add command -label "Update" -command updatecommits
535 .bar.file add command -label "Reread references" -command rereadrefs
536 .bar.file add command -label "List references" -command showrefs
537 .bar.file add command -label "Quit" -command doquit
538 .bar.file configure -font $uifont
539 menu .bar.edit
540 .bar add cascade -label "Edit" -menu .bar.edit
541 .bar.edit add command -label "Preferences" -command doprefs
542 .bar.edit configure -font $uifont
544 menu .bar.view -font $uifont
545 .bar add cascade -label "View" -menu .bar.view
546 .bar.view add command -label "New view..." -command {newview 0}
547 .bar.view add command -label "Edit view..." -command editview \
548 -state disabled
549 .bar.view add command -label "Delete view" -command delview -state disabled
550 .bar.view add separator
551 .bar.view add radiobutton -label "All files" -command {showview 0} \
552 -variable selectedview -value 0
554 menu .bar.help
555 .bar add cascade -label "Help" -menu .bar.help
556 .bar.help add command -label "About gitk" -command about
557 .bar.help add command -label "Key bindings" -command keys
558 .bar.help configure -font $uifont
559 . configure -menu .bar
561 # the gui has upper and lower half, parts of a paned window.
562 panedwindow .ctop -orient vertical
564 # possibly use assumed geometry
565 if {![info exists geometry(pwsash0)]} {
566 set geometry(topheight) [expr {15 * $linespc}]
567 set geometry(topwidth) [expr {80 * $charspc}]
568 set geometry(botheight) [expr {15 * $linespc}]
569 set geometry(botwidth) [expr {50 * $charspc}]
570 set geometry(pwsash0) "[expr {40 * $charspc}] 2"
571 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
574 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
575 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
576 frame .tf.histframe
577 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
579 # create three canvases
580 set cscroll .tf.histframe.csb
581 set canv .tf.histframe.pwclist.canv
582 canvas $canv \
583 -selectbackground $selectbgcolor \
584 -background $bgcolor -bd 0 \
585 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
586 .tf.histframe.pwclist add $canv
587 set canv2 .tf.histframe.pwclist.canv2
588 canvas $canv2 \
589 -selectbackground $selectbgcolor \
590 -background $bgcolor -bd 0 -yscrollincr $linespc
591 .tf.histframe.pwclist add $canv2
592 set canv3 .tf.histframe.pwclist.canv3
593 canvas $canv3 \
594 -selectbackground $selectbgcolor \
595 -background $bgcolor -bd 0 -yscrollincr $linespc
596 .tf.histframe.pwclist add $canv3
597 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
598 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
600 # a scroll bar to rule them
601 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
602 pack $cscroll -side right -fill y
603 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
604 lappend bglist $canv $canv2 $canv3
605 pack .tf.histframe.pwclist -fill both -expand 1 -side left
607 # we have two button bars at bottom of top frame. Bar 1
608 frame .tf.bar
609 frame .tf.lbar -height 15
611 set sha1entry .tf.bar.sha1
612 set entries $sha1entry
613 set sha1but .tf.bar.sha1label
614 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
615 -command gotocommit -width 8 -font $uifont
616 $sha1but conf -disabledforeground [$sha1but cget -foreground]
617 pack .tf.bar.sha1label -side left
618 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
619 trace add variable sha1string write sha1change
620 pack $sha1entry -side left -pady 2
622 image create bitmap bm-left -data {
623 #define left_width 16
624 #define left_height 16
625 static unsigned char left_bits[] = {
626 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
627 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
628 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
630 image create bitmap bm-right -data {
631 #define right_width 16
632 #define right_height 16
633 static unsigned char right_bits[] = {
634 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
635 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
636 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
638 button .tf.bar.leftbut -image bm-left -command goback \
639 -state disabled -width 26
640 pack .tf.bar.leftbut -side left -fill y
641 button .tf.bar.rightbut -image bm-right -command goforw \
642 -state disabled -width 26
643 pack .tf.bar.rightbut -side left -fill y
645 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
646 pack .tf.bar.findbut -side left
647 set findstring {}
648 set fstring .tf.bar.findstring
649 lappend entries $fstring
650 entry $fstring -width 30 -font $textfont -textvariable findstring
651 trace add variable findstring write find_change
652 pack $fstring -side left -expand 1 -fill x -in .tf.bar
653 set findtype Exact
654 set findtypemenu [tk_optionMenu .tf.bar.findtype \
655 findtype Exact IgnCase Regexp]
656 trace add variable findtype write find_change
657 .tf.bar.findtype configure -font $uifont
658 .tf.bar.findtype.menu configure -font $uifont
659 set findloc "All fields"
660 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
661 Comments Author Committer
662 trace add variable findloc write find_change
663 .tf.bar.findloc configure -font $uifont
664 .tf.bar.findloc.menu configure -font $uifont
665 pack .tf.bar.findloc -side right
666 pack .tf.bar.findtype -side right
668 # build up the bottom bar of upper window
669 label .tf.lbar.flabel -text "Highlight: Commits " \
670 -font $uifont
671 pack .tf.lbar.flabel -side left -fill y
672 set gdttype "touching paths:"
673 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
674 "adding/removing string:"]
675 trace add variable gdttype write hfiles_change
676 $gm conf -font $uifont
677 .tf.lbar.gdttype conf -font $uifont
678 pack .tf.lbar.gdttype -side left -fill y
679 entry .tf.lbar.fent -width 25 -font $textfont \
680 -textvariable highlight_files
681 trace add variable highlight_files write hfiles_change
682 lappend entries .tf.lbar.fent
683 pack .tf.lbar.fent -side left -fill x -expand 1
684 label .tf.lbar.vlabel -text " OR in view" -font $uifont
685 pack .tf.lbar.vlabel -side left -fill y
686 global viewhlmenu selectedhlview
687 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
688 $viewhlmenu entryconf None -command delvhighlight
689 $viewhlmenu conf -font $uifont
690 .tf.lbar.vhl conf -font $uifont
691 pack .tf.lbar.vhl -side left -fill y
692 label .tf.lbar.rlabel -text " OR " -font $uifont
693 pack .tf.lbar.rlabel -side left -fill y
694 global highlight_related
695 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
696 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
697 $m conf -font $uifont
698 .tf.lbar.relm conf -font $uifont
699 trace add variable highlight_related write vrel_change
700 pack .tf.lbar.relm -side left -fill y
702 # Finish putting the upper half of the viewer together
703 pack .tf.lbar -in .tf -side bottom -fill x
704 pack .tf.bar -in .tf -side bottom -fill x
705 pack .tf.histframe -fill both -side top -expand 1
706 .ctop add .tf
707 .ctop paneconfigure .tf -height $geometry(topheight)
708 .ctop paneconfigure .tf -width $geometry(topwidth)
710 # now build up the bottom
711 panedwindow .pwbottom -orient horizontal
713 # lower left, a text box over search bar, scroll bar to the right
714 # if we know window height, then that will set the lower text height, otherwise
715 # we set lower text height which will drive window height
716 if {[info exists geometry(main)]} {
717 frame .bleft -width $geometry(botwidth)
718 } else {
719 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
721 frame .bleft.top
722 frame .bleft.mid
724 button .bleft.top.search -text "Search" -command dosearch \
725 -font $uifont
726 pack .bleft.top.search -side left -padx 5
727 set sstring .bleft.top.sstring
728 entry $sstring -width 20 -font $textfont -textvariable searchstring
729 lappend entries $sstring
730 trace add variable searchstring write incrsearch
731 pack $sstring -side left -expand 1 -fill x
732 radiobutton .bleft.mid.diff -text "Diff" \
733 -command changediffdisp -variable diffelide -value {0 0}
734 radiobutton .bleft.mid.old -text "Old version" \
735 -command changediffdisp -variable diffelide -value {0 1}
736 radiobutton .bleft.mid.new -text "New version" \
737 -command changediffdisp -variable diffelide -value {1 0}
738 label .bleft.mid.labeldiffcontext -text " Lines of context: " \
739 -font $uifont
740 pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
741 spinbox .bleft.mid.diffcontext -width 5 -font $textfont \
742 -from 1 -increment 1 -to 10000000 \
743 -validate all -validatecommand "diffcontextvalidate %P" \
744 -textvariable diffcontextstring
745 .bleft.mid.diffcontext set $diffcontext
746 trace add variable diffcontextstring write diffcontextchange
747 lappend entries .bleft.mid.diffcontext
748 pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
749 set ctext .bleft.ctext
750 text $ctext -background $bgcolor -foreground $fgcolor \
751 -tabs "[expr {$tabstop * $charspc}]" \
752 -state disabled -font $textfont \
753 -yscrollcommand scrolltext -wrap none
754 scrollbar .bleft.sb -command "$ctext yview"
755 pack .bleft.top -side top -fill x
756 pack .bleft.mid -side top -fill x
757 pack .bleft.sb -side right -fill y
758 pack $ctext -side left -fill both -expand 1
759 lappend bglist $ctext
760 lappend fglist $ctext
762 $ctext tag conf comment -wrap $wrapcomment
763 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
764 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
765 $ctext tag conf d0 -fore [lindex $diffcolors 0]
766 $ctext tag conf d1 -fore [lindex $diffcolors 1]
767 $ctext tag conf m0 -fore red
768 $ctext tag conf m1 -fore blue
769 $ctext tag conf m2 -fore green
770 $ctext tag conf m3 -fore purple
771 $ctext tag conf m4 -fore brown
772 $ctext tag conf m5 -fore "#009090"
773 $ctext tag conf m6 -fore magenta
774 $ctext tag conf m7 -fore "#808000"
775 $ctext tag conf m8 -fore "#009000"
776 $ctext tag conf m9 -fore "#ff0080"
777 $ctext tag conf m10 -fore cyan
778 $ctext tag conf m11 -fore "#b07070"
779 $ctext tag conf m12 -fore "#70b0f0"
780 $ctext tag conf m13 -fore "#70f0b0"
781 $ctext tag conf m14 -fore "#f0b070"
782 $ctext tag conf m15 -fore "#ff70b0"
783 $ctext tag conf mmax -fore darkgrey
784 set mergemax 16
785 $ctext tag conf mresult -font [concat $textfont bold]
786 $ctext tag conf msep -font [concat $textfont bold]
787 $ctext tag conf found -back yellow
789 .pwbottom add .bleft
790 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
792 # lower right
793 frame .bright
794 frame .bright.mode
795 radiobutton .bright.mode.patch -text "Patch" \
796 -command reselectline -variable cmitmode -value "patch"
797 .bright.mode.patch configure -font $uifont
798 radiobutton .bright.mode.tree -text "Tree" \
799 -command reselectline -variable cmitmode -value "tree"
800 .bright.mode.tree configure -font $uifont
801 grid .bright.mode.patch .bright.mode.tree -sticky ew
802 pack .bright.mode -side top -fill x
803 set cflist .bright.cfiles
804 set indent [font measure $mainfont "nn"]
805 text $cflist \
806 -selectbackground $selectbgcolor \
807 -background $bgcolor -foreground $fgcolor \
808 -font $mainfont \
809 -tabs [list $indent [expr {2 * $indent}]] \
810 -yscrollcommand ".bright.sb set" \
811 -cursor [. cget -cursor] \
812 -spacing1 1 -spacing3 1
813 lappend bglist $cflist
814 lappend fglist $cflist
815 scrollbar .bright.sb -command "$cflist yview"
816 pack .bright.sb -side right -fill y
817 pack $cflist -side left -fill both -expand 1
818 $cflist tag configure highlight \
819 -background [$cflist cget -selectbackground]
820 $cflist tag configure bold -font [concat $mainfont bold]
822 .pwbottom add .bright
823 .ctop add .pwbottom
825 # restore window position if known
826 if {[info exists geometry(main)]} {
827 wm geometry . "$geometry(main)"
830 if {[tk windowingsystem] eq {aqua}} {
831 set M1B M1
832 } else {
833 set M1B Control
836 bind .pwbottom <Configure> {resizecdetpanes %W %w}
837 pack .ctop -fill both -expand 1
838 bindall <1> {selcanvline %W %x %y}
839 #bindall <B1-Motion> {selcanvline %W %x %y}
840 if {[tk windowingsystem] == "win32"} {
841 bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
842 bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
843 } else {
844 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
845 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
847 bindall <2> "canvscan mark %W %x %y"
848 bindall <B2-Motion> "canvscan dragto %W %x %y"
849 bindkey <Home> selfirstline
850 bindkey <End> sellastline
851 bind . <Key-Up> "selnextline -1"
852 bind . <Key-Down> "selnextline 1"
853 bind . <Shift-Key-Up> "next_highlight -1"
854 bind . <Shift-Key-Down> "next_highlight 1"
855 bindkey <Key-Right> "goforw"
856 bindkey <Key-Left> "goback"
857 bind . <Key-Prior> "selnextpage -1"
858 bind . <Key-Next> "selnextpage 1"
859 bind . <$M1B-Home> "allcanvs yview moveto 0.0"
860 bind . <$M1B-End> "allcanvs yview moveto 1.0"
861 bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
862 bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
863 bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
864 bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
865 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
866 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
867 bindkey <Key-space> "$ctext yview scroll 1 pages"
868 bindkey p "selnextline -1"
869 bindkey n "selnextline 1"
870 bindkey z "goback"
871 bindkey x "goforw"
872 bindkey i "selnextline -1"
873 bindkey k "selnextline 1"
874 bindkey j "goback"
875 bindkey l "goforw"
876 bindkey b "$ctext yview scroll -1 pages"
877 bindkey d "$ctext yview scroll 18 units"
878 bindkey u "$ctext yview scroll -18 units"
879 bindkey / {findnext 1}
880 bindkey <Key-Return> {findnext 0}
881 bindkey ? findprev
882 bindkey f nextfile
883 bindkey <F5> updatecommits
884 bind . <$M1B-q> doquit
885 bind . <$M1B-f> dofind
886 bind . <$M1B-g> {findnext 0}
887 bind . <$M1B-r> dosearchback
888 bind . <$M1B-s> dosearch
889 bind . <$M1B-equal> {incrfont 1}
890 bind . <$M1B-KP_Add> {incrfont 1}
891 bind . <$M1B-minus> {incrfont -1}
892 bind . <$M1B-KP_Subtract> {incrfont -1}
893 wm protocol . WM_DELETE_WINDOW doquit
894 bind . <Button-1> "click %W"
895 bind $fstring <Key-Return> dofind
896 bind $sha1entry <Key-Return> gotocommit
897 bind $sha1entry <<PasteSelection>> clearsha1
898 bind $cflist <1> {sel_flist %W %x %y; break}
899 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
900 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
901 bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
903 set maincursor [. cget -cursor]
904 set textcursor [$ctext cget -cursor]
905 set curtextcursor $textcursor
907 set rowctxmenu .rowctxmenu
908 menu $rowctxmenu -tearoff 0
909 $rowctxmenu add command -label "Diff this -> selected" \
910 -command {diffvssel 0}
911 $rowctxmenu add command -label "Diff selected -> this" \
912 -command {diffvssel 1}
913 $rowctxmenu add command -label "Make patch" -command mkpatch
914 $rowctxmenu add command -label "Create tag" -command mktag
915 $rowctxmenu add command -label "Write commit to file" -command writecommit
916 $rowctxmenu add command -label "Create new branch" -command mkbranch
917 $rowctxmenu add command -label "Cherry-pick this commit" \
918 -command cherrypick
919 $rowctxmenu add command -label "Reset HEAD branch to here" \
920 -command resethead
922 set fakerowmenu .fakerowmenu
923 menu $fakerowmenu -tearoff 0
924 $fakerowmenu add command -label "Diff this -> selected" \
925 -command {diffvssel 0}
926 $fakerowmenu add command -label "Diff selected -> this" \
927 -command {diffvssel 1}
928 $fakerowmenu add command -label "Make patch" -command mkpatch
929 # $fakerowmenu add command -label "Commit" -command {mkcommit 0}
930 # $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
931 # $fakerowmenu add command -label "Revert local changes" -command revertlocal
933 set headctxmenu .headctxmenu
934 menu $headctxmenu -tearoff 0
935 $headctxmenu add command -label "Check out this branch" \
936 -command cobranch
937 $headctxmenu add command -label "Remove this branch" \
938 -command rmbranch
940 global flist_menu
941 set flist_menu .flistctxmenu
942 menu $flist_menu -tearoff 0
943 $flist_menu add command -label "Highlight this too" \
944 -command {flist_hl 0}
945 $flist_menu add command -label "Highlight this only" \
946 -command {flist_hl 1}
949 # Windows sends all mouse wheel events to the current focused window, not
950 # the one where the mouse hovers, so bind those events here and redirect
951 # to the correct window
952 proc windows_mousewheel_redirector {W X Y D} {
953 global canv canv2 canv3
954 set w [winfo containing -displayof $W $X $Y]
955 if {$w ne ""} {
956 set u [expr {$D < 0 ? 5 : -5}]
957 if {$w == $canv || $w == $canv2 || $w == $canv3} {
958 allcanvs yview scroll $u units
959 } else {
960 catch {
961 $w yview scroll $u units
967 # mouse-2 makes all windows scan vertically, but only the one
968 # the cursor is in scans horizontally
969 proc canvscan {op w x y} {
970 global canv canv2 canv3
971 foreach c [list $canv $canv2 $canv3] {
972 if {$c == $w} {
973 $c scan $op $x $y
974 } else {
975 $c scan $op 0 $y
980 proc scrollcanv {cscroll f0 f1} {
981 $cscroll set $f0 $f1
982 drawfrac $f0 $f1
983 flushhighlights
986 # when we make a key binding for the toplevel, make sure
987 # it doesn't get triggered when that key is pressed in the
988 # find string entry widget.
989 proc bindkey {ev script} {
990 global entries
991 bind . $ev $script
992 set escript [bind Entry $ev]
993 if {$escript == {}} {
994 set escript [bind Entry <Key>]
996 foreach e $entries {
997 bind $e $ev "$escript; break"
1001 # set the focus back to the toplevel for any click outside
1002 # the entry widgets
1003 proc click {w} {
1004 global ctext entries
1005 foreach e [concat $entries $ctext] {
1006 if {$w == $e} return
1008 focus .
1011 proc savestuff {w} {
1012 global canv canv2 canv3 ctext cflist mainfont textfont uifont tabstop
1013 global stuffsaved findmergefiles maxgraphpct
1014 global maxwidth showneartags showlocalchanges
1015 global viewname viewfiles viewargs viewperm nextviewnum
1016 global cmitmode wrapcomment datetimeformat
1017 global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1019 if {$stuffsaved} return
1020 if {![winfo viewable .]} return
1021 catch {
1022 set f [open "~/.gitk-new" w]
1023 puts $f [list set mainfont $mainfont]
1024 puts $f [list set textfont $textfont]
1025 puts $f [list set uifont $uifont]
1026 puts $f [list set tabstop $tabstop]
1027 puts $f [list set findmergefiles $findmergefiles]
1028 puts $f [list set maxgraphpct $maxgraphpct]
1029 puts $f [list set maxwidth $maxwidth]
1030 puts $f [list set cmitmode $cmitmode]
1031 puts $f [list set wrapcomment $wrapcomment]
1032 puts $f [list set showneartags $showneartags]
1033 puts $f [list set showlocalchanges $showlocalchanges]
1034 puts $f [list set datetimeformat $datetimeformat]
1035 puts $f [list set bgcolor $bgcolor]
1036 puts $f [list set fgcolor $fgcolor]
1037 puts $f [list set colors $colors]
1038 puts $f [list set diffcolors $diffcolors]
1039 puts $f [list set diffcontext $diffcontext]
1040 puts $f [list set selectbgcolor $selectbgcolor]
1042 puts $f "set geometry(main) [wm geometry .]"
1043 puts $f "set geometry(topwidth) [winfo width .tf]"
1044 puts $f "set geometry(topheight) [winfo height .tf]"
1045 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1046 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1047 puts $f "set geometry(botwidth) [winfo width .bleft]"
1048 puts $f "set geometry(botheight) [winfo height .bleft]"
1050 puts -nonewline $f "set permviews {"
1051 for {set v 0} {$v < $nextviewnum} {incr v} {
1052 if {$viewperm($v)} {
1053 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1056 puts $f "}"
1057 close $f
1058 file rename -force "~/.gitk-new" "~/.gitk"
1060 set stuffsaved 1
1063 proc resizeclistpanes {win w} {
1064 global oldwidth
1065 if {[info exists oldwidth($win)]} {
1066 set s0 [$win sash coord 0]
1067 set s1 [$win sash coord 1]
1068 if {$w < 60} {
1069 set sash0 [expr {int($w/2 - 2)}]
1070 set sash1 [expr {int($w*5/6 - 2)}]
1071 } else {
1072 set factor [expr {1.0 * $w / $oldwidth($win)}]
1073 set sash0 [expr {int($factor * [lindex $s0 0])}]
1074 set sash1 [expr {int($factor * [lindex $s1 0])}]
1075 if {$sash0 < 30} {
1076 set sash0 30
1078 if {$sash1 < $sash0 + 20} {
1079 set sash1 [expr {$sash0 + 20}]
1081 if {$sash1 > $w - 10} {
1082 set sash1 [expr {$w - 10}]
1083 if {$sash0 > $sash1 - 20} {
1084 set sash0 [expr {$sash1 - 20}]
1088 $win sash place 0 $sash0 [lindex $s0 1]
1089 $win sash place 1 $sash1 [lindex $s1 1]
1091 set oldwidth($win) $w
1094 proc resizecdetpanes {win w} {
1095 global oldwidth
1096 if {[info exists oldwidth($win)]} {
1097 set s0 [$win sash coord 0]
1098 if {$w < 60} {
1099 set sash0 [expr {int($w*3/4 - 2)}]
1100 } else {
1101 set factor [expr {1.0 * $w / $oldwidth($win)}]
1102 set sash0 [expr {int($factor * [lindex $s0 0])}]
1103 if {$sash0 < 45} {
1104 set sash0 45
1106 if {$sash0 > $w - 15} {
1107 set sash0 [expr {$w - 15}]
1110 $win sash place 0 $sash0 [lindex $s0 1]
1112 set oldwidth($win) $w
1115 proc allcanvs args {
1116 global canv canv2 canv3
1117 eval $canv $args
1118 eval $canv2 $args
1119 eval $canv3 $args
1122 proc bindall {event action} {
1123 global canv canv2 canv3
1124 bind $canv $event $action
1125 bind $canv2 $event $action
1126 bind $canv3 $event $action
1129 proc about {} {
1130 global uifont
1131 set w .about
1132 if {[winfo exists $w]} {
1133 raise $w
1134 return
1136 toplevel $w
1137 wm title $w "About gitk"
1138 message $w.m -text {
1139 Gitk - a commit viewer for git
1141 Copyright © 2005-2006 Paul Mackerras
1143 Use and redistribute under the terms of the GNU General Public License} \
1144 -justify center -aspect 400 -border 2 -bg white -relief groove
1145 pack $w.m -side top -fill x -padx 2 -pady 2
1146 $w.m configure -font $uifont
1147 button $w.ok -text Close -command "destroy $w" -default active
1148 pack $w.ok -side bottom
1149 $w.ok configure -font $uifont
1150 bind $w <Visibility> "focus $w.ok"
1151 bind $w <Key-Escape> "destroy $w"
1152 bind $w <Key-Return> "destroy $w"
1155 proc keys {} {
1156 global uifont
1157 set w .keys
1158 if {[winfo exists $w]} {
1159 raise $w
1160 return
1162 if {[tk windowingsystem] eq {aqua}} {
1163 set M1T Cmd
1164 } else {
1165 set M1T Ctrl
1167 toplevel $w
1168 wm title $w "Gitk key bindings"
1169 message $w.m -text "
1170 Gitk key bindings:
1172 <$M1T-Q> Quit
1173 <Home> Move to first commit
1174 <End> Move to last commit
1175 <Up>, p, i Move up one commit
1176 <Down>, n, k Move down one commit
1177 <Left>, z, j Go back in history list
1178 <Right>, x, l Go forward in history list
1179 <PageUp> Move up one page in commit list
1180 <PageDown> Move down one page in commit list
1181 <$M1T-Home> Scroll to top of commit list
1182 <$M1T-End> Scroll to bottom of commit list
1183 <$M1T-Up> Scroll commit list up one line
1184 <$M1T-Down> Scroll commit list down one line
1185 <$M1T-PageUp> Scroll commit list up one page
1186 <$M1T-PageDown> Scroll commit list down one page
1187 <Shift-Up> Move to previous highlighted line
1188 <Shift-Down> Move to next highlighted line
1189 <Delete>, b Scroll diff view up one page
1190 <Backspace> Scroll diff view up one page
1191 <Space> Scroll diff view down one page
1192 u Scroll diff view up 18 lines
1193 d Scroll diff view down 18 lines
1194 <$M1T-F> Find
1195 <$M1T-G> Move to next find hit
1196 <Return> Move to next find hit
1197 / Move to next find hit, or redo find
1198 ? Move to previous find hit
1199 f Scroll diff view to next file
1200 <$M1T-S> Search for next hit in diff view
1201 <$M1T-R> Search for previous hit in diff view
1202 <$M1T-KP+> Increase font size
1203 <$M1T-plus> Increase font size
1204 <$M1T-KP-> Decrease font size
1205 <$M1T-minus> Decrease font size
1206 <F5> Update
1208 -justify left -bg white -border 2 -relief groove
1209 pack $w.m -side top -fill both -padx 2 -pady 2
1210 $w.m configure -font $uifont
1211 button $w.ok -text Close -command "destroy $w" -default active
1212 pack $w.ok -side bottom
1213 $w.ok configure -font $uifont
1214 bind $w <Visibility> "focus $w.ok"
1215 bind $w <Key-Escape> "destroy $w"
1216 bind $w <Key-Return> "destroy $w"
1219 # Procedures for manipulating the file list window at the
1220 # bottom right of the overall window.
1222 proc treeview {w l openlevs} {
1223 global treecontents treediropen treeheight treeparent treeindex
1225 set ix 0
1226 set treeindex() 0
1227 set lev 0
1228 set prefix {}
1229 set prefixend -1
1230 set prefendstack {}
1231 set htstack {}
1232 set ht 0
1233 set treecontents() {}
1234 $w conf -state normal
1235 foreach f $l {
1236 while {[string range $f 0 $prefixend] ne $prefix} {
1237 if {$lev <= $openlevs} {
1238 $w mark set e:$treeindex($prefix) "end -1c"
1239 $w mark gravity e:$treeindex($prefix) left
1241 set treeheight($prefix) $ht
1242 incr ht [lindex $htstack end]
1243 set htstack [lreplace $htstack end end]
1244 set prefixend [lindex $prefendstack end]
1245 set prefendstack [lreplace $prefendstack end end]
1246 set prefix [string range $prefix 0 $prefixend]
1247 incr lev -1
1249 set tail [string range $f [expr {$prefixend+1}] end]
1250 while {[set slash [string first "/" $tail]] >= 0} {
1251 lappend htstack $ht
1252 set ht 0
1253 lappend prefendstack $prefixend
1254 incr prefixend [expr {$slash + 1}]
1255 set d [string range $tail 0 $slash]
1256 lappend treecontents($prefix) $d
1257 set oldprefix $prefix
1258 append prefix $d
1259 set treecontents($prefix) {}
1260 set treeindex($prefix) [incr ix]
1261 set treeparent($prefix) $oldprefix
1262 set tail [string range $tail [expr {$slash+1}] end]
1263 if {$lev <= $openlevs} {
1264 set ht 1
1265 set treediropen($prefix) [expr {$lev < $openlevs}]
1266 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1267 $w mark set d:$ix "end -1c"
1268 $w mark gravity d:$ix left
1269 set str "\n"
1270 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1271 $w insert end $str
1272 $w image create end -align center -image $bm -padx 1 \
1273 -name a:$ix
1274 $w insert end $d [highlight_tag $prefix]
1275 $w mark set s:$ix "end -1c"
1276 $w mark gravity s:$ix left
1278 incr lev
1280 if {$tail ne {}} {
1281 if {$lev <= $openlevs} {
1282 incr ht
1283 set str "\n"
1284 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1285 $w insert end $str
1286 $w insert end $tail [highlight_tag $f]
1288 lappend treecontents($prefix) $tail
1291 while {$htstack ne {}} {
1292 set treeheight($prefix) $ht
1293 incr ht [lindex $htstack end]
1294 set htstack [lreplace $htstack end end]
1295 set prefixend [lindex $prefendstack end]
1296 set prefendstack [lreplace $prefendstack end end]
1297 set prefix [string range $prefix 0 $prefixend]
1299 $w conf -state disabled
1302 proc linetoelt {l} {
1303 global treeheight treecontents
1305 set y 2
1306 set prefix {}
1307 while {1} {
1308 foreach e $treecontents($prefix) {
1309 if {$y == $l} {
1310 return "$prefix$e"
1312 set n 1
1313 if {[string index $e end] eq "/"} {
1314 set n $treeheight($prefix$e)
1315 if {$y + $n > $l} {
1316 append prefix $e
1317 incr y
1318 break
1321 incr y $n
1326 proc highlight_tree {y prefix} {
1327 global treeheight treecontents cflist
1329 foreach e $treecontents($prefix) {
1330 set path $prefix$e
1331 if {[highlight_tag $path] ne {}} {
1332 $cflist tag add bold $y.0 "$y.0 lineend"
1334 incr y
1335 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1336 set y [highlight_tree $y $path]
1339 return $y
1342 proc treeclosedir {w dir} {
1343 global treediropen treeheight treeparent treeindex
1345 set ix $treeindex($dir)
1346 $w conf -state normal
1347 $w delete s:$ix e:$ix
1348 set treediropen($dir) 0
1349 $w image configure a:$ix -image tri-rt
1350 $w conf -state disabled
1351 set n [expr {1 - $treeheight($dir)}]
1352 while {$dir ne {}} {
1353 incr treeheight($dir) $n
1354 set dir $treeparent($dir)
1358 proc treeopendir {w dir} {
1359 global treediropen treeheight treeparent treecontents treeindex
1361 set ix $treeindex($dir)
1362 $w conf -state normal
1363 $w image configure a:$ix -image tri-dn
1364 $w mark set e:$ix s:$ix
1365 $w mark gravity e:$ix right
1366 set lev 0
1367 set str "\n"
1368 set n [llength $treecontents($dir)]
1369 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1370 incr lev
1371 append str "\t"
1372 incr treeheight($x) $n
1374 foreach e $treecontents($dir) {
1375 set de $dir$e
1376 if {[string index $e end] eq "/"} {
1377 set iy $treeindex($de)
1378 $w mark set d:$iy e:$ix
1379 $w mark gravity d:$iy left
1380 $w insert e:$ix $str
1381 set treediropen($de) 0
1382 $w image create e:$ix -align center -image tri-rt -padx 1 \
1383 -name a:$iy
1384 $w insert e:$ix $e [highlight_tag $de]
1385 $w mark set s:$iy e:$ix
1386 $w mark gravity s:$iy left
1387 set treeheight($de) 1
1388 } else {
1389 $w insert e:$ix $str
1390 $w insert e:$ix $e [highlight_tag $de]
1393 $w mark gravity e:$ix left
1394 $w conf -state disabled
1395 set treediropen($dir) 1
1396 set top [lindex [split [$w index @0,0] .] 0]
1397 set ht [$w cget -height]
1398 set l [lindex [split [$w index s:$ix] .] 0]
1399 if {$l < $top} {
1400 $w yview $l.0
1401 } elseif {$l + $n + 1 > $top + $ht} {
1402 set top [expr {$l + $n + 2 - $ht}]
1403 if {$l < $top} {
1404 set top $l
1406 $w yview $top.0
1410 proc treeclick {w x y} {
1411 global treediropen cmitmode ctext cflist cflist_top
1413 if {$cmitmode ne "tree"} return
1414 if {![info exists cflist_top]} return
1415 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1416 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1417 $cflist tag add highlight $l.0 "$l.0 lineend"
1418 set cflist_top $l
1419 if {$l == 1} {
1420 $ctext yview 1.0
1421 return
1423 set e [linetoelt $l]
1424 if {[string index $e end] ne "/"} {
1425 showfile $e
1426 } elseif {$treediropen($e)} {
1427 treeclosedir $w $e
1428 } else {
1429 treeopendir $w $e
1433 proc setfilelist {id} {
1434 global treefilelist cflist
1436 treeview $cflist $treefilelist($id) 0
1439 image create bitmap tri-rt -background black -foreground blue -data {
1440 #define tri-rt_width 13
1441 #define tri-rt_height 13
1442 static unsigned char tri-rt_bits[] = {
1443 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1444 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1445 0x00, 0x00};
1446 } -maskdata {
1447 #define tri-rt-mask_width 13
1448 #define tri-rt-mask_height 13
1449 static unsigned char tri-rt-mask_bits[] = {
1450 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1451 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1452 0x08, 0x00};
1454 image create bitmap tri-dn -background black -foreground blue -data {
1455 #define tri-dn_width 13
1456 #define tri-dn_height 13
1457 static unsigned char tri-dn_bits[] = {
1458 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1459 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1460 0x00, 0x00};
1461 } -maskdata {
1462 #define tri-dn-mask_width 13
1463 #define tri-dn-mask_height 13
1464 static unsigned char tri-dn-mask_bits[] = {
1465 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1466 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1467 0x00, 0x00};
1470 image create bitmap reficon-T -background black -foreground yellow -data {
1471 #define tagicon_width 13
1472 #define tagicon_height 9
1473 static unsigned char tagicon_bits[] = {
1474 0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1475 0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1476 } -maskdata {
1477 #define tagicon-mask_width 13
1478 #define tagicon-mask_height 9
1479 static unsigned char tagicon-mask_bits[] = {
1480 0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1481 0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1483 set rectdata {
1484 #define headicon_width 13
1485 #define headicon_height 9
1486 static unsigned char headicon_bits[] = {
1487 0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1488 0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1490 set rectmask {
1491 #define headicon-mask_width 13
1492 #define headicon-mask_height 9
1493 static unsigned char headicon-mask_bits[] = {
1494 0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1495 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1497 image create bitmap reficon-H -background black -foreground green \
1498 -data $rectdata -maskdata $rectmask
1499 image create bitmap reficon-o -background black -foreground "#ddddff" \
1500 -data $rectdata -maskdata $rectmask
1502 proc init_flist {first} {
1503 global cflist cflist_top selectedline difffilestart
1505 $cflist conf -state normal
1506 $cflist delete 0.0 end
1507 if {$first ne {}} {
1508 $cflist insert end $first
1509 set cflist_top 1
1510 $cflist tag add highlight 1.0 "1.0 lineend"
1511 } else {
1512 catch {unset cflist_top}
1514 $cflist conf -state disabled
1515 set difffilestart {}
1518 proc highlight_tag {f} {
1519 global highlight_paths
1521 foreach p $highlight_paths {
1522 if {[string match $p $f]} {
1523 return "bold"
1526 return {}
1529 proc highlight_filelist {} {
1530 global cmitmode cflist
1532 $cflist conf -state normal
1533 if {$cmitmode ne "tree"} {
1534 set end [lindex [split [$cflist index end] .] 0]
1535 for {set l 2} {$l < $end} {incr l} {
1536 set line [$cflist get $l.0 "$l.0 lineend"]
1537 if {[highlight_tag $line] ne {}} {
1538 $cflist tag add bold $l.0 "$l.0 lineend"
1541 } else {
1542 highlight_tree 2 {}
1544 $cflist conf -state disabled
1547 proc unhighlight_filelist {} {
1548 global cflist
1550 $cflist conf -state normal
1551 $cflist tag remove bold 1.0 end
1552 $cflist conf -state disabled
1555 proc add_flist {fl} {
1556 global cflist
1558 $cflist conf -state normal
1559 foreach f $fl {
1560 $cflist insert end "\n"
1561 $cflist insert end $f [highlight_tag $f]
1563 $cflist conf -state disabled
1566 proc sel_flist {w x y} {
1567 global ctext difffilestart cflist cflist_top cmitmode
1569 if {$cmitmode eq "tree"} return
1570 if {![info exists cflist_top]} return
1571 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1572 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1573 $cflist tag add highlight $l.0 "$l.0 lineend"
1574 set cflist_top $l
1575 if {$l == 1} {
1576 $ctext yview 1.0
1577 } else {
1578 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1582 proc pop_flist_menu {w X Y x y} {
1583 global ctext cflist cmitmode flist_menu flist_menu_file
1584 global treediffs diffids
1586 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1587 if {$l <= 1} return
1588 if {$cmitmode eq "tree"} {
1589 set e [linetoelt $l]
1590 if {[string index $e end] eq "/"} return
1591 } else {
1592 set e [lindex $treediffs($diffids) [expr {$l-2}]]
1594 set flist_menu_file $e
1595 tk_popup $flist_menu $X $Y
1598 proc flist_hl {only} {
1599 global flist_menu_file highlight_files
1601 set x [shellquote $flist_menu_file]
1602 if {$only || $highlight_files eq {}} {
1603 set highlight_files $x
1604 } else {
1605 append highlight_files " " $x
1609 # Functions for adding and removing shell-type quoting
1611 proc shellquote {str} {
1612 if {![string match "*\['\"\\ \t]*" $str]} {
1613 return $str
1615 if {![string match "*\['\"\\]*" $str]} {
1616 return "\"$str\""
1618 if {![string match "*'*" $str]} {
1619 return "'$str'"
1621 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1624 proc shellarglist {l} {
1625 set str {}
1626 foreach a $l {
1627 if {$str ne {}} {
1628 append str " "
1630 append str [shellquote $a]
1632 return $str
1635 proc shelldequote {str} {
1636 set ret {}
1637 set used -1
1638 while {1} {
1639 incr used
1640 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1641 append ret [string range $str $used end]
1642 set used [string length $str]
1643 break
1645 set first [lindex $first 0]
1646 set ch [string index $str $first]
1647 if {$first > $used} {
1648 append ret [string range $str $used [expr {$first - 1}]]
1649 set used $first
1651 if {$ch eq " " || $ch eq "\t"} break
1652 incr used
1653 if {$ch eq "'"} {
1654 set first [string first "'" $str $used]
1655 if {$first < 0} {
1656 error "unmatched single-quote"
1658 append ret [string range $str $used [expr {$first - 1}]]
1659 set used $first
1660 continue
1662 if {$ch eq "\\"} {
1663 if {$used >= [string length $str]} {
1664 error "trailing backslash"
1666 append ret [string index $str $used]
1667 continue
1669 # here ch == "\""
1670 while {1} {
1671 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1672 error "unmatched double-quote"
1674 set first [lindex $first 0]
1675 set ch [string index $str $first]
1676 if {$first > $used} {
1677 append ret [string range $str $used [expr {$first - 1}]]
1678 set used $first
1680 if {$ch eq "\""} break
1681 incr used
1682 append ret [string index $str $used]
1683 incr used
1686 return [list $used $ret]
1689 proc shellsplit {str} {
1690 set l {}
1691 while {1} {
1692 set str [string trimleft $str]
1693 if {$str eq {}} break
1694 set dq [shelldequote $str]
1695 set n [lindex $dq 0]
1696 set word [lindex $dq 1]
1697 set str [string range $str $n end]
1698 lappend l $word
1700 return $l
1703 # Code to implement multiple views
1705 proc newview {ishighlight} {
1706 global nextviewnum newviewname newviewperm uifont newishighlight
1707 global newviewargs revtreeargs
1709 set newishighlight $ishighlight
1710 set top .gitkview
1711 if {[winfo exists $top]} {
1712 raise $top
1713 return
1715 set newviewname($nextviewnum) "View $nextviewnum"
1716 set newviewperm($nextviewnum) 0
1717 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1718 vieweditor $top $nextviewnum "Gitk view definition"
1721 proc editview {} {
1722 global curview
1723 global viewname viewperm newviewname newviewperm
1724 global viewargs newviewargs
1726 set top .gitkvedit-$curview
1727 if {[winfo exists $top]} {
1728 raise $top
1729 return
1731 set newviewname($curview) $viewname($curview)
1732 set newviewperm($curview) $viewperm($curview)
1733 set newviewargs($curview) [shellarglist $viewargs($curview)]
1734 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1737 proc vieweditor {top n title} {
1738 global newviewname newviewperm viewfiles
1739 global uifont
1741 toplevel $top
1742 wm title $top $title
1743 label $top.nl -text "Name" -font $uifont
1744 entry $top.name -width 20 -textvariable newviewname($n) -font $uifont
1745 grid $top.nl $top.name -sticky w -pady 5
1746 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1747 -font $uifont
1748 grid $top.perm - -pady 5 -sticky w
1749 message $top.al -aspect 1000 -font $uifont \
1750 -text "Commits to include (arguments to git rev-list):"
1751 grid $top.al - -sticky w -pady 5
1752 entry $top.args -width 50 -textvariable newviewargs($n) \
1753 -background white -font $uifont
1754 grid $top.args - -sticky ew -padx 5
1755 message $top.l -aspect 1000 -font $uifont \
1756 -text "Enter files and directories to include, one per line:"
1757 grid $top.l - -sticky w
1758 text $top.t -width 40 -height 10 -background white -font $uifont
1759 if {[info exists viewfiles($n)]} {
1760 foreach f $viewfiles($n) {
1761 $top.t insert end $f
1762 $top.t insert end "\n"
1764 $top.t delete {end - 1c} end
1765 $top.t mark set insert 0.0
1767 grid $top.t - -sticky ew -padx 5
1768 frame $top.buts
1769 button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1770 -font $uifont
1771 button $top.buts.can -text "Cancel" -command [list destroy $top] \
1772 -font $uifont
1773 grid $top.buts.ok $top.buts.can
1774 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1775 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1776 grid $top.buts - -pady 10 -sticky ew
1777 focus $top.t
1780 proc doviewmenu {m first cmd op argv} {
1781 set nmenu [$m index end]
1782 for {set i $first} {$i <= $nmenu} {incr i} {
1783 if {[$m entrycget $i -command] eq $cmd} {
1784 eval $m $op $i $argv
1785 break
1790 proc allviewmenus {n op args} {
1791 global viewhlmenu
1793 doviewmenu .bar.view 5 [list showview $n] $op $args
1794 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1797 proc newviewok {top n} {
1798 global nextviewnum newviewperm newviewname newishighlight
1799 global viewname viewfiles viewperm selectedview curview
1800 global viewargs newviewargs viewhlmenu
1802 if {[catch {
1803 set newargs [shellsplit $newviewargs($n)]
1804 } err]} {
1805 error_popup "Error in commit selection arguments: $err"
1806 wm raise $top
1807 focus $top
1808 return
1810 set files {}
1811 foreach f [split [$top.t get 0.0 end] "\n"] {
1812 set ft [string trim $f]
1813 if {$ft ne {}} {
1814 lappend files $ft
1817 if {![info exists viewfiles($n)]} {
1818 # creating a new view
1819 incr nextviewnum
1820 set viewname($n) $newviewname($n)
1821 set viewperm($n) $newviewperm($n)
1822 set viewfiles($n) $files
1823 set viewargs($n) $newargs
1824 addviewmenu $n
1825 if {!$newishighlight} {
1826 run showview $n
1827 } else {
1828 run addvhighlight $n
1830 } else {
1831 # editing an existing view
1832 set viewperm($n) $newviewperm($n)
1833 if {$newviewname($n) ne $viewname($n)} {
1834 set viewname($n) $newviewname($n)
1835 doviewmenu .bar.view 5 [list showview $n] \
1836 entryconf [list -label $viewname($n)]
1837 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1838 entryconf [list -label $viewname($n) -value $viewname($n)]
1840 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1841 set viewfiles($n) $files
1842 set viewargs($n) $newargs
1843 if {$curview == $n} {
1844 run updatecommits
1848 catch {destroy $top}
1851 proc delview {} {
1852 global curview viewdata viewperm hlview selectedhlview
1854 if {$curview == 0} return
1855 if {[info exists hlview] && $hlview == $curview} {
1856 set selectedhlview None
1857 unset hlview
1859 allviewmenus $curview delete
1860 set viewdata($curview) {}
1861 set viewperm($curview) 0
1862 showview 0
1865 proc addviewmenu {n} {
1866 global viewname viewhlmenu
1868 .bar.view add radiobutton -label $viewname($n) \
1869 -command [list showview $n] -variable selectedview -value $n
1870 $viewhlmenu add radiobutton -label $viewname($n) \
1871 -command [list addvhighlight $n] -variable selectedhlview
1874 proc flatten {var} {
1875 global $var
1877 set ret {}
1878 foreach i [array names $var] {
1879 lappend ret $i [set $var\($i\)]
1881 return $ret
1884 proc unflatten {var l} {
1885 global $var
1887 catch {unset $var}
1888 foreach {i v} $l {
1889 set $var\($i\) $v
1893 proc showview {n} {
1894 global curview viewdata viewfiles
1895 global displayorder parentlist rowidlist rowoffsets
1896 global colormap rowtextx commitrow nextcolor canvxmax
1897 global numcommits rowrangelist commitlisted idrowranges rowchk
1898 global selectedline currentid canv canvy0
1899 global treediffs
1900 global pending_select phase
1901 global commitidx rowlaidout rowoptim
1902 global commfd
1903 global selectedview selectfirst
1904 global vparentlist vdisporder vcmitlisted
1905 global hlview selectedhlview
1907 if {$n == $curview} return
1908 set selid {}
1909 if {[info exists selectedline]} {
1910 set selid $currentid
1911 set y [yc $selectedline]
1912 set ymax [lindex [$canv cget -scrollregion] 3]
1913 set span [$canv yview]
1914 set ytop [expr {[lindex $span 0] * $ymax}]
1915 set ybot [expr {[lindex $span 1] * $ymax}]
1916 if {$ytop < $y && $y < $ybot} {
1917 set yscreen [expr {$y - $ytop}]
1918 } else {
1919 set yscreen [expr {($ybot - $ytop) / 2}]
1921 } elseif {[info exists pending_select]} {
1922 set selid $pending_select
1923 unset pending_select
1925 unselectline
1926 normalline
1927 if {$curview >= 0} {
1928 set vparentlist($curview) $parentlist
1929 set vdisporder($curview) $displayorder
1930 set vcmitlisted($curview) $commitlisted
1931 if {$phase ne {}} {
1932 set viewdata($curview) \
1933 [list $phase $rowidlist $rowoffsets $rowrangelist \
1934 [flatten idrowranges] [flatten idinlist] \
1935 $rowlaidout $rowoptim $numcommits]
1936 } elseif {![info exists viewdata($curview)]
1937 || [lindex $viewdata($curview) 0] ne {}} {
1938 set viewdata($curview) \
1939 [list {} $rowidlist $rowoffsets $rowrangelist]
1942 catch {unset treediffs}
1943 clear_display
1944 if {[info exists hlview] && $hlview == $n} {
1945 unset hlview
1946 set selectedhlview None
1949 set curview $n
1950 set selectedview $n
1951 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1952 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1954 if {![info exists viewdata($n)]} {
1955 if {$selid ne {}} {
1956 set pending_select $selid
1958 getcommits
1959 return
1962 set v $viewdata($n)
1963 set phase [lindex $v 0]
1964 set displayorder $vdisporder($n)
1965 set parentlist $vparentlist($n)
1966 set commitlisted $vcmitlisted($n)
1967 set rowidlist [lindex $v 1]
1968 set rowoffsets [lindex $v 2]
1969 set rowrangelist [lindex $v 3]
1970 if {$phase eq {}} {
1971 set numcommits [llength $displayorder]
1972 catch {unset idrowranges}
1973 } else {
1974 unflatten idrowranges [lindex $v 4]
1975 unflatten idinlist [lindex $v 5]
1976 set rowlaidout [lindex $v 6]
1977 set rowoptim [lindex $v 7]
1978 set numcommits [lindex $v 8]
1979 catch {unset rowchk}
1982 catch {unset colormap}
1983 catch {unset rowtextx}
1984 set nextcolor 0
1985 set canvxmax [$canv cget -width]
1986 set curview $n
1987 set row 0
1988 setcanvscroll
1989 set yf 0
1990 set row {}
1991 set selectfirst 0
1992 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1993 set row $commitrow($n,$selid)
1994 # try to get the selected row in the same position on the screen
1995 set ymax [lindex [$canv cget -scrollregion] 3]
1996 set ytop [expr {[yc $row] - $yscreen}]
1997 if {$ytop < 0} {
1998 set ytop 0
2000 set yf [expr {$ytop * 1.0 / $ymax}]
2002 allcanvs yview moveto $yf
2003 drawvisible
2004 if {$row ne {}} {
2005 selectline $row 0
2006 } elseif {$selid ne {}} {
2007 set pending_select $selid
2008 } else {
2009 set row [first_real_row]
2010 if {$row < $numcommits} {
2011 selectline $row 0
2012 } else {
2013 set selectfirst 1
2016 if {$phase ne {}} {
2017 if {$phase eq "getcommits"} {
2018 show_status "Reading commits..."
2020 run chewcommits $n
2021 } elseif {$numcommits == 0} {
2022 show_status "No commits selected"
2024 run refill_reflist
2027 # Stuff relating to the highlighting facility
2029 proc ishighlighted {row} {
2030 global vhighlights fhighlights nhighlights rhighlights
2032 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2033 return $nhighlights($row)
2035 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2036 return $vhighlights($row)
2038 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2039 return $fhighlights($row)
2041 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2042 return $rhighlights($row)
2044 return 0
2047 proc bolden {row font} {
2048 global canv linehtag selectedline boldrows
2050 lappend boldrows $row
2051 $canv itemconf $linehtag($row) -font $font
2052 if {[info exists selectedline] && $row == $selectedline} {
2053 $canv delete secsel
2054 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2055 -outline {{}} -tags secsel \
2056 -fill [$canv cget -selectbackground]]
2057 $canv lower $t
2061 proc bolden_name {row font} {
2062 global canv2 linentag selectedline boldnamerows
2064 lappend boldnamerows $row
2065 $canv2 itemconf $linentag($row) -font $font
2066 if {[info exists selectedline] && $row == $selectedline} {
2067 $canv2 delete secsel
2068 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2069 -outline {{}} -tags secsel \
2070 -fill [$canv2 cget -selectbackground]]
2071 $canv2 lower $t
2075 proc unbolden {} {
2076 global mainfont boldrows
2078 set stillbold {}
2079 foreach row $boldrows {
2080 if {![ishighlighted $row]} {
2081 bolden $row $mainfont
2082 } else {
2083 lappend stillbold $row
2086 set boldrows $stillbold
2089 proc addvhighlight {n} {
2090 global hlview curview viewdata vhl_done vhighlights commitidx
2092 if {[info exists hlview]} {
2093 delvhighlight
2095 set hlview $n
2096 if {$n != $curview && ![info exists viewdata($n)]} {
2097 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
2098 set vparentlist($n) {}
2099 set vdisporder($n) {}
2100 set vcmitlisted($n) {}
2101 start_rev_list $n
2103 set vhl_done $commitidx($hlview)
2104 if {$vhl_done > 0} {
2105 drawvisible
2109 proc delvhighlight {} {
2110 global hlview vhighlights
2112 if {![info exists hlview]} return
2113 unset hlview
2114 catch {unset vhighlights}
2115 unbolden
2118 proc vhighlightmore {} {
2119 global hlview vhl_done commitidx vhighlights
2120 global displayorder vdisporder curview mainfont
2122 set font [concat $mainfont bold]
2123 set max $commitidx($hlview)
2124 if {$hlview == $curview} {
2125 set disp $displayorder
2126 } else {
2127 set disp $vdisporder($hlview)
2129 set vr [visiblerows]
2130 set r0 [lindex $vr 0]
2131 set r1 [lindex $vr 1]
2132 for {set i $vhl_done} {$i < $max} {incr i} {
2133 set id [lindex $disp $i]
2134 if {[info exists commitrow($curview,$id)]} {
2135 set row $commitrow($curview,$id)
2136 if {$r0 <= $row && $row <= $r1} {
2137 if {![highlighted $row]} {
2138 bolden $row $font
2140 set vhighlights($row) 1
2144 set vhl_done $max
2147 proc askvhighlight {row id} {
2148 global hlview vhighlights commitrow iddrawn mainfont
2150 if {[info exists commitrow($hlview,$id)]} {
2151 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2152 bolden $row [concat $mainfont bold]
2154 set vhighlights($row) 1
2155 } else {
2156 set vhighlights($row) 0
2160 proc hfiles_change {name ix op} {
2161 global highlight_files filehighlight fhighlights fh_serial
2162 global mainfont highlight_paths
2164 if {[info exists filehighlight]} {
2165 # delete previous highlights
2166 catch {close $filehighlight}
2167 unset filehighlight
2168 catch {unset fhighlights}
2169 unbolden
2170 unhighlight_filelist
2172 set highlight_paths {}
2173 after cancel do_file_hl $fh_serial
2174 incr fh_serial
2175 if {$highlight_files ne {}} {
2176 after 300 do_file_hl $fh_serial
2180 proc makepatterns {l} {
2181 set ret {}
2182 foreach e $l {
2183 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2184 if {[string index $ee end] eq "/"} {
2185 lappend ret "$ee*"
2186 } else {
2187 lappend ret $ee
2188 lappend ret "$ee/*"
2191 return $ret
2194 proc do_file_hl {serial} {
2195 global highlight_files filehighlight highlight_paths gdttype fhl_list
2197 if {$gdttype eq "touching paths:"} {
2198 if {[catch {set paths [shellsplit $highlight_files]}]} return
2199 set highlight_paths [makepatterns $paths]
2200 highlight_filelist
2201 set gdtargs [concat -- $paths]
2202 } else {
2203 set gdtargs [list "-S$highlight_files"]
2205 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2206 set filehighlight [open $cmd r+]
2207 fconfigure $filehighlight -blocking 0
2208 filerun $filehighlight readfhighlight
2209 set fhl_list {}
2210 drawvisible
2211 flushhighlights
2214 proc flushhighlights {} {
2215 global filehighlight fhl_list
2217 if {[info exists filehighlight]} {
2218 lappend fhl_list {}
2219 puts $filehighlight ""
2220 flush $filehighlight
2224 proc askfilehighlight {row id} {
2225 global filehighlight fhighlights fhl_list
2227 lappend fhl_list $id
2228 set fhighlights($row) -1
2229 puts $filehighlight $id
2232 proc readfhighlight {} {
2233 global filehighlight fhighlights commitrow curview mainfont iddrawn
2234 global fhl_list
2236 if {![info exists filehighlight]} {
2237 return 0
2239 set nr 0
2240 while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2241 set line [string trim $line]
2242 set i [lsearch -exact $fhl_list $line]
2243 if {$i < 0} continue
2244 for {set j 0} {$j < $i} {incr j} {
2245 set id [lindex $fhl_list $j]
2246 if {[info exists commitrow($curview,$id)]} {
2247 set fhighlights($commitrow($curview,$id)) 0
2250 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2251 if {$line eq {}} continue
2252 if {![info exists commitrow($curview,$line)]} continue
2253 set row $commitrow($curview,$line)
2254 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2255 bolden $row [concat $mainfont bold]
2257 set fhighlights($row) 1
2259 if {[eof $filehighlight]} {
2260 # strange...
2261 puts "oops, git diff-tree died"
2262 catch {close $filehighlight}
2263 unset filehighlight
2264 return 0
2266 next_hlcont
2267 return 1
2270 proc find_change {name ix op} {
2271 global nhighlights mainfont boldnamerows
2272 global findstring findpattern findtype
2274 # delete previous highlights, if any
2275 foreach row $boldnamerows {
2276 bolden_name $row $mainfont
2278 set boldnamerows {}
2279 catch {unset nhighlights}
2280 unbolden
2281 unmarkmatches
2282 if {$findtype ne "Regexp"} {
2283 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2284 $findstring]
2285 set findpattern "*$e*"
2287 drawvisible
2290 proc doesmatch {f} {
2291 global findtype findstring findpattern
2293 if {$findtype eq "Regexp"} {
2294 return [regexp $findstring $f]
2295 } elseif {$findtype eq "IgnCase"} {
2296 return [string match -nocase $findpattern $f]
2297 } else {
2298 return [string match $findpattern $f]
2302 proc askfindhighlight {row id} {
2303 global nhighlights commitinfo iddrawn mainfont
2304 global findloc
2305 global markingmatches
2307 if {![info exists commitinfo($id)]} {
2308 getcommit $id
2310 set info $commitinfo($id)
2311 set isbold 0
2312 set fldtypes {Headline Author Date Committer CDate Comments}
2313 foreach f $info ty $fldtypes {
2314 if {($findloc eq "All fields" || $findloc eq $ty) &&
2315 [doesmatch $f]} {
2316 if {$ty eq "Author"} {
2317 set isbold 2
2318 break
2320 set isbold 1
2323 if {$isbold && [info exists iddrawn($id)]} {
2324 set f [concat $mainfont bold]
2325 if {![ishighlighted $row]} {
2326 bolden $row $f
2327 if {$isbold > 1} {
2328 bolden_name $row $f
2331 if {$markingmatches} {
2332 markrowmatches $row $id
2335 set nhighlights($row) $isbold
2338 proc markrowmatches {row id} {
2339 global canv canv2 linehtag linentag commitinfo findloc
2341 set headline [lindex $commitinfo($id) 0]
2342 set author [lindex $commitinfo($id) 1]
2343 $canv delete match$row
2344 $canv2 delete match$row
2345 if {$findloc eq "All fields" || $findloc eq "Headline"} {
2346 set m [findmatches $headline]
2347 if {$m ne {}} {
2348 markmatches $canv $row $headline $linehtag($row) $m \
2349 [$canv itemcget $linehtag($row) -font] $row
2352 if {$findloc eq "All fields" || $findloc eq "Author"} {
2353 set m [findmatches $author]
2354 if {$m ne {}} {
2355 markmatches $canv2 $row $author $linentag($row) $m \
2356 [$canv2 itemcget $linentag($row) -font] $row
2361 proc vrel_change {name ix op} {
2362 global highlight_related
2364 rhighlight_none
2365 if {$highlight_related ne "None"} {
2366 run drawvisible
2370 # prepare for testing whether commits are descendents or ancestors of a
2371 proc rhighlight_sel {a} {
2372 global descendent desc_todo ancestor anc_todo
2373 global highlight_related rhighlights
2375 catch {unset descendent}
2376 set desc_todo [list $a]
2377 catch {unset ancestor}
2378 set anc_todo [list $a]
2379 if {$highlight_related ne "None"} {
2380 rhighlight_none
2381 run drawvisible
2385 proc rhighlight_none {} {
2386 global rhighlights
2388 catch {unset rhighlights}
2389 unbolden
2392 proc is_descendent {a} {
2393 global curview children commitrow descendent desc_todo
2395 set v $curview
2396 set la $commitrow($v,$a)
2397 set todo $desc_todo
2398 set leftover {}
2399 set done 0
2400 for {set i 0} {$i < [llength $todo]} {incr i} {
2401 set do [lindex $todo $i]
2402 if {$commitrow($v,$do) < $la} {
2403 lappend leftover $do
2404 continue
2406 foreach nk $children($v,$do) {
2407 if {![info exists descendent($nk)]} {
2408 set descendent($nk) 1
2409 lappend todo $nk
2410 if {$nk eq $a} {
2411 set done 1
2415 if {$done} {
2416 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2417 return
2420 set descendent($a) 0
2421 set desc_todo $leftover
2424 proc is_ancestor {a} {
2425 global curview parentlist commitrow ancestor anc_todo
2427 set v $curview
2428 set la $commitrow($v,$a)
2429 set todo $anc_todo
2430 set leftover {}
2431 set done 0
2432 for {set i 0} {$i < [llength $todo]} {incr i} {
2433 set do [lindex $todo $i]
2434 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2435 lappend leftover $do
2436 continue
2438 foreach np [lindex $parentlist $commitrow($v,$do)] {
2439 if {![info exists ancestor($np)]} {
2440 set ancestor($np) 1
2441 lappend todo $np
2442 if {$np eq $a} {
2443 set done 1
2447 if {$done} {
2448 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2449 return
2452 set ancestor($a) 0
2453 set anc_todo $leftover
2456 proc askrelhighlight {row id} {
2457 global descendent highlight_related iddrawn mainfont rhighlights
2458 global selectedline ancestor
2460 if {![info exists selectedline]} return
2461 set isbold 0
2462 if {$highlight_related eq "Descendent" ||
2463 $highlight_related eq "Not descendent"} {
2464 if {![info exists descendent($id)]} {
2465 is_descendent $id
2467 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2468 set isbold 1
2470 } elseif {$highlight_related eq "Ancestor" ||
2471 $highlight_related eq "Not ancestor"} {
2472 if {![info exists ancestor($id)]} {
2473 is_ancestor $id
2475 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2476 set isbold 1
2479 if {[info exists iddrawn($id)]} {
2480 if {$isbold && ![ishighlighted $row]} {
2481 bolden $row [concat $mainfont bold]
2484 set rhighlights($row) $isbold
2487 proc next_hlcont {} {
2488 global fhl_row fhl_dirn displayorder numcommits
2489 global vhighlights fhighlights nhighlights rhighlights
2490 global hlview filehighlight findstring highlight_related
2492 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2493 set row $fhl_row
2494 while {1} {
2495 if {$row < 0 || $row >= $numcommits} {
2496 bell
2497 set fhl_dirn 0
2498 return
2500 set id [lindex $displayorder $row]
2501 if {[info exists hlview]} {
2502 if {![info exists vhighlights($row)]} {
2503 askvhighlight $row $id
2505 if {$vhighlights($row) > 0} break
2507 if {$findstring ne {}} {
2508 if {![info exists nhighlights($row)]} {
2509 askfindhighlight $row $id
2511 if {$nhighlights($row) > 0} break
2513 if {$highlight_related ne "None"} {
2514 if {![info exists rhighlights($row)]} {
2515 askrelhighlight $row $id
2517 if {$rhighlights($row) > 0} break
2519 if {[info exists filehighlight]} {
2520 if {![info exists fhighlights($row)]} {
2521 # ask for a few more while we're at it...
2522 set r $row
2523 for {set n 0} {$n < 100} {incr n} {
2524 if {![info exists fhighlights($r)]} {
2525 askfilehighlight $r [lindex $displayorder $r]
2527 incr r $fhl_dirn
2528 if {$r < 0 || $r >= $numcommits} break
2530 flushhighlights
2532 if {$fhighlights($row) < 0} {
2533 set fhl_row $row
2534 return
2536 if {$fhighlights($row) > 0} break
2538 incr row $fhl_dirn
2540 set fhl_dirn 0
2541 selectline $row 1
2544 proc next_highlight {dirn} {
2545 global selectedline fhl_row fhl_dirn
2546 global hlview filehighlight findstring highlight_related
2548 if {![info exists selectedline]} return
2549 if {!([info exists hlview] || $findstring ne {} ||
2550 $highlight_related ne "None" || [info exists filehighlight])} return
2551 set fhl_row [expr {$selectedline + $dirn}]
2552 set fhl_dirn $dirn
2553 next_hlcont
2556 proc cancel_next_highlight {} {
2557 global fhl_dirn
2559 set fhl_dirn 0
2562 # Graph layout functions
2564 proc shortids {ids} {
2565 set res {}
2566 foreach id $ids {
2567 if {[llength $id] > 1} {
2568 lappend res [shortids $id]
2569 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2570 lappend res [string range $id 0 7]
2571 } else {
2572 lappend res $id
2575 return $res
2578 proc incrange {l x o} {
2579 set n [llength $l]
2580 while {$x < $n} {
2581 set e [lindex $l $x]
2582 if {$e ne {}} {
2583 lset l $x [expr {$e + $o}]
2585 incr x
2587 return $l
2590 proc ntimes {n o} {
2591 set ret {}
2592 for {} {$n > 0} {incr n -1} {
2593 lappend ret $o
2595 return $ret
2598 proc usedinrange {id l1 l2} {
2599 global children commitrow curview
2601 if {[info exists commitrow($curview,$id)]} {
2602 set r $commitrow($curview,$id)
2603 if {$l1 <= $r && $r <= $l2} {
2604 return [expr {$r - $l1 + 1}]
2607 set kids $children($curview,$id)
2608 foreach c $kids {
2609 set r $commitrow($curview,$c)
2610 if {$l1 <= $r && $r <= $l2} {
2611 return [expr {$r - $l1 + 1}]
2614 return 0
2617 proc sanity {row {full 0}} {
2618 global rowidlist rowoffsets
2620 set col -1
2621 set ids [lindex $rowidlist $row]
2622 foreach id $ids {
2623 incr col
2624 if {$id eq {}} continue
2625 if {$col < [llength $ids] - 1 &&
2626 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2627 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2629 set o [lindex $rowoffsets $row $col]
2630 set y $row
2631 set x $col
2632 while {$o ne {}} {
2633 incr y -1
2634 incr x $o
2635 if {[lindex $rowidlist $y $x] != $id} {
2636 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2637 puts " id=[shortids $id] check started at row $row"
2638 for {set i $row} {$i >= $y} {incr i -1} {
2639 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2641 break
2643 if {!$full} break
2644 set o [lindex $rowoffsets $y $x]
2649 proc makeuparrow {oid x y z} {
2650 global rowidlist rowoffsets uparrowlen idrowranges displayorder
2652 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2653 incr y -1
2654 incr x $z
2655 set off0 [lindex $rowoffsets $y]
2656 for {set x0 $x} {1} {incr x0} {
2657 if {$x0 >= [llength $off0]} {
2658 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2659 break
2661 set z [lindex $off0 $x0]
2662 if {$z ne {}} {
2663 incr x0 $z
2664 break
2667 set z [expr {$x0 - $x}]
2668 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2669 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2671 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2672 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2673 lappend idrowranges($oid) [lindex $displayorder $y]
2676 proc initlayout {} {
2677 global rowidlist rowoffsets displayorder commitlisted
2678 global rowlaidout rowoptim
2679 global idinlist rowchk rowrangelist idrowranges
2680 global numcommits canvxmax canv
2681 global nextcolor
2682 global parentlist
2683 global colormap rowtextx
2684 global selectfirst
2686 set numcommits 0
2687 set displayorder {}
2688 set commitlisted {}
2689 set parentlist {}
2690 set rowrangelist {}
2691 set nextcolor 0
2692 set rowidlist {{}}
2693 set rowoffsets {{}}
2694 catch {unset idinlist}
2695 catch {unset rowchk}
2696 set rowlaidout 0
2697 set rowoptim 0
2698 set canvxmax [$canv cget -width]
2699 catch {unset colormap}
2700 catch {unset rowtextx}
2701 catch {unset idrowranges}
2702 set selectfirst 1
2705 proc setcanvscroll {} {
2706 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2708 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2709 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2710 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2711 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2714 proc visiblerows {} {
2715 global canv numcommits linespc
2717 set ymax [lindex [$canv cget -scrollregion] 3]
2718 if {$ymax eq {} || $ymax == 0} return
2719 set f [$canv yview]
2720 set y0 [expr {int([lindex $f 0] * $ymax)}]
2721 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2722 if {$r0 < 0} {
2723 set r0 0
2725 set y1 [expr {int([lindex $f 1] * $ymax)}]
2726 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2727 if {$r1 >= $numcommits} {
2728 set r1 [expr {$numcommits - 1}]
2730 return [list $r0 $r1]
2733 proc layoutmore {tmax allread} {
2734 global rowlaidout rowoptim commitidx numcommits optim_delay
2735 global uparrowlen curview rowidlist idinlist
2737 set showlast 0
2738 set showdelay $optim_delay
2739 set optdelay [expr {$uparrowlen + 1}]
2740 while {1} {
2741 if {$rowoptim - $showdelay > $numcommits} {
2742 showstuff [expr {$rowoptim - $showdelay}] $showlast
2743 } elseif {$rowlaidout - $optdelay > $rowoptim} {
2744 set nr [expr {$rowlaidout - $optdelay - $rowoptim}]
2745 if {$nr > 100} {
2746 set nr 100
2748 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2749 incr rowoptim $nr
2750 } elseif {$commitidx($curview) > $rowlaidout} {
2751 set nr [expr {$commitidx($curview) - $rowlaidout}]
2752 # may need to increase this threshold if uparrowlen or
2753 # mingaplen are increased...
2754 if {$nr > 150} {
2755 set nr 150
2757 set row $rowlaidout
2758 set rowlaidout [layoutrows $row [expr {$row + $nr}] $allread]
2759 if {$rowlaidout == $row} {
2760 return 0
2762 } elseif {$allread} {
2763 set optdelay 0
2764 set nrows $commitidx($curview)
2765 if {[lindex $rowidlist $nrows] ne {} ||
2766 [array names idinlist] ne {}} {
2767 layouttail
2768 set rowlaidout $commitidx($curview)
2769 } elseif {$rowoptim == $nrows} {
2770 set showdelay 0
2771 set showlast 1
2772 if {$numcommits == $nrows} {
2773 return 0
2776 } else {
2777 return 0
2779 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2780 return 1
2785 proc showstuff {canshow last} {
2786 global numcommits commitrow pending_select selectedline curview
2787 global lookingforhead mainheadid displayorder selectfirst
2788 global lastscrollset commitinterest
2790 if {$numcommits == 0} {
2791 global phase
2792 set phase "incrdraw"
2793 allcanvs delete all
2795 for {set l $numcommits} {$l < $canshow} {incr l} {
2796 set id [lindex $displayorder $l]
2797 if {[info exists commitinterest($id)]} {
2798 foreach script $commitinterest($id) {
2799 eval [string map [list "%I" $id] $script]
2801 unset commitinterest($id)
2804 set r0 $numcommits
2805 set prev $numcommits
2806 set numcommits $canshow
2807 set t [clock clicks -milliseconds]
2808 if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2809 set lastscrollset $t
2810 setcanvscroll
2812 set rows [visiblerows]
2813 set r1 [lindex $rows 1]
2814 if {$r1 >= $canshow} {
2815 set r1 [expr {$canshow - 1}]
2817 if {$r0 <= $r1} {
2818 drawcommits $r0 $r1
2820 if {[info exists pending_select] &&
2821 [info exists commitrow($curview,$pending_select)] &&
2822 $commitrow($curview,$pending_select) < $numcommits} {
2823 selectline $commitrow($curview,$pending_select) 1
2825 if {$selectfirst} {
2826 if {[info exists selectedline] || [info exists pending_select]} {
2827 set selectfirst 0
2828 } else {
2829 set l [first_real_row]
2830 selectline $l 1
2831 set selectfirst 0
2834 if {$lookingforhead && [info exists commitrow($curview,$mainheadid)]
2835 && ($last || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2836 set lookingforhead 0
2837 dodiffindex
2841 proc doshowlocalchanges {} {
2842 global lookingforhead curview mainheadid phase commitrow
2844 if {[info exists commitrow($curview,$mainheadid)] &&
2845 ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2846 dodiffindex
2847 } elseif {$phase ne {}} {
2848 set lookingforhead 1
2852 proc dohidelocalchanges {} {
2853 global lookingforhead localfrow localirow lserial
2855 set lookingforhead 0
2856 if {$localfrow >= 0} {
2857 removerow $localfrow
2858 set localfrow -1
2859 if {$localirow > 0} {
2860 incr localirow -1
2863 if {$localirow >= 0} {
2864 removerow $localirow
2865 set localirow -1
2867 incr lserial
2870 # spawn off a process to do git diff-index --cached HEAD
2871 proc dodiffindex {} {
2872 global localirow localfrow lserial
2874 incr lserial
2875 set localfrow -1
2876 set localirow -1
2877 set fd [open "|git diff-index --cached HEAD" r]
2878 fconfigure $fd -blocking 0
2879 filerun $fd [list readdiffindex $fd $lserial]
2882 proc readdiffindex {fd serial} {
2883 global localirow commitrow mainheadid nullid2 curview
2884 global commitinfo commitdata lserial
2886 set isdiff 1
2887 if {[gets $fd line] < 0} {
2888 if {![eof $fd]} {
2889 return 1
2891 set isdiff 0
2893 # we only need to see one line and we don't really care what it says...
2894 close $fd
2896 # now see if there are any local changes not checked in to the index
2897 if {$serial == $lserial} {
2898 set fd [open "|git diff-files" r]
2899 fconfigure $fd -blocking 0
2900 filerun $fd [list readdifffiles $fd $serial]
2903 if {$isdiff && $serial == $lserial && $localirow == -1} {
2904 # add the line for the changes in the index to the graph
2905 set localirow $commitrow($curview,$mainheadid)
2906 set hl "Local changes checked in to index but not committed"
2907 set commitinfo($nullid2) [list $hl {} {} {} {} " $hl\n"]
2908 set commitdata($nullid2) "\n $hl\n"
2909 insertrow $localirow $nullid2
2911 return 0
2914 proc readdifffiles {fd serial} {
2915 global localirow localfrow commitrow mainheadid nullid curview
2916 global commitinfo commitdata lserial
2918 set isdiff 1
2919 if {[gets $fd line] < 0} {
2920 if {![eof $fd]} {
2921 return 1
2923 set isdiff 0
2925 # we only need to see one line and we don't really care what it says...
2926 close $fd
2928 if {$isdiff && $serial == $lserial && $localfrow == -1} {
2929 # add the line for the local diff to the graph
2930 if {$localirow >= 0} {
2931 set localfrow $localirow
2932 incr localirow
2933 } else {
2934 set localfrow $commitrow($curview,$mainheadid)
2936 set hl "Local uncommitted changes, not checked in to index"
2937 set commitinfo($nullid) [list $hl {} {} {} {} " $hl\n"]
2938 set commitdata($nullid) "\n $hl\n"
2939 insertrow $localfrow $nullid
2941 return 0
2944 proc layoutrows {row endrow last} {
2945 global rowidlist rowoffsets displayorder
2946 global uparrowlen downarrowlen maxwidth mingaplen
2947 global children parentlist
2948 global idrowranges
2949 global commitidx curview
2950 global idinlist rowchk rowrangelist
2952 set idlist [lindex $rowidlist $row]
2953 set offs [lindex $rowoffsets $row]
2954 while {$row < $endrow} {
2955 set id [lindex $displayorder $row]
2956 set nev [expr {[llength $idlist] - $maxwidth + 1}]
2957 foreach p [lindex $parentlist $row] {
2958 if {![info exists idinlist($p)] || !$idinlist($p)} {
2959 incr nev
2962 if {$nev > 0} {
2963 if {!$last &&
2964 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2965 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2966 set i [lindex $idlist $x]
2967 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2968 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2969 [expr {$row + $uparrowlen + $mingaplen}]]
2970 if {$r == 0} {
2971 set idlist [lreplace $idlist $x $x]
2972 set offs [lreplace $offs $x $x]
2973 set offs [incrange $offs $x 1]
2974 set idinlist($i) 0
2975 set rm1 [expr {$row - 1}]
2976 lappend idrowranges($i) [lindex $displayorder $rm1]
2977 if {[incr nev -1] <= 0} break
2978 continue
2980 set rowchk($i) [expr {$row + $r}]
2983 lset rowidlist $row $idlist
2984 lset rowoffsets $row $offs
2986 set oldolds {}
2987 set newolds {}
2988 foreach p [lindex $parentlist $row] {
2989 if {![info exists idinlist($p)]} {
2990 lappend newolds $p
2991 } elseif {!$idinlist($p)} {
2992 lappend oldolds $p
2994 set idinlist($p) 1
2996 set col [lsearch -exact $idlist $id]
2997 if {$col < 0} {
2998 set col [llength $idlist]
2999 lappend idlist $id
3000 lset rowidlist $row $idlist
3001 set z {}
3002 if {$children($curview,$id) ne {}} {
3003 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
3004 unset idinlist($id)
3006 lappend offs $z
3007 lset rowoffsets $row $offs
3008 if {$z ne {}} {
3009 makeuparrow $id $col $row $z
3011 } else {
3012 unset idinlist($id)
3014 set ranges {}
3015 if {[info exists idrowranges($id)]} {
3016 set ranges $idrowranges($id)
3017 lappend ranges $id
3018 unset idrowranges($id)
3020 lappend rowrangelist $ranges
3021 incr row
3022 set offs [ntimes [llength $idlist] 0]
3023 set l [llength $newolds]
3024 set idlist [eval lreplace \$idlist $col $col $newolds]
3025 set o 0
3026 if {$l != 1} {
3027 set offs [lrange $offs 0 [expr {$col - 1}]]
3028 foreach x $newolds {
3029 lappend offs {}
3030 incr o -1
3032 incr o
3033 set tmp [expr {[llength $idlist] - [llength $offs]}]
3034 if {$tmp > 0} {
3035 set offs [concat $offs [ntimes $tmp $o]]
3037 } else {
3038 lset offs $col {}
3040 foreach i $newolds {
3041 set idrowranges($i) $id
3043 incr col $l
3044 foreach oid $oldolds {
3045 set idlist [linsert $idlist $col $oid]
3046 set offs [linsert $offs $col $o]
3047 makeuparrow $oid $col $row $o
3048 incr col
3050 lappend rowidlist $idlist
3051 lappend rowoffsets $offs
3053 return $row
3056 proc addextraid {id row} {
3057 global displayorder commitrow commitinfo
3058 global commitidx commitlisted
3059 global parentlist children curview
3061 incr commitidx($curview)
3062 lappend displayorder $id
3063 lappend commitlisted 0
3064 lappend parentlist {}
3065 set commitrow($curview,$id) $row
3066 readcommit $id
3067 if {![info exists commitinfo($id)]} {
3068 set commitinfo($id) {"No commit information available"}
3070 if {![info exists children($curview,$id)]} {
3071 set children($curview,$id) {}
3075 proc layouttail {} {
3076 global rowidlist rowoffsets idinlist commitidx curview
3077 global idrowranges rowrangelist
3079 set row $commitidx($curview)
3080 set idlist [lindex $rowidlist $row]
3081 while {$idlist ne {}} {
3082 set col [expr {[llength $idlist] - 1}]
3083 set id [lindex $idlist $col]
3084 addextraid $id $row
3085 catch {unset idinlist($id)}
3086 lappend idrowranges($id) $id
3087 lappend rowrangelist $idrowranges($id)
3088 unset idrowranges($id)
3089 incr row
3090 set offs [ntimes $col 0]
3091 set idlist [lreplace $idlist $col $col]
3092 lappend rowidlist $idlist
3093 lappend rowoffsets $offs
3096 foreach id [array names idinlist] {
3097 unset idinlist($id)
3098 addextraid $id $row
3099 lset rowidlist $row [list $id]
3100 lset rowoffsets $row 0
3101 makeuparrow $id 0 $row 0
3102 lappend idrowranges($id) $id
3103 lappend rowrangelist $idrowranges($id)
3104 unset idrowranges($id)
3105 incr row
3106 lappend rowidlist {}
3107 lappend rowoffsets {}
3111 proc insert_pad {row col npad} {
3112 global rowidlist rowoffsets
3114 set pad [ntimes $npad {}]
3115 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
3116 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
3117 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
3120 proc optimize_rows {row col endrow} {
3121 global rowidlist rowoffsets displayorder
3123 for {} {$row < $endrow} {incr row} {
3124 set idlist [lindex $rowidlist $row]
3125 set offs [lindex $rowoffsets $row]
3126 set haspad 0
3127 for {} {$col < [llength $offs]} {incr col} {
3128 if {[lindex $idlist $col] eq {}} {
3129 set haspad 1
3130 continue
3132 set z [lindex $offs $col]
3133 if {$z eq {}} continue
3134 set isarrow 0
3135 set x0 [expr {$col + $z}]
3136 set y0 [expr {$row - 1}]
3137 set z0 [lindex $rowoffsets $y0 $x0]
3138 if {$z0 eq {}} {
3139 set id [lindex $idlist $col]
3140 set ranges [rowranges $id]
3141 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
3142 set isarrow 1
3145 # Looking at lines from this row to the previous row,
3146 # make them go straight up if they end in an arrow on
3147 # the previous row; otherwise make them go straight up
3148 # or at 45 degrees.
3149 if {$z < -1 || ($z < 0 && $isarrow)} {
3150 # Line currently goes left too much;
3151 # insert pads in the previous row, then optimize it
3152 set npad [expr {-1 - $z + $isarrow}]
3153 set offs [incrange $offs $col $npad]
3154 insert_pad $y0 $x0 $npad
3155 if {$y0 > 0} {
3156 optimize_rows $y0 $x0 $row
3158 set z [lindex $offs $col]
3159 set x0 [expr {$col + $z}]
3160 set z0 [lindex $rowoffsets $y0 $x0]
3161 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3162 # Line currently goes right too much;
3163 # insert pads in this line and adjust the next's rowoffsets
3164 set npad [expr {$z - 1 + $isarrow}]
3165 set y1 [expr {$row + 1}]
3166 set offs2 [lindex $rowoffsets $y1]
3167 set x1 -1
3168 foreach z $offs2 {
3169 incr x1
3170 if {$z eq {} || $x1 + $z < $col} continue
3171 if {$x1 + $z > $col} {
3172 incr npad
3174 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
3175 break
3177 set pad [ntimes $npad {}]
3178 set idlist [eval linsert \$idlist $col $pad]
3179 set tmp [eval linsert \$offs $col $pad]
3180 incr col $npad
3181 set offs [incrange $tmp $col [expr {-$npad}]]
3182 set z [lindex $offs $col]
3183 set haspad 1
3185 if {$z0 eq {} && !$isarrow} {
3186 # this line links to its first child on row $row-2
3187 set rm2 [expr {$row - 2}]
3188 set id [lindex $displayorder $rm2]
3189 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
3190 if {$xc >= 0} {
3191 set z0 [expr {$xc - $x0}]
3194 # avoid lines jigging left then immediately right
3195 if {$z0 ne {} && $z < 0 && $z0 > 0} {
3196 insert_pad $y0 $x0 1
3197 set offs [incrange $offs $col 1]
3198 optimize_rows $y0 [expr {$x0 + 1}] $row
3201 if {!$haspad} {
3202 set o {}
3203 # Find the first column that doesn't have a line going right
3204 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3205 set o [lindex $offs $col]
3206 if {$o eq {}} {
3207 # check if this is the link to the first child
3208 set id [lindex $idlist $col]
3209 set ranges [rowranges $id]
3210 if {$ranges ne {} && $row == [lindex $ranges 0]} {
3211 # it is, work out offset to child
3212 set y0 [expr {$row - 1}]
3213 set id [lindex $displayorder $y0]
3214 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
3215 if {$x0 >= 0} {
3216 set o [expr {$x0 - $col}]
3220 if {$o eq {} || $o <= 0} break
3222 # Insert a pad at that column as long as it has a line and
3223 # isn't the last column, and adjust the next row' offsets
3224 if {$o ne {} && [incr col] < [llength $idlist]} {
3225 set y1 [expr {$row + 1}]
3226 set offs2 [lindex $rowoffsets $y1]
3227 set x1 -1
3228 foreach z $offs2 {
3229 incr x1
3230 if {$z eq {} || $x1 + $z < $col} continue
3231 lset rowoffsets $y1 [incrange $offs2 $x1 1]
3232 break
3234 set idlist [linsert $idlist $col {}]
3235 set tmp [linsert $offs $col {}]
3236 incr col
3237 set offs [incrange $tmp $col -1]
3240 lset rowidlist $row $idlist
3241 lset rowoffsets $row $offs
3242 set col 0
3246 proc xc {row col} {
3247 global canvx0 linespc
3248 return [expr {$canvx0 + $col * $linespc}]
3251 proc yc {row} {
3252 global canvy0 linespc
3253 return [expr {$canvy0 + $row * $linespc}]
3256 proc linewidth {id} {
3257 global thickerline lthickness
3259 set wid $lthickness
3260 if {[info exists thickerline] && $id eq $thickerline} {
3261 set wid [expr {2 * $lthickness}]
3263 return $wid
3266 proc rowranges {id} {
3267 global phase idrowranges commitrow rowlaidout rowrangelist curview
3269 set ranges {}
3270 if {$phase eq {} ||
3271 ([info exists commitrow($curview,$id)]
3272 && $commitrow($curview,$id) < $rowlaidout)} {
3273 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
3274 } elseif {[info exists idrowranges($id)]} {
3275 set ranges $idrowranges($id)
3277 set linenos {}
3278 foreach rid $ranges {
3279 lappend linenos $commitrow($curview,$rid)
3281 if {$linenos ne {}} {
3282 lset linenos 0 [expr {[lindex $linenos 0] + 1}]
3284 return $linenos
3287 # work around tk8.4 refusal to draw arrows on diagonal segments
3288 proc adjarrowhigh {coords} {
3289 global linespc
3291 set x0 [lindex $coords 0]
3292 set x1 [lindex $coords 2]
3293 if {$x0 != $x1} {
3294 set y0 [lindex $coords 1]
3295 set y1 [lindex $coords 3]
3296 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
3297 # we have a nearby vertical segment, just trim off the diag bit
3298 set coords [lrange $coords 2 end]
3299 } else {
3300 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
3301 set xi [expr {$x0 - $slope * $linespc / 2}]
3302 set yi [expr {$y0 - $linespc / 2}]
3303 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
3306 return $coords
3309 proc drawlineseg {id row endrow arrowlow} {
3310 global rowidlist displayorder iddrawn linesegs
3311 global canv colormap linespc curview maxlinelen
3313 set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3314 set le [expr {$row + 1}]
3315 set arrowhigh 1
3316 while {1} {
3317 set c [lsearch -exact [lindex $rowidlist $le] $id]
3318 if {$c < 0} {
3319 incr le -1
3320 break
3322 lappend cols $c
3323 set x [lindex $displayorder $le]
3324 if {$x eq $id} {
3325 set arrowhigh 0
3326 break
3328 if {[info exists iddrawn($x)] || $le == $endrow} {
3329 set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3330 if {$c >= 0} {
3331 lappend cols $c
3332 set arrowhigh 0
3334 break
3336 incr le
3338 if {$le <= $row} {
3339 return $row
3342 set lines {}
3343 set i 0
3344 set joinhigh 0
3345 if {[info exists linesegs($id)]} {
3346 set lines $linesegs($id)
3347 foreach li $lines {
3348 set r0 [lindex $li 0]
3349 if {$r0 > $row} {
3350 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3351 set joinhigh 1
3353 break
3355 incr i
3358 set joinlow 0
3359 if {$i > 0} {
3360 set li [lindex $lines [expr {$i-1}]]
3361 set r1 [lindex $li 1]
3362 if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3363 set joinlow 1
3367 set x [lindex $cols [expr {$le - $row}]]
3368 set xp [lindex $cols [expr {$le - 1 - $row}]]
3369 set dir [expr {$xp - $x}]
3370 if {$joinhigh} {
3371 set ith [lindex $lines $i 2]
3372 set coords [$canv coords $ith]
3373 set ah [$canv itemcget $ith -arrow]
3374 set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3375 set x2 [lindex $cols [expr {$le + 1 - $row}]]
3376 if {$x2 ne {} && $x - $x2 == $dir} {
3377 set coords [lrange $coords 0 end-2]
3379 } else {
3380 set coords [list [xc $le $x] [yc $le]]
3382 if {$joinlow} {
3383 set itl [lindex $lines [expr {$i-1}] 2]
3384 set al [$canv itemcget $itl -arrow]
3385 set arrowlow [expr {$al eq "last" || $al eq "both"}]
3386 } elseif {$arrowlow &&
3387 [lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0} {
3388 set arrowlow 0
3390 set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3391 for {set y $le} {[incr y -1] > $row} {} {
3392 set x $xp
3393 set xp [lindex $cols [expr {$y - 1 - $row}]]
3394 set ndir [expr {$xp - $x}]
3395 if {$dir != $ndir || $xp < 0} {
3396 lappend coords [xc $y $x] [yc $y]
3398 set dir $ndir
3400 if {!$joinlow} {
3401 if {$xp < 0} {
3402 # join parent line to first child
3403 set ch [lindex $displayorder $row]
3404 set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3405 if {$xc < 0} {
3406 puts "oops: drawlineseg: child $ch not on row $row"
3407 } else {
3408 if {$xc < $x - 1} {
3409 lappend coords [xc $row [expr {$x-1}]] [yc $row]
3410 } elseif {$xc > $x + 1} {
3411 lappend coords [xc $row [expr {$x+1}]] [yc $row]
3413 set x $xc
3415 lappend coords [xc $row $x] [yc $row]
3416 } else {
3417 set xn [xc $row $xp]
3418 set yn [yc $row]
3419 # work around tk8.4 refusal to draw arrows on diagonal segments
3420 if {$arrowlow && $xn != [lindex $coords end-1]} {
3421 if {[llength $coords] < 4 ||
3422 [lindex $coords end-3] != [lindex $coords end-1] ||
3423 [lindex $coords end] - $yn > 2 * $linespc} {
3424 set xn [xc $row [expr {$xp - 0.5 * $dir}]]
3425 set yo [yc [expr {$row + 0.5}]]
3426 lappend coords $xn $yo $xn $yn
3428 } else {
3429 lappend coords $xn $yn
3432 if {!$joinhigh} {
3433 if {$arrowhigh} {
3434 set coords [adjarrowhigh $coords]
3436 assigncolor $id
3437 set t [$canv create line $coords -width [linewidth $id] \
3438 -fill $colormap($id) -tags lines.$id -arrow $arrow]
3439 $canv lower $t
3440 bindline $t $id
3441 set lines [linsert $lines $i [list $row $le $t]]
3442 } else {
3443 $canv coords $ith $coords
3444 if {$arrow ne $ah} {
3445 $canv itemconf $ith -arrow $arrow
3447 lset lines $i 0 $row
3449 } else {
3450 set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3451 set ndir [expr {$xo - $xp}]
3452 set clow [$canv coords $itl]
3453 if {$dir == $ndir} {
3454 set clow [lrange $clow 2 end]
3456 set coords [concat $coords $clow]
3457 if {!$joinhigh} {
3458 lset lines [expr {$i-1}] 1 $le
3459 if {$arrowhigh} {
3460 set coords [adjarrowhigh $coords]
3462 } else {
3463 # coalesce two pieces
3464 $canv delete $ith
3465 set b [lindex $lines [expr {$i-1}] 0]
3466 set e [lindex $lines $i 1]
3467 set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3469 $canv coords $itl $coords
3470 if {$arrow ne $al} {
3471 $canv itemconf $itl -arrow $arrow
3475 set linesegs($id) $lines
3476 return $le
3479 proc drawparentlinks {id row} {
3480 global rowidlist canv colormap curview parentlist
3481 global idpos
3483 set rowids [lindex $rowidlist $row]
3484 set col [lsearch -exact $rowids $id]
3485 if {$col < 0} return
3486 set olds [lindex $parentlist $row]
3487 set row2 [expr {$row + 1}]
3488 set x [xc $row $col]
3489 set y [yc $row]
3490 set y2 [yc $row2]
3491 set ids [lindex $rowidlist $row2]
3492 # rmx = right-most X coord used
3493 set rmx 0
3494 foreach p $olds {
3495 set i [lsearch -exact $ids $p]
3496 if {$i < 0} {
3497 puts "oops, parent $p of $id not in list"
3498 continue
3500 set x2 [xc $row2 $i]
3501 if {$x2 > $rmx} {
3502 set rmx $x2
3504 if {[lsearch -exact $rowids $p] < 0} {
3505 # drawlineseg will do this one for us
3506 continue
3508 assigncolor $p
3509 # should handle duplicated parents here...
3510 set coords [list $x $y]
3511 if {$i < $col - 1} {
3512 lappend coords [xc $row [expr {$i + 1}]] $y
3513 } elseif {$i > $col + 1} {
3514 lappend coords [xc $row [expr {$i - 1}]] $y
3516 lappend coords $x2 $y2
3517 set t [$canv create line $coords -width [linewidth $p] \
3518 -fill $colormap($p) -tags lines.$p]
3519 $canv lower $t
3520 bindline $t $p
3522 if {$rmx > [lindex $idpos($id) 1]} {
3523 lset idpos($id) 1 $rmx
3524 redrawtags $id
3528 proc drawlines {id} {
3529 global canv
3531 $canv itemconf lines.$id -width [linewidth $id]
3534 proc drawcmittext {id row col} {
3535 global linespc canv canv2 canv3 canvy0 fgcolor curview
3536 global commitlisted commitinfo rowidlist parentlist
3537 global rowtextx idpos idtags idheads idotherrefs
3538 global linehtag linentag linedtag
3539 global mainfont canvxmax boldrows boldnamerows fgcolor nullid nullid2
3541 # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3542 set listed [lindex $commitlisted $row]
3543 if {$id eq $nullid} {
3544 set ofill red
3545 } elseif {$id eq $nullid2} {
3546 set ofill green
3547 } else {
3548 set ofill [expr {$listed != 0? "blue": "white"}]
3550 set x [xc $row $col]
3551 set y [yc $row]
3552 set orad [expr {$linespc / 3}]
3553 if {$listed <= 1} {
3554 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3555 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3556 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3557 } elseif {$listed == 2} {
3558 # triangle pointing left for left-side commits
3559 set t [$canv create polygon \
3560 [expr {$x - $orad}] $y \
3561 [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3562 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3563 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3564 } else {
3565 # triangle pointing right for right-side commits
3566 set t [$canv create polygon \
3567 [expr {$x + $orad - 1}] $y \
3568 [expr {$x - $orad}] [expr {$y - $orad}] \
3569 [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3570 -fill $ofill -outline $fgcolor -width 1 -tags circle]
3572 $canv raise $t
3573 $canv bind $t <1> {selcanvline {} %x %y}
3574 set rmx [llength [lindex $rowidlist $row]]
3575 set olds [lindex $parentlist $row]
3576 if {$olds ne {}} {
3577 set nextids [lindex $rowidlist [expr {$row + 1}]]
3578 foreach p $olds {
3579 set i [lsearch -exact $nextids $p]
3580 if {$i > $rmx} {
3581 set rmx $i
3585 set xt [xc $row $rmx]
3586 set rowtextx($row) $xt
3587 set idpos($id) [list $x $xt $y]
3588 if {[info exists idtags($id)] || [info exists idheads($id)]
3589 || [info exists idotherrefs($id)]} {
3590 set xt [drawtags $id $x $xt $y]
3592 set headline [lindex $commitinfo($id) 0]
3593 set name [lindex $commitinfo($id) 1]
3594 set date [lindex $commitinfo($id) 2]
3595 set date [formatdate $date]
3596 set font $mainfont
3597 set nfont $mainfont
3598 set isbold [ishighlighted $row]
3599 if {$isbold > 0} {
3600 lappend boldrows $row
3601 lappend font bold
3602 if {$isbold > 1} {
3603 lappend boldnamerows $row
3604 lappend nfont bold
3607 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3608 -text $headline -font $font -tags text]
3609 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3610 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3611 -text $name -font $nfont -tags text]
3612 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3613 -text $date -font $mainfont -tags text]
3614 set xr [expr {$xt + [font measure $mainfont $headline]}]
3615 if {$xr > $canvxmax} {
3616 set canvxmax $xr
3617 setcanvscroll
3621 proc drawcmitrow {row} {
3622 global displayorder rowidlist
3623 global iddrawn markingmatches
3624 global commitinfo parentlist numcommits
3625 global filehighlight fhighlights findstring nhighlights
3626 global hlview vhighlights
3627 global highlight_related rhighlights
3629 if {$row >= $numcommits} return
3631 set id [lindex $displayorder $row]
3632 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3633 askvhighlight $row $id
3635 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3636 askfilehighlight $row $id
3638 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3639 askfindhighlight $row $id
3641 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3642 askrelhighlight $row $id
3644 if {![info exists iddrawn($id)]} {
3645 set col [lsearch -exact [lindex $rowidlist $row] $id]
3646 if {$col < 0} {
3647 puts "oops, row $row id $id not in list"
3648 return
3650 if {![info exists commitinfo($id)]} {
3651 getcommit $id
3653 assigncolor $id
3654 drawcmittext $id $row $col
3655 set iddrawn($id) 1
3657 if {$markingmatches} {
3658 markrowmatches $row $id
3662 proc drawcommits {row {endrow {}}} {
3663 global numcommits iddrawn displayorder curview
3664 global parentlist rowidlist
3666 if {$row < 0} {
3667 set row 0
3669 if {$endrow eq {}} {
3670 set endrow $row
3672 if {$endrow >= $numcommits} {
3673 set endrow [expr {$numcommits - 1}]
3676 # make the lines join to already-drawn rows either side
3677 set r [expr {$row - 1}]
3678 if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3679 set r $row
3681 set er [expr {$endrow + 1}]
3682 if {$er >= $numcommits ||
3683 ![info exists iddrawn([lindex $displayorder $er])]} {
3684 set er $endrow
3686 for {} {$r <= $er} {incr r} {
3687 set id [lindex $displayorder $r]
3688 set wasdrawn [info exists iddrawn($id)]
3689 drawcmitrow $r
3690 if {$r == $er} break
3691 set nextid [lindex $displayorder [expr {$r + 1}]]
3692 if {$wasdrawn && [info exists iddrawn($nextid)]} {
3693 catch {unset prevlines}
3694 continue
3696 drawparentlinks $id $r
3698 if {[info exists lineends($r)]} {
3699 foreach lid $lineends($r) {
3700 unset prevlines($lid)
3703 set rowids [lindex $rowidlist $r]
3704 foreach lid $rowids {
3705 if {$lid eq {}} continue
3706 if {$lid eq $id} {
3707 # see if this is the first child of any of its parents
3708 foreach p [lindex $parentlist $r] {
3709 if {[lsearch -exact $rowids $p] < 0} {
3710 # make this line extend up to the child
3711 set le [drawlineseg $p $r $er 0]
3712 lappend lineends($le) $p
3713 set prevlines($p) 1
3716 } elseif {![info exists prevlines($lid)]} {
3717 set le [drawlineseg $lid $r $er 1]
3718 lappend lineends($le) $lid
3719 set prevlines($lid) 1
3725 proc drawfrac {f0 f1} {
3726 global canv linespc
3728 set ymax [lindex [$canv cget -scrollregion] 3]
3729 if {$ymax eq {} || $ymax == 0} return
3730 set y0 [expr {int($f0 * $ymax)}]
3731 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3732 set y1 [expr {int($f1 * $ymax)}]
3733 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3734 drawcommits $row $endrow
3737 proc drawvisible {} {
3738 global canv
3739 eval drawfrac [$canv yview]
3742 proc clear_display {} {
3743 global iddrawn linesegs
3744 global vhighlights fhighlights nhighlights rhighlights
3746 allcanvs delete all
3747 catch {unset iddrawn}
3748 catch {unset linesegs}
3749 catch {unset vhighlights}
3750 catch {unset fhighlights}
3751 catch {unset nhighlights}
3752 catch {unset rhighlights}
3755 proc findcrossings {id} {
3756 global rowidlist parentlist numcommits rowoffsets displayorder
3758 set cross {}
3759 set ccross {}
3760 foreach {s e} [rowranges $id] {
3761 if {$e >= $numcommits} {
3762 set e [expr {$numcommits - 1}]
3764 if {$e <= $s} continue
3765 set x [lsearch -exact [lindex $rowidlist $e] $id]
3766 if {$x < 0} {
3767 puts "findcrossings: oops, no [shortids $id] in row $e"
3768 continue
3770 for {set row $e} {[incr row -1] >= $s} {} {
3771 set olds [lindex $parentlist $row]
3772 set kid [lindex $displayorder $row]
3773 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3774 if {$kidx < 0} continue
3775 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3776 foreach p $olds {
3777 set px [lsearch -exact $nextrow $p]
3778 if {$px < 0} continue
3779 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3780 if {[lsearch -exact $ccross $p] >= 0} continue
3781 if {$x == $px + ($kidx < $px? -1: 1)} {
3782 lappend ccross $p
3783 } elseif {[lsearch -exact $cross $p] < 0} {
3784 lappend cross $p
3788 set inc [lindex $rowoffsets $row $x]
3789 if {$inc eq {}} break
3790 incr x $inc
3793 return [concat $ccross {{}} $cross]
3796 proc assigncolor {id} {
3797 global colormap colors nextcolor
3798 global commitrow parentlist children children curview
3800 if {[info exists colormap($id)]} return
3801 set ncolors [llength $colors]
3802 if {[info exists children($curview,$id)]} {
3803 set kids $children($curview,$id)
3804 } else {
3805 set kids {}
3807 if {[llength $kids] == 1} {
3808 set child [lindex $kids 0]
3809 if {[info exists colormap($child)]
3810 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3811 set colormap($id) $colormap($child)
3812 return
3815 set badcolors {}
3816 set origbad {}
3817 foreach x [findcrossings $id] {
3818 if {$x eq {}} {
3819 # delimiter between corner crossings and other crossings
3820 if {[llength $badcolors] >= $ncolors - 1} break
3821 set origbad $badcolors
3823 if {[info exists colormap($x)]
3824 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3825 lappend badcolors $colormap($x)
3828 if {[llength $badcolors] >= $ncolors} {
3829 set badcolors $origbad
3831 set origbad $badcolors
3832 if {[llength $badcolors] < $ncolors - 1} {
3833 foreach child $kids {
3834 if {[info exists colormap($child)]
3835 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3836 lappend badcolors $colormap($child)
3838 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3839 if {[info exists colormap($p)]
3840 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3841 lappend badcolors $colormap($p)
3845 if {[llength $badcolors] >= $ncolors} {
3846 set badcolors $origbad
3849 for {set i 0} {$i <= $ncolors} {incr i} {
3850 set c [lindex $colors $nextcolor]
3851 if {[incr nextcolor] >= $ncolors} {
3852 set nextcolor 0
3854 if {[lsearch -exact $badcolors $c]} break
3856 set colormap($id) $c
3859 proc bindline {t id} {
3860 global canv
3862 $canv bind $t <Enter> "lineenter %x %y $id"
3863 $canv bind $t <Motion> "linemotion %x %y $id"
3864 $canv bind $t <Leave> "lineleave $id"
3865 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3868 proc drawtags {id x xt y1} {
3869 global idtags idheads idotherrefs mainhead
3870 global linespc lthickness
3871 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3873 set marks {}
3874 set ntags 0
3875 set nheads 0
3876 if {[info exists idtags($id)]} {
3877 set marks $idtags($id)
3878 set ntags [llength $marks]
3880 if {[info exists idheads($id)]} {
3881 set marks [concat $marks $idheads($id)]
3882 set nheads [llength $idheads($id)]
3884 if {[info exists idotherrefs($id)]} {
3885 set marks [concat $marks $idotherrefs($id)]
3887 if {$marks eq {}} {
3888 return $xt
3891 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3892 set yt [expr {$y1 - 0.5 * $linespc}]
3893 set yb [expr {$yt + $linespc - 1}]
3894 set xvals {}
3895 set wvals {}
3896 set i -1
3897 foreach tag $marks {
3898 incr i
3899 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3900 set wid [font measure [concat $mainfont bold] $tag]
3901 } else {
3902 set wid [font measure $mainfont $tag]
3904 lappend xvals $xt
3905 lappend wvals $wid
3906 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3908 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3909 -width $lthickness -fill black -tags tag.$id]
3910 $canv lower $t
3911 foreach tag $marks x $xvals wid $wvals {
3912 set xl [expr {$x + $delta}]
3913 set xr [expr {$x + $delta + $wid + $lthickness}]
3914 set font $mainfont
3915 if {[incr ntags -1] >= 0} {
3916 # draw a tag
3917 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3918 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3919 -width 1 -outline black -fill yellow -tags tag.$id]
3920 $canv bind $t <1> [list showtag $tag 1]
3921 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3922 } else {
3923 # draw a head or other ref
3924 if {[incr nheads -1] >= 0} {
3925 set col green
3926 if {$tag eq $mainhead} {
3927 lappend font bold
3929 } else {
3930 set col "#ddddff"
3932 set xl [expr {$xl - $delta/2}]
3933 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3934 -width 1 -outline black -fill $col -tags tag.$id
3935 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3936 set rwid [font measure $mainfont $remoteprefix]
3937 set xi [expr {$x + 1}]
3938 set yti [expr {$yt + 1}]
3939 set xri [expr {$x + $rwid}]
3940 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3941 -width 0 -fill "#ffddaa" -tags tag.$id
3944 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3945 -font $font -tags [list tag.$id text]]
3946 if {$ntags >= 0} {
3947 $canv bind $t <1> [list showtag $tag 1]
3948 } elseif {$nheads >= 0} {
3949 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3952 return $xt
3955 proc xcoord {i level ln} {
3956 global canvx0 xspc1 xspc2
3958 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3959 if {$i > 0 && $i == $level} {
3960 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3961 } elseif {$i > $level} {
3962 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3964 return $x
3967 proc show_status {msg} {
3968 global canv mainfont fgcolor
3970 clear_display
3971 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3972 -tags text -fill $fgcolor
3975 # Insert a new commit as the child of the commit on row $row.
3976 # The new commit will be displayed on row $row and the commits
3977 # on that row and below will move down one row.
3978 proc insertrow {row newcmit} {
3979 global displayorder parentlist commitlisted children
3980 global commitrow curview rowidlist rowoffsets numcommits
3981 global rowrangelist rowlaidout rowoptim numcommits
3982 global selectedline rowchk commitidx
3984 if {$row >= $numcommits} {
3985 puts "oops, inserting new row $row but only have $numcommits rows"
3986 return
3988 set p [lindex $displayorder $row]
3989 set displayorder [linsert $displayorder $row $newcmit]
3990 set parentlist [linsert $parentlist $row $p]
3991 set kids $children($curview,$p)
3992 lappend kids $newcmit
3993 set children($curview,$p) $kids
3994 set children($curview,$newcmit) {}
3995 set commitlisted [linsert $commitlisted $row 1]
3996 set l [llength $displayorder]
3997 for {set r $row} {$r < $l} {incr r} {
3998 set id [lindex $displayorder $r]
3999 set commitrow($curview,$id) $r
4001 incr commitidx($curview)
4003 set idlist [lindex $rowidlist $row]
4004 set offs [lindex $rowoffsets $row]
4005 set newoffs {}
4006 foreach x $idlist {
4007 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
4008 lappend newoffs {}
4009 } else {
4010 lappend newoffs 0
4013 if {[llength $kids] == 1} {
4014 set col [lsearch -exact $idlist $p]
4015 lset idlist $col $newcmit
4016 } else {
4017 set col [llength $idlist]
4018 lappend idlist $newcmit
4019 lappend offs {}
4020 lset rowoffsets $row $offs
4022 set rowidlist [linsert $rowidlist $row $idlist]
4023 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
4025 set rowrangelist [linsert $rowrangelist $row {}]
4026 if {[llength $kids] > 1} {
4027 set rp1 [expr {$row + 1}]
4028 set ranges [lindex $rowrangelist $rp1]
4029 if {$ranges eq {}} {
4030 set ranges [list $newcmit $p]
4031 } elseif {[lindex $ranges end-1] eq $p} {
4032 lset ranges end-1 $newcmit
4034 lset rowrangelist $rp1 $ranges
4037 catch {unset rowchk}
4039 incr rowlaidout
4040 incr rowoptim
4041 incr numcommits
4043 if {[info exists selectedline] && $selectedline >= $row} {
4044 incr selectedline
4046 redisplay
4049 # Remove a commit that was inserted with insertrow on row $row.
4050 proc removerow {row} {
4051 global displayorder parentlist commitlisted children
4052 global commitrow curview rowidlist rowoffsets numcommits
4053 global rowrangelist idrowranges rowlaidout rowoptim numcommits
4054 global linesegends selectedline rowchk commitidx
4056 if {$row >= $numcommits} {
4057 puts "oops, removing row $row but only have $numcommits rows"
4058 return
4060 set rp1 [expr {$row + 1}]
4061 set id [lindex $displayorder $row]
4062 set p [lindex $parentlist $row]
4063 set displayorder [lreplace $displayorder $row $row]
4064 set parentlist [lreplace $parentlist $row $row]
4065 set commitlisted [lreplace $commitlisted $row $row]
4066 set kids $children($curview,$p)
4067 set i [lsearch -exact $kids $id]
4068 if {$i >= 0} {
4069 set kids [lreplace $kids $i $i]
4070 set children($curview,$p) $kids
4072 set l [llength $displayorder]
4073 for {set r $row} {$r < $l} {incr r} {
4074 set id [lindex $displayorder $r]
4075 set commitrow($curview,$id) $r
4077 incr commitidx($curview) -1
4079 set rowidlist [lreplace $rowidlist $row $row]
4080 set rowoffsets [lreplace $rowoffsets $rp1 $rp1]
4081 if {$kids ne {}} {
4082 set offs [lindex $rowoffsets $row]
4083 set offs [lreplace $offs end end]
4084 lset rowoffsets $row $offs
4087 set rowrangelist [lreplace $rowrangelist $row $row]
4088 if {[llength $kids] > 0} {
4089 set ranges [lindex $rowrangelist $row]
4090 if {[lindex $ranges end-1] eq $id} {
4091 set ranges [lreplace $ranges end-1 end]
4092 lset rowrangelist $row $ranges
4096 catch {unset rowchk}
4098 incr rowlaidout -1
4099 incr rowoptim -1
4100 incr numcommits -1
4102 if {[info exists selectedline] && $selectedline > $row} {
4103 incr selectedline -1
4105 redisplay
4108 # Don't change the text pane cursor if it is currently the hand cursor,
4109 # showing that we are over a sha1 ID link.
4110 proc settextcursor {c} {
4111 global ctext curtextcursor
4113 if {[$ctext cget -cursor] == $curtextcursor} {
4114 $ctext config -cursor $c
4116 set curtextcursor $c
4119 proc nowbusy {what} {
4120 global isbusy
4122 if {[array names isbusy] eq {}} {
4123 . config -cursor watch
4124 settextcursor watch
4126 set isbusy($what) 1
4129 proc notbusy {what} {
4130 global isbusy maincursor textcursor
4132 catch {unset isbusy($what)}
4133 if {[array names isbusy] eq {}} {
4134 . config -cursor $maincursor
4135 settextcursor $textcursor
4139 proc findmatches {f} {
4140 global findtype findstring
4141 if {$findtype == "Regexp"} {
4142 set matches [regexp -indices -all -inline $findstring $f]
4143 } else {
4144 set fs $findstring
4145 if {$findtype == "IgnCase"} {
4146 set f [string tolower $f]
4147 set fs [string tolower $fs]
4149 set matches {}
4150 set i 0
4151 set l [string length $fs]
4152 while {[set j [string first $fs $f $i]] >= 0} {
4153 lappend matches [list $j [expr {$j+$l-1}]]
4154 set i [expr {$j + $l}]
4157 return $matches
4160 proc dofind {{rev 0}} {
4161 global findstring findstartline findcurline selectedline numcommits
4163 unmarkmatches
4164 cancel_next_highlight
4165 focus .
4166 if {$findstring eq {} || $numcommits == 0} return
4167 if {![info exists selectedline]} {
4168 set findstartline [lindex [visiblerows] $rev]
4169 } else {
4170 set findstartline $selectedline
4172 set findcurline $findstartline
4173 nowbusy finding
4174 if {!$rev} {
4175 run findmore
4176 } else {
4177 if {$findcurline == 0} {
4178 set findcurline $numcommits
4180 incr findcurline -1
4181 run findmorerev
4185 proc findnext {restart} {
4186 global findcurline
4187 if {![info exists findcurline]} {
4188 if {$restart} {
4189 dofind
4190 } else {
4191 bell
4193 } else {
4194 run findmore
4195 nowbusy finding
4199 proc findprev {} {
4200 global findcurline
4201 if {![info exists findcurline]} {
4202 dofind 1
4203 } else {
4204 run findmorerev
4205 nowbusy finding
4209 proc findmore {} {
4210 global commitdata commitinfo numcommits findstring findpattern findloc
4211 global findstartline findcurline displayorder
4213 set fldtypes {Headline Author Date Committer CDate Comments}
4214 set l [expr {$findcurline + 1}]
4215 if {$l >= $numcommits} {
4216 set l 0
4218 if {$l <= $findstartline} {
4219 set lim [expr {$findstartline + 1}]
4220 } else {
4221 set lim $numcommits
4223 if {$lim - $l > 500} {
4224 set lim [expr {$l + 500}]
4226 set last 0
4227 for {} {$l < $lim} {incr l} {
4228 set id [lindex $displayorder $l]
4229 # shouldn't happen unless git log doesn't give all the commits...
4230 if {![info exists commitdata($id)]} continue
4231 if {![doesmatch $commitdata($id)]} continue
4232 if {![info exists commitinfo($id)]} {
4233 getcommit $id
4235 set info $commitinfo($id)
4236 foreach f $info ty $fldtypes {
4237 if {($findloc eq "All fields" || $findloc eq $ty) &&
4238 [doesmatch $f]} {
4239 findselectline $l
4240 notbusy finding
4241 return 0
4245 if {$l == $findstartline + 1} {
4246 bell
4247 unset findcurline
4248 notbusy finding
4249 return 0
4251 set findcurline [expr {$l - 1}]
4252 return 1
4255 proc findmorerev {} {
4256 global commitdata commitinfo numcommits findstring findpattern findloc
4257 global findstartline findcurline displayorder
4259 set fldtypes {Headline Author Date Committer CDate Comments}
4260 set l $findcurline
4261 if {$l == 0} {
4262 set l $numcommits
4264 incr l -1
4265 if {$l >= $findstartline} {
4266 set lim [expr {$findstartline - 1}]
4267 } else {
4268 set lim -1
4270 if {$l - $lim > 500} {
4271 set lim [expr {$l - 500}]
4273 set last 0
4274 for {} {$l > $lim} {incr l -1} {
4275 set id [lindex $displayorder $l]
4276 if {![doesmatch $commitdata($id)]} continue
4277 if {![info exists commitinfo($id)]} {
4278 getcommit $id
4280 set info $commitinfo($id)
4281 foreach f $info ty $fldtypes {
4282 if {($findloc eq "All fields" || $findloc eq $ty) &&
4283 [doesmatch $f]} {
4284 findselectline $l
4285 notbusy finding
4286 return 0
4290 if {$l == -1} {
4291 bell
4292 unset findcurline
4293 notbusy finding
4294 return 0
4296 set findcurline [expr {$l + 1}]
4297 return 1
4300 proc findselectline {l} {
4301 global findloc commentend ctext findcurline markingmatches
4303 set markingmatches 1
4304 set findcurline $l
4305 selectline $l 1
4306 if {$findloc == "All fields" || $findloc == "Comments"} {
4307 # highlight the matches in the comments
4308 set f [$ctext get 1.0 $commentend]
4309 set matches [findmatches $f]
4310 foreach match $matches {
4311 set start [lindex $match 0]
4312 set end [expr {[lindex $match 1] + 1}]
4313 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4316 drawvisible
4319 # mark the bits of a headline or author that match a find string
4320 proc markmatches {canv l str tag matches font row} {
4321 global selectedline
4323 set bbox [$canv bbox $tag]
4324 set x0 [lindex $bbox 0]
4325 set y0 [lindex $bbox 1]
4326 set y1 [lindex $bbox 3]
4327 foreach match $matches {
4328 set start [lindex $match 0]
4329 set end [lindex $match 1]
4330 if {$start > $end} continue
4331 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4332 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4333 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4334 [expr {$x0+$xlen+2}] $y1 \
4335 -outline {} -tags [list match$l matches] -fill yellow]
4336 $canv lower $t
4337 if {[info exists selectedline] && $row == $selectedline} {
4338 $canv raise $t secsel
4343 proc unmarkmatches {} {
4344 global findids markingmatches findcurline
4346 allcanvs delete matches
4347 catch {unset findids}
4348 set markingmatches 0
4349 catch {unset findcurline}
4352 proc selcanvline {w x y} {
4353 global canv canvy0 ctext linespc
4354 global rowtextx
4355 set ymax [lindex [$canv cget -scrollregion] 3]
4356 if {$ymax == {}} return
4357 set yfrac [lindex [$canv yview] 0]
4358 set y [expr {$y + $yfrac * $ymax}]
4359 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4360 if {$l < 0} {
4361 set l 0
4363 if {$w eq $canv} {
4364 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4366 unmarkmatches
4367 selectline $l 1
4370 proc commit_descriptor {p} {
4371 global commitinfo
4372 if {![info exists commitinfo($p)]} {
4373 getcommit $p
4375 set l "..."
4376 if {[llength $commitinfo($p)] > 1} {
4377 set l [lindex $commitinfo($p) 0]
4379 return "$p ($l)\n"
4382 # append some text to the ctext widget, and make any SHA1 ID
4383 # that we know about be a clickable link.
4384 proc appendwithlinks {text tags} {
4385 global ctext commitrow linknum curview
4387 set start [$ctext index "end - 1c"]
4388 $ctext insert end $text $tags
4389 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4390 foreach l $links {
4391 set s [lindex $l 0]
4392 set e [lindex $l 1]
4393 set linkid [string range $text $s $e]
4394 if {![info exists commitrow($curview,$linkid)]} continue
4395 incr e
4396 $ctext tag add link "$start + $s c" "$start + $e c"
4397 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4398 $ctext tag bind link$linknum <1> \
4399 [list selectline $commitrow($curview,$linkid) 1]
4400 incr linknum
4402 $ctext tag conf link -foreground blue -underline 1
4403 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4404 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4407 proc viewnextline {dir} {
4408 global canv linespc
4410 $canv delete hover
4411 set ymax [lindex [$canv cget -scrollregion] 3]
4412 set wnow [$canv yview]
4413 set wtop [expr {[lindex $wnow 0] * $ymax}]
4414 set newtop [expr {$wtop + $dir * $linespc}]
4415 if {$newtop < 0} {
4416 set newtop 0
4417 } elseif {$newtop > $ymax} {
4418 set newtop $ymax
4420 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4423 # add a list of tag or branch names at position pos
4424 # returns the number of names inserted
4425 proc appendrefs {pos ids var} {
4426 global ctext commitrow linknum curview $var maxrefs
4428 if {[catch {$ctext index $pos}]} {
4429 return 0
4431 $ctext conf -state normal
4432 $ctext delete $pos "$pos lineend"
4433 set tags {}
4434 foreach id $ids {
4435 foreach tag [set $var\($id\)] {
4436 lappend tags [list $tag $id]
4439 if {[llength $tags] > $maxrefs} {
4440 $ctext insert $pos "many ([llength $tags])"
4441 } else {
4442 set tags [lsort -index 0 -decreasing $tags]
4443 set sep {}
4444 foreach ti $tags {
4445 set id [lindex $ti 1]
4446 set lk link$linknum
4447 incr linknum
4448 $ctext tag delete $lk
4449 $ctext insert $pos $sep
4450 $ctext insert $pos [lindex $ti 0] $lk
4451 if {[info exists commitrow($curview,$id)]} {
4452 $ctext tag conf $lk -foreground blue
4453 $ctext tag bind $lk <1> \
4454 [list selectline $commitrow($curview,$id) 1]
4455 $ctext tag conf $lk -underline 1
4456 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
4457 $ctext tag bind $lk <Leave> \
4458 { %W configure -cursor $curtextcursor }
4460 set sep ", "
4463 $ctext conf -state disabled
4464 return [llength $tags]
4467 # called when we have finished computing the nearby tags
4468 proc dispneartags {delay} {
4469 global selectedline currentid showneartags tagphase
4471 if {![info exists selectedline] || !$showneartags} return
4472 after cancel dispnexttag
4473 if {$delay} {
4474 after 200 dispnexttag
4475 set tagphase -1
4476 } else {
4477 after idle dispnexttag
4478 set tagphase 0
4482 proc dispnexttag {} {
4483 global selectedline currentid showneartags tagphase ctext
4485 if {![info exists selectedline] || !$showneartags} return
4486 switch -- $tagphase {
4488 set dtags [desctags $currentid]
4489 if {$dtags ne {}} {
4490 appendrefs precedes $dtags idtags
4494 set atags [anctags $currentid]
4495 if {$atags ne {}} {
4496 appendrefs follows $atags idtags
4500 set dheads [descheads $currentid]
4501 if {$dheads ne {}} {
4502 if {[appendrefs branch $dheads idheads] > 1
4503 && [$ctext get "branch -3c"] eq "h"} {
4504 # turn "Branch" into "Branches"
4505 $ctext conf -state normal
4506 $ctext insert "branch -2c" "es"
4507 $ctext conf -state disabled
4512 if {[incr tagphase] <= 2} {
4513 after idle dispnexttag
4517 proc selectline {l isnew} {
4518 global canv canv2 canv3 ctext commitinfo selectedline
4519 global displayorder linehtag linentag linedtag
4520 global canvy0 linespc parentlist children curview
4521 global currentid sha1entry
4522 global commentend idtags linknum
4523 global mergemax numcommits pending_select
4524 global cmitmode showneartags allcommits
4526 catch {unset pending_select}
4527 $canv delete hover
4528 normalline
4529 cancel_next_highlight
4530 unsel_reflist
4531 if {$l < 0 || $l >= $numcommits} return
4532 set y [expr {$canvy0 + $l * $linespc}]
4533 set ymax [lindex [$canv cget -scrollregion] 3]
4534 set ytop [expr {$y - $linespc - 1}]
4535 set ybot [expr {$y + $linespc + 1}]
4536 set wnow [$canv yview]
4537 set wtop [expr {[lindex $wnow 0] * $ymax}]
4538 set wbot [expr {[lindex $wnow 1] * $ymax}]
4539 set wh [expr {$wbot - $wtop}]
4540 set newtop $wtop
4541 if {$ytop < $wtop} {
4542 if {$ybot < $wtop} {
4543 set newtop [expr {$y - $wh / 2.0}]
4544 } else {
4545 set newtop $ytop
4546 if {$newtop > $wtop - $linespc} {
4547 set newtop [expr {$wtop - $linespc}]
4550 } elseif {$ybot > $wbot} {
4551 if {$ytop > $wbot} {
4552 set newtop [expr {$y - $wh / 2.0}]
4553 } else {
4554 set newtop [expr {$ybot - $wh}]
4555 if {$newtop < $wtop + $linespc} {
4556 set newtop [expr {$wtop + $linespc}]
4560 if {$newtop != $wtop} {
4561 if {$newtop < 0} {
4562 set newtop 0
4564 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4565 drawvisible
4568 if {![info exists linehtag($l)]} return
4569 $canv delete secsel
4570 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4571 -tags secsel -fill [$canv cget -selectbackground]]
4572 $canv lower $t
4573 $canv2 delete secsel
4574 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4575 -tags secsel -fill [$canv2 cget -selectbackground]]
4576 $canv2 lower $t
4577 $canv3 delete secsel
4578 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4579 -tags secsel -fill [$canv3 cget -selectbackground]]
4580 $canv3 lower $t
4582 if {$isnew} {
4583 addtohistory [list selectline $l 0]
4586 set selectedline $l
4588 set id [lindex $displayorder $l]
4589 set currentid $id
4590 $sha1entry delete 0 end
4591 $sha1entry insert 0 $id
4592 $sha1entry selection from 0
4593 $sha1entry selection to end
4594 rhighlight_sel $id
4596 $ctext conf -state normal
4597 clear_ctext
4598 set linknum 0
4599 set info $commitinfo($id)
4600 set date [formatdate [lindex $info 2]]
4601 $ctext insert end "Author: [lindex $info 1] $date\n"
4602 set date [formatdate [lindex $info 4]]
4603 $ctext insert end "Committer: [lindex $info 3] $date\n"
4604 if {[info exists idtags($id)]} {
4605 $ctext insert end "Tags:"
4606 foreach tag $idtags($id) {
4607 $ctext insert end " $tag"
4609 $ctext insert end "\n"
4612 set headers {}
4613 set olds [lindex $parentlist $l]
4614 if {[llength $olds] > 1} {
4615 set np 0
4616 foreach p $olds {
4617 if {$np >= $mergemax} {
4618 set tag mmax
4619 } else {
4620 set tag m$np
4622 $ctext insert end "Parent: " $tag
4623 appendwithlinks [commit_descriptor $p] {}
4624 incr np
4626 } else {
4627 foreach p $olds {
4628 append headers "Parent: [commit_descriptor $p]"
4632 foreach c $children($curview,$id) {
4633 append headers "Child: [commit_descriptor $c]"
4636 # make anything that looks like a SHA1 ID be a clickable link
4637 appendwithlinks $headers {}
4638 if {$showneartags} {
4639 if {![info exists allcommits]} {
4640 getallcommits
4642 $ctext insert end "Branch: "
4643 $ctext mark set branch "end -1c"
4644 $ctext mark gravity branch left
4645 $ctext insert end "\nFollows: "
4646 $ctext mark set follows "end -1c"
4647 $ctext mark gravity follows left
4648 $ctext insert end "\nPrecedes: "
4649 $ctext mark set precedes "end -1c"
4650 $ctext mark gravity precedes left
4651 $ctext insert end "\n"
4652 dispneartags 1
4654 $ctext insert end "\n"
4655 set comment [lindex $info 5]
4656 if {[string first "\r" $comment] >= 0} {
4657 set comment [string map {"\r" "\n "} $comment]
4659 appendwithlinks $comment {comment}
4661 $ctext tag remove found 1.0 end
4662 $ctext conf -state disabled
4663 set commentend [$ctext index "end - 1c"]
4665 init_flist "Comments"
4666 if {$cmitmode eq "tree"} {
4667 gettree $id
4668 } elseif {[llength $olds] <= 1} {
4669 startdiff $id
4670 } else {
4671 mergediff $id $l
4675 proc selfirstline {} {
4676 unmarkmatches
4677 selectline 0 1
4680 proc sellastline {} {
4681 global numcommits
4682 unmarkmatches
4683 set l [expr {$numcommits - 1}]
4684 selectline $l 1
4687 proc selnextline {dir} {
4688 global selectedline
4689 focus .
4690 if {![info exists selectedline]} return
4691 set l [expr {$selectedline + $dir}]
4692 unmarkmatches
4693 selectline $l 1
4696 proc selnextpage {dir} {
4697 global canv linespc selectedline numcommits
4699 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4700 if {$lpp < 1} {
4701 set lpp 1
4703 allcanvs yview scroll [expr {$dir * $lpp}] units
4704 drawvisible
4705 if {![info exists selectedline]} return
4706 set l [expr {$selectedline + $dir * $lpp}]
4707 if {$l < 0} {
4708 set l 0
4709 } elseif {$l >= $numcommits} {
4710 set l [expr $numcommits - 1]
4712 unmarkmatches
4713 selectline $l 1
4716 proc unselectline {} {
4717 global selectedline currentid
4719 catch {unset selectedline}
4720 catch {unset currentid}
4721 allcanvs delete secsel
4722 rhighlight_none
4723 cancel_next_highlight
4726 proc reselectline {} {
4727 global selectedline
4729 if {[info exists selectedline]} {
4730 selectline $selectedline 0
4734 proc addtohistory {cmd} {
4735 global history historyindex curview
4737 set elt [list $curview $cmd]
4738 if {$historyindex > 0
4739 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4740 return
4743 if {$historyindex < [llength $history]} {
4744 set history [lreplace $history $historyindex end $elt]
4745 } else {
4746 lappend history $elt
4748 incr historyindex
4749 if {$historyindex > 1} {
4750 .tf.bar.leftbut conf -state normal
4751 } else {
4752 .tf.bar.leftbut conf -state disabled
4754 .tf.bar.rightbut conf -state disabled
4757 proc godo {elt} {
4758 global curview
4760 set view [lindex $elt 0]
4761 set cmd [lindex $elt 1]
4762 if {$curview != $view} {
4763 showview $view
4765 eval $cmd
4768 proc goback {} {
4769 global history historyindex
4770 focus .
4772 if {$historyindex > 1} {
4773 incr historyindex -1
4774 godo [lindex $history [expr {$historyindex - 1}]]
4775 .tf.bar.rightbut conf -state normal
4777 if {$historyindex <= 1} {
4778 .tf.bar.leftbut conf -state disabled
4782 proc goforw {} {
4783 global history historyindex
4784 focus .
4786 if {$historyindex < [llength $history]} {
4787 set cmd [lindex $history $historyindex]
4788 incr historyindex
4789 godo $cmd
4790 .tf.bar.leftbut conf -state normal
4792 if {$historyindex >= [llength $history]} {
4793 .tf.bar.rightbut conf -state disabled
4797 proc gettree {id} {
4798 global treefilelist treeidlist diffids diffmergeid treepending
4799 global nullid nullid2
4801 set diffids $id
4802 catch {unset diffmergeid}
4803 if {![info exists treefilelist($id)]} {
4804 if {![info exists treepending]} {
4805 if {$id eq $nullid} {
4806 set cmd [list | git ls-files]
4807 } elseif {$id eq $nullid2} {
4808 set cmd [list | git ls-files --stage -t]
4809 } else {
4810 set cmd [list | git ls-tree -r $id]
4812 if {[catch {set gtf [open $cmd r]}]} {
4813 return
4815 set treepending $id
4816 set treefilelist($id) {}
4817 set treeidlist($id) {}
4818 fconfigure $gtf -blocking 0
4819 filerun $gtf [list gettreeline $gtf $id]
4821 } else {
4822 setfilelist $id
4826 proc gettreeline {gtf id} {
4827 global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4829 set nl 0
4830 while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4831 if {$diffids eq $nullid} {
4832 set fname $line
4833 } else {
4834 if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4835 set i [string first "\t" $line]
4836 if {$i < 0} continue
4837 set sha1 [lindex $line 2]
4838 set fname [string range $line [expr {$i+1}] end]
4839 if {[string index $fname 0] eq "\""} {
4840 set fname [lindex $fname 0]
4842 lappend treeidlist($id) $sha1
4844 lappend treefilelist($id) $fname
4846 if {![eof $gtf]} {
4847 return [expr {$nl >= 1000? 2: 1}]
4849 close $gtf
4850 unset treepending
4851 if {$cmitmode ne "tree"} {
4852 if {![info exists diffmergeid]} {
4853 gettreediffs $diffids
4855 } elseif {$id ne $diffids} {
4856 gettree $diffids
4857 } else {
4858 setfilelist $id
4860 return 0
4863 proc showfile {f} {
4864 global treefilelist treeidlist diffids nullid nullid2
4865 global ctext commentend
4867 set i [lsearch -exact $treefilelist($diffids) $f]
4868 if {$i < 0} {
4869 puts "oops, $f not in list for id $diffids"
4870 return
4872 if {$diffids eq $nullid} {
4873 if {[catch {set bf [open $f r]} err]} {
4874 puts "oops, can't read $f: $err"
4875 return
4877 } else {
4878 set blob [lindex $treeidlist($diffids) $i]
4879 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4880 puts "oops, error reading blob $blob: $err"
4881 return
4884 fconfigure $bf -blocking 0
4885 filerun $bf [list getblobline $bf $diffids]
4886 $ctext config -state normal
4887 clear_ctext $commentend
4888 $ctext insert end "\n"
4889 $ctext insert end "$f\n" filesep
4890 $ctext config -state disabled
4891 $ctext yview $commentend
4894 proc getblobline {bf id} {
4895 global diffids cmitmode ctext
4897 if {$id ne $diffids || $cmitmode ne "tree"} {
4898 catch {close $bf}
4899 return 0
4901 $ctext config -state normal
4902 set nl 0
4903 while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
4904 $ctext insert end "$line\n"
4906 if {[eof $bf]} {
4907 # delete last newline
4908 $ctext delete "end - 2c" "end - 1c"
4909 close $bf
4910 return 0
4912 $ctext config -state disabled
4913 return [expr {$nl >= 1000? 2: 1}]
4916 proc mergediff {id l} {
4917 global diffmergeid diffopts mdifffd
4918 global diffids
4919 global parentlist
4921 set diffmergeid $id
4922 set diffids $id
4923 # this doesn't seem to actually affect anything...
4924 set env(GIT_DIFF_OPTS) $diffopts
4925 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4926 if {[catch {set mdf [open $cmd r]} err]} {
4927 error_popup "Error getting merge diffs: $err"
4928 return
4930 fconfigure $mdf -blocking 0
4931 set mdifffd($id) $mdf
4932 set np [llength [lindex $parentlist $l]]
4933 filerun $mdf [list getmergediffline $mdf $id $np]
4936 proc getmergediffline {mdf id np} {
4937 global diffmergeid ctext cflist mergemax
4938 global difffilestart mdifffd
4940 $ctext conf -state normal
4941 set nr 0
4942 while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
4943 if {![info exists diffmergeid] || $id != $diffmergeid
4944 || $mdf != $mdifffd($id)} {
4945 close $mdf
4946 return 0
4948 if {[regexp {^diff --cc (.*)} $line match fname]} {
4949 # start of a new file
4950 $ctext insert end "\n"
4951 set here [$ctext index "end - 1c"]
4952 lappend difffilestart $here
4953 add_flist [list $fname]
4954 set l [expr {(78 - [string length $fname]) / 2}]
4955 set pad [string range "----------------------------------------" 1 $l]
4956 $ctext insert end "$pad $fname $pad\n" filesep
4957 } elseif {[regexp {^@@} $line]} {
4958 $ctext insert end "$line\n" hunksep
4959 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4960 # do nothing
4961 } else {
4962 # parse the prefix - one ' ', '-' or '+' for each parent
4963 set spaces {}
4964 set minuses {}
4965 set pluses {}
4966 set isbad 0
4967 for {set j 0} {$j < $np} {incr j} {
4968 set c [string range $line $j $j]
4969 if {$c == " "} {
4970 lappend spaces $j
4971 } elseif {$c == "-"} {
4972 lappend minuses $j
4973 } elseif {$c == "+"} {
4974 lappend pluses $j
4975 } else {
4976 set isbad 1
4977 break
4980 set tags {}
4981 set num {}
4982 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4983 # line doesn't appear in result, parents in $minuses have the line
4984 set num [lindex $minuses 0]
4985 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4986 # line appears in result, parents in $pluses don't have the line
4987 lappend tags mresult
4988 set num [lindex $spaces 0]
4990 if {$num ne {}} {
4991 if {$num >= $mergemax} {
4992 set num "max"
4994 lappend tags m$num
4996 $ctext insert end "$line\n" $tags
4999 $ctext conf -state disabled
5000 if {[eof $mdf]} {
5001 close $mdf
5002 return 0
5004 return [expr {$nr >= 1000? 2: 1}]
5007 proc startdiff {ids} {
5008 global treediffs diffids treepending diffmergeid nullid nullid2
5010 set diffids $ids
5011 catch {unset diffmergeid}
5012 if {![info exists treediffs($ids)] ||
5013 [lsearch -exact $ids $nullid] >= 0 ||
5014 [lsearch -exact $ids $nullid2] >= 0} {
5015 if {![info exists treepending]} {
5016 gettreediffs $ids
5018 } else {
5019 addtocflist $ids
5023 proc addtocflist {ids} {
5024 global treediffs cflist
5025 add_flist $treediffs($ids)
5026 getblobdiffs $ids
5029 proc diffcmd {ids flags} {
5030 global nullid nullid2
5032 set i [lsearch -exact $ids $nullid]
5033 set j [lsearch -exact $ids $nullid2]
5034 if {$i >= 0} {
5035 if {[llength $ids] > 1 && $j < 0} {
5036 # comparing working directory with some specific revision
5037 set cmd [concat | git diff-index $flags]
5038 if {$i == 0} {
5039 lappend cmd -R [lindex $ids 1]
5040 } else {
5041 lappend cmd [lindex $ids 0]
5043 } else {
5044 # comparing working directory with index
5045 set cmd [concat | git diff-files $flags]
5046 if {$j == 1} {
5047 lappend cmd -R
5050 } elseif {$j >= 0} {
5051 set cmd [concat | git diff-index --cached $flags]
5052 if {[llength $ids] > 1} {
5053 # comparing index with specific revision
5054 if {$i == 0} {
5055 lappend cmd -R [lindex $ids 1]
5056 } else {
5057 lappend cmd [lindex $ids 0]
5059 } else {
5060 # comparing index with HEAD
5061 lappend cmd HEAD
5063 } else {
5064 set cmd [concat | git diff-tree -r $flags $ids]
5066 return $cmd
5069 proc gettreediffs {ids} {
5070 global treediff treepending
5072 set treepending $ids
5073 set treediff {}
5074 if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5075 fconfigure $gdtf -blocking 0
5076 filerun $gdtf [list gettreediffline $gdtf $ids]
5079 proc gettreediffline {gdtf ids} {
5080 global treediff treediffs treepending diffids diffmergeid
5081 global cmitmode
5083 set nr 0
5084 while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5085 set i [string first "\t" $line]
5086 if {$i >= 0} {
5087 set file [string range $line [expr {$i+1}] end]
5088 if {[string index $file 0] eq "\""} {
5089 set file [lindex $file 0]
5091 lappend treediff $file
5094 if {![eof $gdtf]} {
5095 return [expr {$nr >= 1000? 2: 1}]
5097 close $gdtf
5098 set treediffs($ids) $treediff
5099 unset treepending
5100 if {$cmitmode eq "tree"} {
5101 gettree $diffids
5102 } elseif {$ids != $diffids} {
5103 if {![info exists diffmergeid]} {
5104 gettreediffs $diffids
5106 } else {
5107 addtocflist $ids
5109 return 0
5112 # empty string or positive integer
5113 proc diffcontextvalidate {v} {
5114 return [regexp {^(|[1-9][0-9]*)$} $v]
5117 proc diffcontextchange {n1 n2 op} {
5118 global diffcontextstring diffcontext
5120 if {[string is integer -strict $diffcontextstring]} {
5121 if {$diffcontextstring > 0} {
5122 set diffcontext $diffcontextstring
5123 reselectline
5128 proc getblobdiffs {ids} {
5129 global diffopts blobdifffd diffids env
5130 global diffinhdr treediffs
5131 global diffcontext
5133 set env(GIT_DIFF_OPTS) $diffopts
5134 if {[catch {set bdf [open [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"] r]} err]} {
5135 puts "error getting diffs: $err"
5136 return
5138 set diffinhdr 0
5139 fconfigure $bdf -blocking 0
5140 set blobdifffd($ids) $bdf
5141 filerun $bdf [list getblobdiffline $bdf $diffids]
5144 proc setinlist {var i val} {
5145 global $var
5147 while {[llength [set $var]] < $i} {
5148 lappend $var {}
5150 if {[llength [set $var]] == $i} {
5151 lappend $var $val
5152 } else {
5153 lset $var $i $val
5157 proc makediffhdr {fname ids} {
5158 global ctext curdiffstart treediffs
5160 set i [lsearch -exact $treediffs($ids) $fname]
5161 if {$i >= 0} {
5162 setinlist difffilestart $i $curdiffstart
5164 set l [expr {(78 - [string length $fname]) / 2}]
5165 set pad [string range "----------------------------------------" 1 $l]
5166 $ctext insert $curdiffstart "$pad $fname $pad" filesep
5169 proc getblobdiffline {bdf ids} {
5170 global diffids blobdifffd ctext curdiffstart
5171 global diffnexthead diffnextnote difffilestart
5172 global diffinhdr treediffs
5174 set nr 0
5175 $ctext conf -state normal
5176 while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5177 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5178 close $bdf
5179 return 0
5181 if {![string compare -length 11 "diff --git " $line]} {
5182 # trim off "diff --git "
5183 set line [string range $line 11 end]
5184 set diffinhdr 1
5185 # start of a new file
5186 $ctext insert end "\n"
5187 set curdiffstart [$ctext index "end - 1c"]
5188 $ctext insert end "\n" filesep
5189 # If the name hasn't changed the length will be odd,
5190 # the middle char will be a space, and the two bits either
5191 # side will be a/name and b/name, or "a/name" and "b/name".
5192 # If the name has changed we'll get "rename from" and
5193 # "rename to" or "copy from" and "copy to" lines following this,
5194 # and we'll use them to get the filenames.
5195 # This complexity is necessary because spaces in the filename(s)
5196 # don't get escaped.
5197 set l [string length $line]
5198 set i [expr {$l / 2}]
5199 if {!(($l & 1) && [string index $line $i] eq " " &&
5200 [string range $line 2 [expr {$i - 1}]] eq \
5201 [string range $line [expr {$i + 3}] end])} {
5202 continue
5204 # unescape if quoted and chop off the a/ from the front
5205 if {[string index $line 0] eq "\""} {
5206 set fname [string range [lindex $line 0] 2 end]
5207 } else {
5208 set fname [string range $line 2 [expr {$i - 1}]]
5210 makediffhdr $fname $ids
5212 } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5213 $line match f1l f1c f2l f2c rest]} {
5214 $ctext insert end "$line\n" hunksep
5215 set diffinhdr 0
5217 } elseif {$diffinhdr} {
5218 if {![string compare -length 12 "rename from " $line] ||
5219 ![string compare -length 10 "copy from " $line]} {
5220 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5221 if {[string index $fname 0] eq "\""} {
5222 set fname [lindex $fname 0]
5224 set i [lsearch -exact $treediffs($ids) $fname]
5225 if {$i >= 0} {
5226 setinlist difffilestart $i $curdiffstart
5228 } elseif {![string compare -length 10 $line "rename to "] ||
5229 ![string compare -length 8 $line "copy to "]} {
5230 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5231 if {[string index $fname 0] eq "\""} {
5232 set fname [lindex $fname 0]
5234 makediffhdr $fname $ids
5235 } elseif {[string compare -length 3 $line "---"] == 0} {
5236 # do nothing
5237 continue
5238 } elseif {[string compare -length 3 $line "+++"] == 0} {
5239 set diffinhdr 0
5240 continue
5242 $ctext insert end "$line\n" filesep
5244 } else {
5245 set x [string range $line 0 0]
5246 if {$x == "-" || $x == "+"} {
5247 set tag [expr {$x == "+"}]
5248 $ctext insert end "$line\n" d$tag
5249 } elseif {$x == " "} {
5250 $ctext insert end "$line\n"
5251 } else {
5252 # "\ No newline at end of file",
5253 # or something else we don't recognize
5254 $ctext insert end "$line\n" hunksep
5258 $ctext conf -state disabled
5259 if {[eof $bdf]} {
5260 close $bdf
5261 return 0
5263 return [expr {$nr >= 1000? 2: 1}]
5266 proc changediffdisp {} {
5267 global ctext diffelide
5269 $ctext tag conf d0 -elide [lindex $diffelide 0]
5270 $ctext tag conf d1 -elide [lindex $diffelide 1]
5273 proc prevfile {} {
5274 global difffilestart ctext
5275 set prev [lindex $difffilestart 0]
5276 set here [$ctext index @0,0]
5277 foreach loc $difffilestart {
5278 if {[$ctext compare $loc >= $here]} {
5279 $ctext yview $prev
5280 return
5282 set prev $loc
5284 $ctext yview $prev
5287 proc nextfile {} {
5288 global difffilestart ctext
5289 set here [$ctext index @0,0]
5290 foreach loc $difffilestart {
5291 if {[$ctext compare $loc > $here]} {
5292 $ctext yview $loc
5293 return
5298 proc clear_ctext {{first 1.0}} {
5299 global ctext smarktop smarkbot
5301 set l [lindex [split $first .] 0]
5302 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5303 set smarktop $l
5305 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5306 set smarkbot $l
5308 $ctext delete $first end
5311 proc incrsearch {name ix op} {
5312 global ctext searchstring searchdirn
5314 $ctext tag remove found 1.0 end
5315 if {[catch {$ctext index anchor}]} {
5316 # no anchor set, use start of selection, or of visible area
5317 set sel [$ctext tag ranges sel]
5318 if {$sel ne {}} {
5319 $ctext mark set anchor [lindex $sel 0]
5320 } elseif {$searchdirn eq "-forwards"} {
5321 $ctext mark set anchor @0,0
5322 } else {
5323 $ctext mark set anchor @0,[winfo height $ctext]
5326 if {$searchstring ne {}} {
5327 set here [$ctext search $searchdirn -- $searchstring anchor]
5328 if {$here ne {}} {
5329 $ctext see $here
5331 searchmarkvisible 1
5335 proc dosearch {} {
5336 global sstring ctext searchstring searchdirn
5338 focus $sstring
5339 $sstring icursor end
5340 set searchdirn -forwards
5341 if {$searchstring ne {}} {
5342 set sel [$ctext tag ranges sel]
5343 if {$sel ne {}} {
5344 set start "[lindex $sel 0] + 1c"
5345 } elseif {[catch {set start [$ctext index anchor]}]} {
5346 set start "@0,0"
5348 set match [$ctext search -count mlen -- $searchstring $start]
5349 $ctext tag remove sel 1.0 end
5350 if {$match eq {}} {
5351 bell
5352 return
5354 $ctext see $match
5355 set mend "$match + $mlen c"
5356 $ctext tag add sel $match $mend
5357 $ctext mark unset anchor
5361 proc dosearchback {} {
5362 global sstring ctext searchstring searchdirn
5364 focus $sstring
5365 $sstring icursor end
5366 set searchdirn -backwards
5367 if {$searchstring ne {}} {
5368 set sel [$ctext tag ranges sel]
5369 if {$sel ne {}} {
5370 set start [lindex $sel 0]
5371 } elseif {[catch {set start [$ctext index anchor]}]} {
5372 set start @0,[winfo height $ctext]
5374 set match [$ctext search -backwards -count ml -- $searchstring $start]
5375 $ctext tag remove sel 1.0 end
5376 if {$match eq {}} {
5377 bell
5378 return
5380 $ctext see $match
5381 set mend "$match + $ml c"
5382 $ctext tag add sel $match $mend
5383 $ctext mark unset anchor
5387 proc searchmark {first last} {
5388 global ctext searchstring
5390 set mend $first.0
5391 while {1} {
5392 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5393 if {$match eq {}} break
5394 set mend "$match + $mlen c"
5395 $ctext tag add found $match $mend
5399 proc searchmarkvisible {doall} {
5400 global ctext smarktop smarkbot
5402 set topline [lindex [split [$ctext index @0,0] .] 0]
5403 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5404 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5405 # no overlap with previous
5406 searchmark $topline $botline
5407 set smarktop $topline
5408 set smarkbot $botline
5409 } else {
5410 if {$topline < $smarktop} {
5411 searchmark $topline [expr {$smarktop-1}]
5412 set smarktop $topline
5414 if {$botline > $smarkbot} {
5415 searchmark [expr {$smarkbot+1}] $botline
5416 set smarkbot $botline
5421 proc scrolltext {f0 f1} {
5422 global searchstring
5424 .bleft.sb set $f0 $f1
5425 if {$searchstring ne {}} {
5426 searchmarkvisible 0
5430 proc setcoords {} {
5431 global linespc charspc canvx0 canvy0 mainfont
5432 global xspc1 xspc2 lthickness
5434 set linespc [font metrics $mainfont -linespace]
5435 set charspc [font measure $mainfont "m"]
5436 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5437 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5438 set lthickness [expr {int($linespc / 9) + 1}]
5439 set xspc1(0) $linespc
5440 set xspc2 $linespc
5443 proc redisplay {} {
5444 global canv
5445 global selectedline
5447 set ymax [lindex [$canv cget -scrollregion] 3]
5448 if {$ymax eq {} || $ymax == 0} return
5449 set span [$canv yview]
5450 clear_display
5451 setcanvscroll
5452 allcanvs yview moveto [lindex $span 0]
5453 drawvisible
5454 if {[info exists selectedline]} {
5455 selectline $selectedline 0
5456 allcanvs yview moveto [lindex $span 0]
5460 proc incrfont {inc} {
5461 global mainfont textfont ctext canv phase cflist showrefstop
5462 global charspc tabstop
5463 global stopped entries
5464 unmarkmatches
5465 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
5466 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
5467 setcoords
5468 $ctext conf -font $textfont -tabs "[expr {$tabstop * $charspc}]"
5469 $cflist conf -font $textfont
5470 $ctext tag conf filesep -font [concat $textfont bold]
5471 foreach e $entries {
5472 $e conf -font $mainfont
5474 if {$phase eq "getcommits"} {
5475 $canv itemconf textitems -font $mainfont
5477 if {[info exists showrefstop] && [winfo exists $showrefstop]} {
5478 $showrefstop.list conf -font $mainfont
5480 redisplay
5483 proc clearsha1 {} {
5484 global sha1entry sha1string
5485 if {[string length $sha1string] == 40} {
5486 $sha1entry delete 0 end
5490 proc sha1change {n1 n2 op} {
5491 global sha1string currentid sha1but
5492 if {$sha1string == {}
5493 || ([info exists currentid] && $sha1string == $currentid)} {
5494 set state disabled
5495 } else {
5496 set state normal
5498 if {[$sha1but cget -state] == $state} return
5499 if {$state == "normal"} {
5500 $sha1but conf -state normal -relief raised -text "Goto: "
5501 } else {
5502 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5506 proc gotocommit {} {
5507 global sha1string currentid commitrow tagids headids
5508 global displayorder numcommits curview
5510 if {$sha1string == {}
5511 || ([info exists currentid] && $sha1string == $currentid)} return
5512 if {[info exists tagids($sha1string)]} {
5513 set id $tagids($sha1string)
5514 } elseif {[info exists headids($sha1string)]} {
5515 set id $headids($sha1string)
5516 } else {
5517 set id [string tolower $sha1string]
5518 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5519 set matches {}
5520 foreach i $displayorder {
5521 if {[string match $id* $i]} {
5522 lappend matches $i
5525 if {$matches ne {}} {
5526 if {[llength $matches] > 1} {
5527 error_popup "Short SHA1 id $id is ambiguous"
5528 return
5530 set id [lindex $matches 0]
5534 if {[info exists commitrow($curview,$id)]} {
5535 selectline $commitrow($curview,$id) 1
5536 return
5538 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5539 set type "SHA1 id"
5540 } else {
5541 set type "Tag/Head"
5543 error_popup "$type $sha1string is not known"
5546 proc lineenter {x y id} {
5547 global hoverx hovery hoverid hovertimer
5548 global commitinfo canv
5550 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5551 set hoverx $x
5552 set hovery $y
5553 set hoverid $id
5554 if {[info exists hovertimer]} {
5555 after cancel $hovertimer
5557 set hovertimer [after 500 linehover]
5558 $canv delete hover
5561 proc linemotion {x y id} {
5562 global hoverx hovery hoverid hovertimer
5564 if {[info exists hoverid] && $id == $hoverid} {
5565 set hoverx $x
5566 set hovery $y
5567 if {[info exists hovertimer]} {
5568 after cancel $hovertimer
5570 set hovertimer [after 500 linehover]
5574 proc lineleave {id} {
5575 global hoverid hovertimer canv
5577 if {[info exists hoverid] && $id == $hoverid} {
5578 $canv delete hover
5579 if {[info exists hovertimer]} {
5580 after cancel $hovertimer
5581 unset hovertimer
5583 unset hoverid
5587 proc linehover {} {
5588 global hoverx hovery hoverid hovertimer
5589 global canv linespc lthickness
5590 global commitinfo mainfont
5592 set text [lindex $commitinfo($hoverid) 0]
5593 set ymax [lindex [$canv cget -scrollregion] 3]
5594 if {$ymax == {}} return
5595 set yfrac [lindex [$canv yview] 0]
5596 set x [expr {$hoverx + 2 * $linespc}]
5597 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5598 set x0 [expr {$x - 2 * $lthickness}]
5599 set y0 [expr {$y - 2 * $lthickness}]
5600 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
5601 set y1 [expr {$y + $linespc + 2 * $lthickness}]
5602 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5603 -fill \#ffff80 -outline black -width 1 -tags hover]
5604 $canv raise $t
5605 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5606 -font $mainfont]
5607 $canv raise $t
5610 proc clickisonarrow {id y} {
5611 global lthickness
5613 set ranges [rowranges $id]
5614 set thresh [expr {2 * $lthickness + 6}]
5615 set n [expr {[llength $ranges] - 1}]
5616 for {set i 1} {$i < $n} {incr i} {
5617 set row [lindex $ranges $i]
5618 if {abs([yc $row] - $y) < $thresh} {
5619 return $i
5622 return {}
5625 proc arrowjump {id n y} {
5626 global canv
5628 # 1 <-> 2, 3 <-> 4, etc...
5629 set n [expr {(($n - 1) ^ 1) + 1}]
5630 set row [lindex [rowranges $id] $n]
5631 set yt [yc $row]
5632 set ymax [lindex [$canv cget -scrollregion] 3]
5633 if {$ymax eq {} || $ymax <= 0} return
5634 set view [$canv yview]
5635 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5636 set yfrac [expr {$yt / $ymax - $yspan / 2}]
5637 if {$yfrac < 0} {
5638 set yfrac 0
5640 allcanvs yview moveto $yfrac
5643 proc lineclick {x y id isnew} {
5644 global ctext commitinfo children canv thickerline curview
5646 if {![info exists commitinfo($id)] && ![getcommit $id]} return
5647 unmarkmatches
5648 unselectline
5649 normalline
5650 $canv delete hover
5651 # draw this line thicker than normal
5652 set thickerline $id
5653 drawlines $id
5654 if {$isnew} {
5655 set ymax [lindex [$canv cget -scrollregion] 3]
5656 if {$ymax eq {}} return
5657 set yfrac [lindex [$canv yview] 0]
5658 set y [expr {$y + $yfrac * $ymax}]
5660 set dirn [clickisonarrow $id $y]
5661 if {$dirn ne {}} {
5662 arrowjump $id $dirn $y
5663 return
5666 if {$isnew} {
5667 addtohistory [list lineclick $x $y $id 0]
5669 # fill the details pane with info about this line
5670 $ctext conf -state normal
5671 clear_ctext
5672 $ctext tag conf link -foreground blue -underline 1
5673 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5674 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5675 $ctext insert end "Parent:\t"
5676 $ctext insert end $id [list link link0]
5677 $ctext tag bind link0 <1> [list selbyid $id]
5678 set info $commitinfo($id)
5679 $ctext insert end "\n\t[lindex $info 0]\n"
5680 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5681 set date [formatdate [lindex $info 2]]
5682 $ctext insert end "\tDate:\t$date\n"
5683 set kids $children($curview,$id)
5684 if {$kids ne {}} {
5685 $ctext insert end "\nChildren:"
5686 set i 0
5687 foreach child $kids {
5688 incr i
5689 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5690 set info $commitinfo($child)
5691 $ctext insert end "\n\t"
5692 $ctext insert end $child [list link link$i]
5693 $ctext tag bind link$i <1> [list selbyid $child]
5694 $ctext insert end "\n\t[lindex $info 0]"
5695 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5696 set date [formatdate [lindex $info 2]]
5697 $ctext insert end "\n\tDate:\t$date\n"
5700 $ctext conf -state disabled
5701 init_flist {}
5704 proc normalline {} {
5705 global thickerline
5706 if {[info exists thickerline]} {
5707 set id $thickerline
5708 unset thickerline
5709 drawlines $id
5713 proc selbyid {id} {
5714 global commitrow curview
5715 if {[info exists commitrow($curview,$id)]} {
5716 selectline $commitrow($curview,$id) 1
5720 proc mstime {} {
5721 global startmstime
5722 if {![info exists startmstime]} {
5723 set startmstime [clock clicks -milliseconds]
5725 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5728 proc rowmenu {x y id} {
5729 global rowctxmenu commitrow selectedline rowmenuid curview
5730 global nullid nullid2 fakerowmenu mainhead
5732 set rowmenuid $id
5733 if {![info exists selectedline]
5734 || $commitrow($curview,$id) eq $selectedline} {
5735 set state disabled
5736 } else {
5737 set state normal
5739 if {$id ne $nullid && $id ne $nullid2} {
5740 set menu $rowctxmenu
5741 $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5742 } else {
5743 set menu $fakerowmenu
5745 $menu entryconfigure "Diff this*" -state $state
5746 $menu entryconfigure "Diff selected*" -state $state
5747 $menu entryconfigure "Make patch" -state $state
5748 tk_popup $menu $x $y
5751 proc diffvssel {dirn} {
5752 global rowmenuid selectedline displayorder
5754 if {![info exists selectedline]} return
5755 if {$dirn} {
5756 set oldid [lindex $displayorder $selectedline]
5757 set newid $rowmenuid
5758 } else {
5759 set oldid $rowmenuid
5760 set newid [lindex $displayorder $selectedline]
5762 addtohistory [list doseldiff $oldid $newid]
5763 doseldiff $oldid $newid
5766 proc doseldiff {oldid newid} {
5767 global ctext
5768 global commitinfo
5770 $ctext conf -state normal
5771 clear_ctext
5772 init_flist "Top"
5773 $ctext insert end "From "
5774 $ctext tag conf link -foreground blue -underline 1
5775 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
5776 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
5777 $ctext tag bind link0 <1> [list selbyid $oldid]
5778 $ctext insert end $oldid [list link link0]
5779 $ctext insert end "\n "
5780 $ctext insert end [lindex $commitinfo($oldid) 0]
5781 $ctext insert end "\n\nTo "
5782 $ctext tag bind link1 <1> [list selbyid $newid]
5783 $ctext insert end $newid [list link link1]
5784 $ctext insert end "\n "
5785 $ctext insert end [lindex $commitinfo($newid) 0]
5786 $ctext insert end "\n"
5787 $ctext conf -state disabled
5788 $ctext tag remove found 1.0 end
5789 startdiff [list $oldid $newid]
5792 proc mkpatch {} {
5793 global rowmenuid currentid commitinfo patchtop patchnum
5795 if {![info exists currentid]} return
5796 set oldid $currentid
5797 set oldhead [lindex $commitinfo($oldid) 0]
5798 set newid $rowmenuid
5799 set newhead [lindex $commitinfo($newid) 0]
5800 set top .patch
5801 set patchtop $top
5802 catch {destroy $top}
5803 toplevel $top
5804 label $top.title -text "Generate patch"
5805 grid $top.title - -pady 10
5806 label $top.from -text "From:"
5807 entry $top.fromsha1 -width 40 -relief flat
5808 $top.fromsha1 insert 0 $oldid
5809 $top.fromsha1 conf -state readonly
5810 grid $top.from $top.fromsha1 -sticky w
5811 entry $top.fromhead -width 60 -relief flat
5812 $top.fromhead insert 0 $oldhead
5813 $top.fromhead conf -state readonly
5814 grid x $top.fromhead -sticky w
5815 label $top.to -text "To:"
5816 entry $top.tosha1 -width 40 -relief flat
5817 $top.tosha1 insert 0 $newid
5818 $top.tosha1 conf -state readonly
5819 grid $top.to $top.tosha1 -sticky w
5820 entry $top.tohead -width 60 -relief flat
5821 $top.tohead insert 0 $newhead
5822 $top.tohead conf -state readonly
5823 grid x $top.tohead -sticky w
5824 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5825 grid $top.rev x -pady 10
5826 label $top.flab -text "Output file:"
5827 entry $top.fname -width 60
5828 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5829 incr patchnum
5830 grid $top.flab $top.fname -sticky w
5831 frame $top.buts
5832 button $top.buts.gen -text "Generate" -command mkpatchgo
5833 button $top.buts.can -text "Cancel" -command mkpatchcan
5834 grid $top.buts.gen $top.buts.can
5835 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5836 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5837 grid $top.buts - -pady 10 -sticky ew
5838 focus $top.fname
5841 proc mkpatchrev {} {
5842 global patchtop
5844 set oldid [$patchtop.fromsha1 get]
5845 set oldhead [$patchtop.fromhead get]
5846 set newid [$patchtop.tosha1 get]
5847 set newhead [$patchtop.tohead get]
5848 foreach e [list fromsha1 fromhead tosha1 tohead] \
5849 v [list $newid $newhead $oldid $oldhead] {
5850 $patchtop.$e conf -state normal
5851 $patchtop.$e delete 0 end
5852 $patchtop.$e insert 0 $v
5853 $patchtop.$e conf -state readonly
5857 proc mkpatchgo {} {
5858 global patchtop nullid nullid2
5860 set oldid [$patchtop.fromsha1 get]
5861 set newid [$patchtop.tosha1 get]
5862 set fname [$patchtop.fname get]
5863 set cmd [diffcmd [list $oldid $newid] -p]
5864 lappend cmd >$fname &
5865 if {[catch {eval exec $cmd} err]} {
5866 error_popup "Error creating patch: $err"
5868 catch {destroy $patchtop}
5869 unset patchtop
5872 proc mkpatchcan {} {
5873 global patchtop
5875 catch {destroy $patchtop}
5876 unset patchtop
5879 proc mktag {} {
5880 global rowmenuid mktagtop commitinfo
5882 set top .maketag
5883 set mktagtop $top
5884 catch {destroy $top}
5885 toplevel $top
5886 label $top.title -text "Create tag"
5887 grid $top.title - -pady 10
5888 label $top.id -text "ID:"
5889 entry $top.sha1 -width 40 -relief flat
5890 $top.sha1 insert 0 $rowmenuid
5891 $top.sha1 conf -state readonly
5892 grid $top.id $top.sha1 -sticky w
5893 entry $top.head -width 60 -relief flat
5894 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5895 $top.head conf -state readonly
5896 grid x $top.head -sticky w
5897 label $top.tlab -text "Tag name:"
5898 entry $top.tag -width 60
5899 grid $top.tlab $top.tag -sticky w
5900 frame $top.buts
5901 button $top.buts.gen -text "Create" -command mktaggo
5902 button $top.buts.can -text "Cancel" -command mktagcan
5903 grid $top.buts.gen $top.buts.can
5904 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5905 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5906 grid $top.buts - -pady 10 -sticky ew
5907 focus $top.tag
5910 proc domktag {} {
5911 global mktagtop env tagids idtags
5913 set id [$mktagtop.sha1 get]
5914 set tag [$mktagtop.tag get]
5915 if {$tag == {}} {
5916 error_popup "No tag name specified"
5917 return
5919 if {[info exists tagids($tag)]} {
5920 error_popup "Tag \"$tag\" already exists"
5921 return
5923 if {[catch {
5924 set dir [gitdir]
5925 set fname [file join $dir "refs/tags" $tag]
5926 set f [open $fname w]
5927 puts $f $id
5928 close $f
5929 } err]} {
5930 error_popup "Error creating tag: $err"
5931 return
5934 set tagids($tag) $id
5935 lappend idtags($id) $tag
5936 redrawtags $id
5937 addedtag $id
5938 dispneartags 0
5939 run refill_reflist
5942 proc redrawtags {id} {
5943 global canv linehtag commitrow idpos selectedline curview
5944 global mainfont canvxmax iddrawn
5946 if {![info exists commitrow($curview,$id)]} return
5947 if {![info exists iddrawn($id)]} return
5948 drawcommits $commitrow($curview,$id)
5949 $canv delete tag.$id
5950 set xt [eval drawtags $id $idpos($id)]
5951 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5952 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5953 set xr [expr {$xt + [font measure $mainfont $text]}]
5954 if {$xr > $canvxmax} {
5955 set canvxmax $xr
5956 setcanvscroll
5958 if {[info exists selectedline]
5959 && $selectedline == $commitrow($curview,$id)} {
5960 selectline $selectedline 0
5964 proc mktagcan {} {
5965 global mktagtop
5967 catch {destroy $mktagtop}
5968 unset mktagtop
5971 proc mktaggo {} {
5972 domktag
5973 mktagcan
5976 proc writecommit {} {
5977 global rowmenuid wrcomtop commitinfo wrcomcmd
5979 set top .writecommit
5980 set wrcomtop $top
5981 catch {destroy $top}
5982 toplevel $top
5983 label $top.title -text "Write commit to file"
5984 grid $top.title - -pady 10
5985 label $top.id -text "ID:"
5986 entry $top.sha1 -width 40 -relief flat
5987 $top.sha1 insert 0 $rowmenuid
5988 $top.sha1 conf -state readonly
5989 grid $top.id $top.sha1 -sticky w
5990 entry $top.head -width 60 -relief flat
5991 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5992 $top.head conf -state readonly
5993 grid x $top.head -sticky w
5994 label $top.clab -text "Command:"
5995 entry $top.cmd -width 60 -textvariable wrcomcmd
5996 grid $top.clab $top.cmd -sticky w -pady 10
5997 label $top.flab -text "Output file:"
5998 entry $top.fname -width 60
5999 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6000 grid $top.flab $top.fname -sticky w
6001 frame $top.buts
6002 button $top.buts.gen -text "Write" -command wrcomgo
6003 button $top.buts.can -text "Cancel" -command wrcomcan
6004 grid $top.buts.gen $top.buts.can
6005 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6006 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6007 grid $top.buts - -pady 10 -sticky ew
6008 focus $top.fname
6011 proc wrcomgo {} {
6012 global wrcomtop
6014 set id [$wrcomtop.sha1 get]
6015 set cmd "echo $id | [$wrcomtop.cmd get]"
6016 set fname [$wrcomtop.fname get]
6017 if {[catch {exec sh -c $cmd >$fname &} err]} {
6018 error_popup "Error writing commit: $err"
6020 catch {destroy $wrcomtop}
6021 unset wrcomtop
6024 proc wrcomcan {} {
6025 global wrcomtop
6027 catch {destroy $wrcomtop}
6028 unset wrcomtop
6031 proc mkbranch {} {
6032 global rowmenuid mkbrtop
6034 set top .makebranch
6035 catch {destroy $top}
6036 toplevel $top
6037 label $top.title -text "Create new branch"
6038 grid $top.title - -pady 10
6039 label $top.id -text "ID:"
6040 entry $top.sha1 -width 40 -relief flat
6041 $top.sha1 insert 0 $rowmenuid
6042 $top.sha1 conf -state readonly
6043 grid $top.id $top.sha1 -sticky w
6044 label $top.nlab -text "Name:"
6045 entry $top.name -width 40
6046 grid $top.nlab $top.name -sticky w
6047 frame $top.buts
6048 button $top.buts.go -text "Create" -command [list mkbrgo $top]
6049 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6050 grid $top.buts.go $top.buts.can
6051 grid columnconfigure $top.buts 0 -weight 1 -uniform a
6052 grid columnconfigure $top.buts 1 -weight 1 -uniform a
6053 grid $top.buts - -pady 10 -sticky ew
6054 focus $top.name
6057 proc mkbrgo {top} {
6058 global headids idheads
6060 set name [$top.name get]
6061 set id [$top.sha1 get]
6062 if {$name eq {}} {
6063 error_popup "Please specify a name for the new branch"
6064 return
6066 catch {destroy $top}
6067 nowbusy newbranch
6068 update
6069 if {[catch {
6070 exec git branch $name $id
6071 } err]} {
6072 notbusy newbranch
6073 error_popup $err
6074 } else {
6075 set headids($name) $id
6076 lappend idheads($id) $name
6077 addedhead $id $name
6078 notbusy newbranch
6079 redrawtags $id
6080 dispneartags 0
6081 run refill_reflist
6085 proc cherrypick {} {
6086 global rowmenuid curview commitrow
6087 global mainhead
6089 set oldhead [exec git rev-parse HEAD]
6090 set dheads [descheads $rowmenuid]
6091 if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6092 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6093 included in branch $mainhead -- really re-apply it?"]
6094 if {!$ok} return
6096 nowbusy cherrypick
6097 update
6098 # Unfortunately git-cherry-pick writes stuff to stderr even when
6099 # no error occurs, and exec takes that as an indication of error...
6100 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6101 notbusy cherrypick
6102 error_popup $err
6103 return
6105 set newhead [exec git rev-parse HEAD]
6106 if {$newhead eq $oldhead} {
6107 notbusy cherrypick
6108 error_popup "No changes committed"
6109 return
6111 addnewchild $newhead $oldhead
6112 if {[info exists commitrow($curview,$oldhead)]} {
6113 insertrow $commitrow($curview,$oldhead) $newhead
6114 if {$mainhead ne {}} {
6115 movehead $newhead $mainhead
6116 movedhead $newhead $mainhead
6118 redrawtags $oldhead
6119 redrawtags $newhead
6121 notbusy cherrypick
6124 proc resethead {} {
6125 global mainheadid mainhead rowmenuid confirm_ok resettype
6126 global showlocalchanges
6128 set confirm_ok 0
6129 set w ".confirmreset"
6130 toplevel $w
6131 wm transient $w .
6132 wm title $w "Confirm reset"
6133 message $w.m -text \
6134 "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6135 -justify center -aspect 1000
6136 pack $w.m -side top -fill x -padx 20 -pady 20
6137 frame $w.f -relief sunken -border 2
6138 message $w.f.rt -text "Reset type:" -aspect 1000
6139 grid $w.f.rt -sticky w
6140 set resettype mixed
6141 radiobutton $w.f.soft -value soft -variable resettype -justify left \
6142 -text "Soft: Leave working tree and index untouched"
6143 grid $w.f.soft -sticky w
6144 radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6145 -text "Mixed: Leave working tree untouched, reset index"
6146 grid $w.f.mixed -sticky w
6147 radiobutton $w.f.hard -value hard -variable resettype -justify left \
6148 -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6149 grid $w.f.hard -sticky w
6150 pack $w.f -side top -fill x
6151 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6152 pack $w.ok -side left -fill x -padx 20 -pady 20
6153 button $w.cancel -text Cancel -command "destroy $w"
6154 pack $w.cancel -side right -fill x -padx 20 -pady 20
6155 bind $w <Visibility> "grab $w; focus $w"
6156 tkwait window $w
6157 if {!$confirm_ok} return
6158 if {[catch {set fd [open \
6159 [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6160 error_popup $err
6161 } else {
6162 dohidelocalchanges
6163 set w ".resetprogress"
6164 filerun $fd [list readresetstat $fd $w]
6165 toplevel $w
6166 wm transient $w
6167 wm title $w "Reset progress"
6168 message $w.m -text "Reset in progress, please wait..." \
6169 -justify center -aspect 1000
6170 pack $w.m -side top -fill x -padx 20 -pady 5
6171 canvas $w.c -width 150 -height 20 -bg white
6172 $w.c create rect 0 0 0 20 -fill green -tags rect
6173 pack $w.c -side top -fill x -padx 20 -pady 5 -expand 1
6174 nowbusy reset
6178 proc readresetstat {fd w} {
6179 global mainhead mainheadid showlocalchanges
6181 if {[gets $fd line] >= 0} {
6182 if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6183 set x [expr {($m * 150) / $n}]
6184 $w.c coords rect 0 0 $x 20
6186 return 1
6188 destroy $w
6189 notbusy reset
6190 if {[catch {close $fd} err]} {
6191 error_popup $err
6193 set oldhead $mainheadid
6194 set newhead [exec git rev-parse HEAD]
6195 if {$newhead ne $oldhead} {
6196 movehead $newhead $mainhead
6197 movedhead $newhead $mainhead
6198 set mainheadid $newhead
6199 redrawtags $oldhead
6200 redrawtags $newhead
6202 if {$showlocalchanges} {
6203 doshowlocalchanges
6205 return 0
6208 # context menu for a head
6209 proc headmenu {x y id head} {
6210 global headmenuid headmenuhead headctxmenu mainhead
6212 set headmenuid $id
6213 set headmenuhead $head
6214 set state normal
6215 if {$head eq $mainhead} {
6216 set state disabled
6218 $headctxmenu entryconfigure 0 -state $state
6219 $headctxmenu entryconfigure 1 -state $state
6220 tk_popup $headctxmenu $x $y
6223 proc cobranch {} {
6224 global headmenuid headmenuhead mainhead headids
6225 global showlocalchanges mainheadid
6227 # check the tree is clean first??
6228 set oldmainhead $mainhead
6229 nowbusy checkout
6230 update
6231 dohidelocalchanges
6232 if {[catch {
6233 exec git checkout -q $headmenuhead
6234 } err]} {
6235 notbusy checkout
6236 error_popup $err
6237 } else {
6238 notbusy checkout
6239 set mainhead $headmenuhead
6240 set mainheadid $headmenuid
6241 if {[info exists headids($oldmainhead)]} {
6242 redrawtags $headids($oldmainhead)
6244 redrawtags $headmenuid
6246 if {$showlocalchanges} {
6247 dodiffindex
6251 proc rmbranch {} {
6252 global headmenuid headmenuhead mainhead
6253 global idheads
6255 set head $headmenuhead
6256 set id $headmenuid
6257 # this check shouldn't be needed any more...
6258 if {$head eq $mainhead} {
6259 error_popup "Cannot delete the currently checked-out branch"
6260 return
6262 set dheads [descheads $id]
6263 if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6264 # the stuff on this branch isn't on any other branch
6265 if {![confirm_popup "The commits on branch $head aren't on any other\
6266 branch.\nReally delete branch $head?"]} return
6268 nowbusy rmbranch
6269 update
6270 if {[catch {exec git branch -D $head} err]} {
6271 notbusy rmbranch
6272 error_popup $err
6273 return
6275 removehead $id $head
6276 removedhead $id $head
6277 redrawtags $id
6278 notbusy rmbranch
6279 dispneartags 0
6280 run refill_reflist
6283 # Display a list of tags and heads
6284 proc showrefs {} {
6285 global showrefstop bgcolor fgcolor selectbgcolor mainfont
6286 global bglist fglist uifont reflistfilter reflist maincursor
6288 set top .showrefs
6289 set showrefstop $top
6290 if {[winfo exists $top]} {
6291 raise $top
6292 refill_reflist
6293 return
6295 toplevel $top
6296 wm title $top "Tags and heads: [file tail [pwd]]"
6297 text $top.list -background $bgcolor -foreground $fgcolor \
6298 -selectbackground $selectbgcolor -font $mainfont \
6299 -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6300 -width 30 -height 20 -cursor $maincursor \
6301 -spacing1 1 -spacing3 1 -state disabled
6302 $top.list tag configure highlight -background $selectbgcolor
6303 lappend bglist $top.list
6304 lappend fglist $top.list
6305 scrollbar $top.ysb -command "$top.list yview" -orient vertical
6306 scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6307 grid $top.list $top.ysb -sticky nsew
6308 grid $top.xsb x -sticky ew
6309 frame $top.f
6310 label $top.f.l -text "Filter: " -font $uifont
6311 entry $top.f.e -width 20 -textvariable reflistfilter -font $uifont
6312 set reflistfilter "*"
6313 trace add variable reflistfilter write reflistfilter_change
6314 pack $top.f.e -side right -fill x -expand 1
6315 pack $top.f.l -side left
6316 grid $top.f - -sticky ew -pady 2
6317 button $top.close -command [list destroy $top] -text "Close" \
6318 -font $uifont
6319 grid $top.close -
6320 grid columnconfigure $top 0 -weight 1
6321 grid rowconfigure $top 0 -weight 1
6322 bind $top.list <1> {break}
6323 bind $top.list <B1-Motion> {break}
6324 bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6325 set reflist {}
6326 refill_reflist
6329 proc sel_reflist {w x y} {
6330 global showrefstop reflist headids tagids otherrefids
6332 if {![winfo exists $showrefstop]} return
6333 set l [lindex [split [$w index "@$x,$y"] "."] 0]
6334 set ref [lindex $reflist [expr {$l-1}]]
6335 set n [lindex $ref 0]
6336 switch -- [lindex $ref 1] {
6337 "H" {selbyid $headids($n)}
6338 "T" {selbyid $tagids($n)}
6339 "o" {selbyid $otherrefids($n)}
6341 $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6344 proc unsel_reflist {} {
6345 global showrefstop
6347 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6348 $showrefstop.list tag remove highlight 0.0 end
6351 proc reflistfilter_change {n1 n2 op} {
6352 global reflistfilter
6354 after cancel refill_reflist
6355 after 200 refill_reflist
6358 proc refill_reflist {} {
6359 global reflist reflistfilter showrefstop headids tagids otherrefids
6360 global commitrow curview commitinterest
6362 if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6363 set refs {}
6364 foreach n [array names headids] {
6365 if {[string match $reflistfilter $n]} {
6366 if {[info exists commitrow($curview,$headids($n))]} {
6367 lappend refs [list $n H]
6368 } else {
6369 set commitinterest($headids($n)) {run refill_reflist}
6373 foreach n [array names tagids] {
6374 if {[string match $reflistfilter $n]} {
6375 if {[info exists commitrow($curview,$tagids($n))]} {
6376 lappend refs [list $n T]
6377 } else {
6378 set commitinterest($tagids($n)) {run refill_reflist}
6382 foreach n [array names otherrefids] {
6383 if {[string match $reflistfilter $n]} {
6384 if {[info exists commitrow($curview,$otherrefids($n))]} {
6385 lappend refs [list $n o]
6386 } else {
6387 set commitinterest($otherrefids($n)) {run refill_reflist}
6391 set refs [lsort -index 0 $refs]
6392 if {$refs eq $reflist} return
6394 # Update the contents of $showrefstop.list according to the
6395 # differences between $reflist (old) and $refs (new)
6396 $showrefstop.list conf -state normal
6397 $showrefstop.list insert end "\n"
6398 set i 0
6399 set j 0
6400 while {$i < [llength $reflist] || $j < [llength $refs]} {
6401 if {$i < [llength $reflist]} {
6402 if {$j < [llength $refs]} {
6403 set cmp [string compare [lindex $reflist $i 0] \
6404 [lindex $refs $j 0]]
6405 if {$cmp == 0} {
6406 set cmp [string compare [lindex $reflist $i 1] \
6407 [lindex $refs $j 1]]
6409 } else {
6410 set cmp -1
6412 } else {
6413 set cmp 1
6415 switch -- $cmp {
6416 -1 {
6417 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6418 incr i
6421 incr i
6422 incr j
6425 set l [expr {$j + 1}]
6426 $showrefstop.list image create $l.0 -align baseline \
6427 -image reficon-[lindex $refs $j 1] -padx 2
6428 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6429 incr j
6433 set reflist $refs
6434 # delete last newline
6435 $showrefstop.list delete end-2c end-1c
6436 $showrefstop.list conf -state disabled
6439 # Stuff for finding nearby tags
6440 proc getallcommits {} {
6441 global allcommits allids nbmp nextarc seeds
6443 if {![info exists allcommits]} {
6444 set allids {}
6445 set nbmp 0
6446 set nextarc 0
6447 set allcommits 0
6448 set seeds {}
6451 set cmd [concat | git rev-list --all --parents]
6452 foreach id $seeds {
6453 lappend cmd "^$id"
6455 set fd [open $cmd r]
6456 fconfigure $fd -blocking 0
6457 incr allcommits
6458 nowbusy allcommits
6459 filerun $fd [list getallclines $fd]
6462 # Since most commits have 1 parent and 1 child, we group strings of
6463 # such commits into "arcs" joining branch/merge points (BMPs), which
6464 # are commits that either don't have 1 parent or don't have 1 child.
6466 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6467 # arcout(id) - outgoing arcs for BMP
6468 # arcids(a) - list of IDs on arc including end but not start
6469 # arcstart(a) - BMP ID at start of arc
6470 # arcend(a) - BMP ID at end of arc
6471 # growing(a) - arc a is still growing
6472 # arctags(a) - IDs out of arcids (excluding end) that have tags
6473 # archeads(a) - IDs out of arcids (excluding end) that have heads
6474 # The start of an arc is at the descendent end, so "incoming" means
6475 # coming from descendents, and "outgoing" means going towards ancestors.
6477 proc getallclines {fd} {
6478 global allids allparents allchildren idtags idheads nextarc nbmp
6479 global arcnos arcids arctags arcout arcend arcstart archeads growing
6480 global seeds allcommits
6482 set nid 0
6483 while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6484 set id [lindex $line 0]
6485 if {[info exists allparents($id)]} {
6486 # seen it already
6487 continue
6489 lappend allids $id
6490 set olds [lrange $line 1 end]
6491 set allparents($id) $olds
6492 if {![info exists allchildren($id)]} {
6493 set allchildren($id) {}
6494 set arcnos($id) {}
6495 lappend seeds $id
6496 } else {
6497 set a $arcnos($id)
6498 if {[llength $olds] == 1 && [llength $a] == 1} {
6499 lappend arcids($a) $id
6500 if {[info exists idtags($id)]} {
6501 lappend arctags($a) $id
6503 if {[info exists idheads($id)]} {
6504 lappend archeads($a) $id
6506 if {[info exists allparents($olds)]} {
6507 # seen parent already
6508 if {![info exists arcout($olds)]} {
6509 splitarc $olds
6511 lappend arcids($a) $olds
6512 set arcend($a) $olds
6513 unset growing($a)
6515 lappend allchildren($olds) $id
6516 lappend arcnos($olds) $a
6517 continue
6520 incr nbmp
6521 foreach a $arcnos($id) {
6522 lappend arcids($a) $id
6523 set arcend($a) $id
6524 unset growing($a)
6527 set ao {}
6528 foreach p $olds {
6529 lappend allchildren($p) $id
6530 set a [incr nextarc]
6531 set arcstart($a) $id
6532 set archeads($a) {}
6533 set arctags($a) {}
6534 set archeads($a) {}
6535 set arcids($a) {}
6536 lappend ao $a
6537 set growing($a) 1
6538 if {[info exists allparents($p)]} {
6539 # seen it already, may need to make a new branch
6540 if {![info exists arcout($p)]} {
6541 splitarc $p
6543 lappend arcids($a) $p
6544 set arcend($a) $p
6545 unset growing($a)
6547 lappend arcnos($p) $a
6549 set arcout($id) $ao
6551 if {$nid > 0} {
6552 global cached_dheads cached_dtags cached_atags
6553 catch {unset cached_dheads}
6554 catch {unset cached_dtags}
6555 catch {unset cached_atags}
6557 if {![eof $fd]} {
6558 return [expr {$nid >= 1000? 2: 1}]
6560 close $fd
6561 if {[incr allcommits -1] == 0} {
6562 notbusy allcommits
6564 dispneartags 0
6565 return 0
6568 proc recalcarc {a} {
6569 global arctags archeads arcids idtags idheads
6571 set at {}
6572 set ah {}
6573 foreach id [lrange $arcids($a) 0 end-1] {
6574 if {[info exists idtags($id)]} {
6575 lappend at $id
6577 if {[info exists idheads($id)]} {
6578 lappend ah $id
6581 set arctags($a) $at
6582 set archeads($a) $ah
6585 proc splitarc {p} {
6586 global arcnos arcids nextarc nbmp arctags archeads idtags idheads
6587 global arcstart arcend arcout allparents growing
6589 set a $arcnos($p)
6590 if {[llength $a] != 1} {
6591 puts "oops splitarc called but [llength $a] arcs already"
6592 return
6594 set a [lindex $a 0]
6595 set i [lsearch -exact $arcids($a) $p]
6596 if {$i < 0} {
6597 puts "oops splitarc $p not in arc $a"
6598 return
6600 set na [incr nextarc]
6601 if {[info exists arcend($a)]} {
6602 set arcend($na) $arcend($a)
6603 } else {
6604 set l [lindex $allparents([lindex $arcids($a) end]) 0]
6605 set j [lsearch -exact $arcnos($l) $a]
6606 set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6608 set tail [lrange $arcids($a) [expr {$i+1}] end]
6609 set arcids($a) [lrange $arcids($a) 0 $i]
6610 set arcend($a) $p
6611 set arcstart($na) $p
6612 set arcout($p) $na
6613 set arcids($na) $tail
6614 if {[info exists growing($a)]} {
6615 set growing($na) 1
6616 unset growing($a)
6618 incr nbmp
6620 foreach id $tail {
6621 if {[llength $arcnos($id)] == 1} {
6622 set arcnos($id) $na
6623 } else {
6624 set j [lsearch -exact $arcnos($id) $a]
6625 set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6629 # reconstruct tags and heads lists
6630 if {$arctags($a) ne {} || $archeads($a) ne {}} {
6631 recalcarc $a
6632 recalcarc $na
6633 } else {
6634 set arctags($na) {}
6635 set archeads($na) {}
6639 # Update things for a new commit added that is a child of one
6640 # existing commit. Used when cherry-picking.
6641 proc addnewchild {id p} {
6642 global allids allparents allchildren idtags nextarc nbmp
6643 global arcnos arcids arctags arcout arcend arcstart archeads growing
6644 global seeds allcommits
6646 if {![info exists allcommits]} return
6647 lappend allids $id
6648 set allparents($id) [list $p]
6649 set allchildren($id) {}
6650 set arcnos($id) {}
6651 lappend seeds $id
6652 incr nbmp
6653 lappend allchildren($p) $id
6654 set a [incr nextarc]
6655 set arcstart($a) $id
6656 set archeads($a) {}
6657 set arctags($a) {}
6658 set arcids($a) [list $p]
6659 set arcend($a) $p
6660 if {![info exists arcout($p)]} {
6661 splitarc $p
6663 lappend arcnos($p) $a
6664 set arcout($id) [list $a]
6667 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
6668 # or 0 if neither is true.
6669 proc anc_or_desc {a b} {
6670 global arcout arcstart arcend arcnos cached_isanc
6672 if {$arcnos($a) eq $arcnos($b)} {
6673 # Both are on the same arc(s); either both are the same BMP,
6674 # or if one is not a BMP, the other is also not a BMP or is
6675 # the BMP at end of the arc (and it only has 1 incoming arc).
6676 # Or both can be BMPs with no incoming arcs.
6677 if {$a eq $b || $arcnos($a) eq {}} {
6678 return 0
6680 # assert {[llength $arcnos($a)] == 1}
6681 set arc [lindex $arcnos($a) 0]
6682 set i [lsearch -exact $arcids($arc) $a]
6683 set j [lsearch -exact $arcids($arc) $b]
6684 if {$i < 0 || $i > $j} {
6685 return 1
6686 } else {
6687 return -1
6691 if {![info exists arcout($a)]} {
6692 set arc [lindex $arcnos($a) 0]
6693 if {[info exists arcend($arc)]} {
6694 set aend $arcend($arc)
6695 } else {
6696 set aend {}
6698 set a $arcstart($arc)
6699 } else {
6700 set aend $a
6702 if {![info exists arcout($b)]} {
6703 set arc [lindex $arcnos($b) 0]
6704 if {[info exists arcend($arc)]} {
6705 set bend $arcend($arc)
6706 } else {
6707 set bend {}
6709 set b $arcstart($arc)
6710 } else {
6711 set bend $b
6713 if {$a eq $bend} {
6714 return 1
6716 if {$b eq $aend} {
6717 return -1
6719 if {[info exists cached_isanc($a,$bend)]} {
6720 if {$cached_isanc($a,$bend)} {
6721 return 1
6724 if {[info exists cached_isanc($b,$aend)]} {
6725 if {$cached_isanc($b,$aend)} {
6726 return -1
6728 if {[info exists cached_isanc($a,$bend)]} {
6729 return 0
6733 set todo [list $a $b]
6734 set anc($a) a
6735 set anc($b) b
6736 for {set i 0} {$i < [llength $todo]} {incr i} {
6737 set x [lindex $todo $i]
6738 if {$anc($x) eq {}} {
6739 continue
6741 foreach arc $arcnos($x) {
6742 set xd $arcstart($arc)
6743 if {$xd eq $bend} {
6744 set cached_isanc($a,$bend) 1
6745 set cached_isanc($b,$aend) 0
6746 return 1
6747 } elseif {$xd eq $aend} {
6748 set cached_isanc($b,$aend) 1
6749 set cached_isanc($a,$bend) 0
6750 return -1
6752 if {![info exists anc($xd)]} {
6753 set anc($xd) $anc($x)
6754 lappend todo $xd
6755 } elseif {$anc($xd) ne $anc($x)} {
6756 set anc($xd) {}
6760 set cached_isanc($a,$bend) 0
6761 set cached_isanc($b,$aend) 0
6762 return 0
6765 # This identifies whether $desc has an ancestor that is
6766 # a growing tip of the graph and which is not an ancestor of $anc
6767 # and returns 0 if so and 1 if not.
6768 # If we subsequently discover a tag on such a growing tip, and that
6769 # turns out to be a descendent of $anc (which it could, since we
6770 # don't necessarily see children before parents), then $desc
6771 # isn't a good choice to display as a descendent tag of
6772 # $anc (since it is the descendent of another tag which is
6773 # a descendent of $anc). Similarly, $anc isn't a good choice to
6774 # display as a ancestor tag of $desc.
6776 proc is_certain {desc anc} {
6777 global arcnos arcout arcstart arcend growing problems
6779 set certain {}
6780 if {[llength $arcnos($anc)] == 1} {
6781 # tags on the same arc are certain
6782 if {$arcnos($desc) eq $arcnos($anc)} {
6783 return 1
6785 if {![info exists arcout($anc)]} {
6786 # if $anc is partway along an arc, use the start of the arc instead
6787 set a [lindex $arcnos($anc) 0]
6788 set anc $arcstart($a)
6791 if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
6792 set x $desc
6793 } else {
6794 set a [lindex $arcnos($desc) 0]
6795 set x $arcend($a)
6797 if {$x == $anc} {
6798 return 1
6800 set anclist [list $x]
6801 set dl($x) 1
6802 set nnh 1
6803 set ngrowanc 0
6804 for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
6805 set x [lindex $anclist $i]
6806 if {$dl($x)} {
6807 incr nnh -1
6809 set done($x) 1
6810 foreach a $arcout($x) {
6811 if {[info exists growing($a)]} {
6812 if {![info exists growanc($x)] && $dl($x)} {
6813 set growanc($x) 1
6814 incr ngrowanc
6816 } else {
6817 set y $arcend($a)
6818 if {[info exists dl($y)]} {
6819 if {$dl($y)} {
6820 if {!$dl($x)} {
6821 set dl($y) 0
6822 if {![info exists done($y)]} {
6823 incr nnh -1
6825 if {[info exists growanc($x)]} {
6826 incr ngrowanc -1
6828 set xl [list $y]
6829 for {set k 0} {$k < [llength $xl]} {incr k} {
6830 set z [lindex $xl $k]
6831 foreach c $arcout($z) {
6832 if {[info exists arcend($c)]} {
6833 set v $arcend($c)
6834 if {[info exists dl($v)] && $dl($v)} {
6835 set dl($v) 0
6836 if {![info exists done($v)]} {
6837 incr nnh -1
6839 if {[info exists growanc($v)]} {
6840 incr ngrowanc -1
6842 lappend xl $v
6849 } elseif {$y eq $anc || !$dl($x)} {
6850 set dl($y) 0
6851 lappend anclist $y
6852 } else {
6853 set dl($y) 1
6854 lappend anclist $y
6855 incr nnh
6860 foreach x [array names growanc] {
6861 if {$dl($x)} {
6862 return 0
6864 return 0
6866 return 1
6869 proc validate_arctags {a} {
6870 global arctags idtags
6872 set i -1
6873 set na $arctags($a)
6874 foreach id $arctags($a) {
6875 incr i
6876 if {![info exists idtags($id)]} {
6877 set na [lreplace $na $i $i]
6878 incr i -1
6881 set arctags($a) $na
6884 proc validate_archeads {a} {
6885 global archeads idheads
6887 set i -1
6888 set na $archeads($a)
6889 foreach id $archeads($a) {
6890 incr i
6891 if {![info exists idheads($id)]} {
6892 set na [lreplace $na $i $i]
6893 incr i -1
6896 set archeads($a) $na
6899 # Return the list of IDs that have tags that are descendents of id,
6900 # ignoring IDs that are descendents of IDs already reported.
6901 proc desctags {id} {
6902 global arcnos arcstart arcids arctags idtags allparents
6903 global growing cached_dtags
6905 if {![info exists allparents($id)]} {
6906 return {}
6908 set t1 [clock clicks -milliseconds]
6909 set argid $id
6910 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
6911 # part-way along an arc; check that arc first
6912 set a [lindex $arcnos($id) 0]
6913 if {$arctags($a) ne {}} {
6914 validate_arctags $a
6915 set i [lsearch -exact $arcids($a) $id]
6916 set tid {}
6917 foreach t $arctags($a) {
6918 set j [lsearch -exact $arcids($a) $t]
6919 if {$j >= $i} break
6920 set tid $t
6922 if {$tid ne {}} {
6923 return $tid
6926 set id $arcstart($a)
6927 if {[info exists idtags($id)]} {
6928 return $id
6931 if {[info exists cached_dtags($id)]} {
6932 return $cached_dtags($id)
6935 set origid $id
6936 set todo [list $id]
6937 set queued($id) 1
6938 set nc 1
6939 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
6940 set id [lindex $todo $i]
6941 set done($id) 1
6942 set ta [info exists hastaggedancestor($id)]
6943 if {!$ta} {
6944 incr nc -1
6946 # ignore tags on starting node
6947 if {!$ta && $i > 0} {
6948 if {[info exists idtags($id)]} {
6949 set tagloc($id) $id
6950 set ta 1
6951 } elseif {[info exists cached_dtags($id)]} {
6952 set tagloc($id) $cached_dtags($id)
6953 set ta 1
6956 foreach a $arcnos($id) {
6957 set d $arcstart($a)
6958 if {!$ta && $arctags($a) ne {}} {
6959 validate_arctags $a
6960 if {$arctags($a) ne {}} {
6961 lappend tagloc($id) [lindex $arctags($a) end]
6964 if {$ta || $arctags($a) ne {}} {
6965 set tomark [list $d]
6966 for {set j 0} {$j < [llength $tomark]} {incr j} {
6967 set dd [lindex $tomark $j]
6968 if {![info exists hastaggedancestor($dd)]} {
6969 if {[info exists done($dd)]} {
6970 foreach b $arcnos($dd) {
6971 lappend tomark $arcstart($b)
6973 if {[info exists tagloc($dd)]} {
6974 unset tagloc($dd)
6976 } elseif {[info exists queued($dd)]} {
6977 incr nc -1
6979 set hastaggedancestor($dd) 1
6983 if {![info exists queued($d)]} {
6984 lappend todo $d
6985 set queued($d) 1
6986 if {![info exists hastaggedancestor($d)]} {
6987 incr nc
6992 set tags {}
6993 foreach id [array names tagloc] {
6994 if {![info exists hastaggedancestor($id)]} {
6995 foreach t $tagloc($id) {
6996 if {[lsearch -exact $tags $t] < 0} {
6997 lappend tags $t
7002 set t2 [clock clicks -milliseconds]
7003 set loopix $i
7005 # remove tags that are descendents of other tags
7006 for {set i 0} {$i < [llength $tags]} {incr i} {
7007 set a [lindex $tags $i]
7008 for {set j 0} {$j < $i} {incr j} {
7009 set b [lindex $tags $j]
7010 set r [anc_or_desc $a $b]
7011 if {$r == 1} {
7012 set tags [lreplace $tags $j $j]
7013 incr j -1
7014 incr i -1
7015 } elseif {$r == -1} {
7016 set tags [lreplace $tags $i $i]
7017 incr i -1
7018 break
7023 if {[array names growing] ne {}} {
7024 # graph isn't finished, need to check if any tag could get
7025 # eclipsed by another tag coming later. Simply ignore any
7026 # tags that could later get eclipsed.
7027 set ctags {}
7028 foreach t $tags {
7029 if {[is_certain $t $origid]} {
7030 lappend ctags $t
7033 if {$tags eq $ctags} {
7034 set cached_dtags($origid) $tags
7035 } else {
7036 set tags $ctags
7038 } else {
7039 set cached_dtags($origid) $tags
7041 set t3 [clock clicks -milliseconds]
7042 if {0 && $t3 - $t1 >= 100} {
7043 puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7044 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7046 return $tags
7049 proc anctags {id} {
7050 global arcnos arcids arcout arcend arctags idtags allparents
7051 global growing cached_atags
7053 if {![info exists allparents($id)]} {
7054 return {}
7056 set t1 [clock clicks -milliseconds]
7057 set argid $id
7058 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7059 # part-way along an arc; check that arc first
7060 set a [lindex $arcnos($id) 0]
7061 if {$arctags($a) ne {}} {
7062 validate_arctags $a
7063 set i [lsearch -exact $arcids($a) $id]
7064 foreach t $arctags($a) {
7065 set j [lsearch -exact $arcids($a) $t]
7066 if {$j > $i} {
7067 return $t
7071 if {![info exists arcend($a)]} {
7072 return {}
7074 set id $arcend($a)
7075 if {[info exists idtags($id)]} {
7076 return $id
7079 if {[info exists cached_atags($id)]} {
7080 return $cached_atags($id)
7083 set origid $id
7084 set todo [list $id]
7085 set queued($id) 1
7086 set taglist {}
7087 set nc 1
7088 for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7089 set id [lindex $todo $i]
7090 set done($id) 1
7091 set td [info exists hastaggeddescendent($id)]
7092 if {!$td} {
7093 incr nc -1
7095 # ignore tags on starting node
7096 if {!$td && $i > 0} {
7097 if {[info exists idtags($id)]} {
7098 set tagloc($id) $id
7099 set td 1
7100 } elseif {[info exists cached_atags($id)]} {
7101 set tagloc($id) $cached_atags($id)
7102 set td 1
7105 foreach a $arcout($id) {
7106 if {!$td && $arctags($a) ne {}} {
7107 validate_arctags $a
7108 if {$arctags($a) ne {}} {
7109 lappend tagloc($id) [lindex $arctags($a) 0]
7112 if {![info exists arcend($a)]} continue
7113 set d $arcend($a)
7114 if {$td || $arctags($a) ne {}} {
7115 set tomark [list $d]
7116 for {set j 0} {$j < [llength $tomark]} {incr j} {
7117 set dd [lindex $tomark $j]
7118 if {![info exists hastaggeddescendent($dd)]} {
7119 if {[info exists done($dd)]} {
7120 foreach b $arcout($dd) {
7121 if {[info exists arcend($b)]} {
7122 lappend tomark $arcend($b)
7125 if {[info exists tagloc($dd)]} {
7126 unset tagloc($dd)
7128 } elseif {[info exists queued($dd)]} {
7129 incr nc -1
7131 set hastaggeddescendent($dd) 1
7135 if {![info exists queued($d)]} {
7136 lappend todo $d
7137 set queued($d) 1
7138 if {![info exists hastaggeddescendent($d)]} {
7139 incr nc
7144 set t2 [clock clicks -milliseconds]
7145 set loopix $i
7146 set tags {}
7147 foreach id [array names tagloc] {
7148 if {![info exists hastaggeddescendent($id)]} {
7149 foreach t $tagloc($id) {
7150 if {[lsearch -exact $tags $t] < 0} {
7151 lappend tags $t
7157 # remove tags that are ancestors of other tags
7158 for {set i 0} {$i < [llength $tags]} {incr i} {
7159 set a [lindex $tags $i]
7160 for {set j 0} {$j < $i} {incr j} {
7161 set b [lindex $tags $j]
7162 set r [anc_or_desc $a $b]
7163 if {$r == -1} {
7164 set tags [lreplace $tags $j $j]
7165 incr j -1
7166 incr i -1
7167 } elseif {$r == 1} {
7168 set tags [lreplace $tags $i $i]
7169 incr i -1
7170 break
7175 if {[array names growing] ne {}} {
7176 # graph isn't finished, need to check if any tag could get
7177 # eclipsed by another tag coming later. Simply ignore any
7178 # tags that could later get eclipsed.
7179 set ctags {}
7180 foreach t $tags {
7181 if {[is_certain $origid $t]} {
7182 lappend ctags $t
7185 if {$tags eq $ctags} {
7186 set cached_atags($origid) $tags
7187 } else {
7188 set tags $ctags
7190 } else {
7191 set cached_atags($origid) $tags
7193 set t3 [clock clicks -milliseconds]
7194 if {0 && $t3 - $t1 >= 100} {
7195 puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7196 [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7198 return $tags
7201 # Return the list of IDs that have heads that are descendents of id,
7202 # including id itself if it has a head.
7203 proc descheads {id} {
7204 global arcnos arcstart arcids archeads idheads cached_dheads
7205 global allparents
7207 if {![info exists allparents($id)]} {
7208 return {}
7210 set aret {}
7211 if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7212 # part-way along an arc; check it first
7213 set a [lindex $arcnos($id) 0]
7214 if {$archeads($a) ne {}} {
7215 validate_archeads $a
7216 set i [lsearch -exact $arcids($a) $id]
7217 foreach t $archeads($a) {
7218 set j [lsearch -exact $arcids($a) $t]
7219 if {$j > $i} break
7220 lappend aret $t
7223 set id $arcstart($a)
7225 set origid $id
7226 set todo [list $id]
7227 set seen($id) 1
7228 set ret {}
7229 for {set i 0} {$i < [llength $todo]} {incr i} {
7230 set id [lindex $todo $i]
7231 if {[info exists cached_dheads($id)]} {
7232 set ret [concat $ret $cached_dheads($id)]
7233 } else {
7234 if {[info exists idheads($id)]} {
7235 lappend ret $id
7237 foreach a $arcnos($id) {
7238 if {$archeads($a) ne {}} {
7239 validate_archeads $a
7240 if {$archeads($a) ne {}} {
7241 set ret [concat $ret $archeads($a)]
7244 set d $arcstart($a)
7245 if {![info exists seen($d)]} {
7246 lappend todo $d
7247 set seen($d) 1
7252 set ret [lsort -unique $ret]
7253 set cached_dheads($origid) $ret
7254 return [concat $ret $aret]
7257 proc addedtag {id} {
7258 global arcnos arcout cached_dtags cached_atags
7260 if {![info exists arcnos($id)]} return
7261 if {![info exists arcout($id)]} {
7262 recalcarc [lindex $arcnos($id) 0]
7264 catch {unset cached_dtags}
7265 catch {unset cached_atags}
7268 proc addedhead {hid head} {
7269 global arcnos arcout cached_dheads
7271 if {![info exists arcnos($hid)]} return
7272 if {![info exists arcout($hid)]} {
7273 recalcarc [lindex $arcnos($hid) 0]
7275 catch {unset cached_dheads}
7278 proc removedhead {hid head} {
7279 global cached_dheads
7281 catch {unset cached_dheads}
7284 proc movedhead {hid head} {
7285 global arcnos arcout cached_dheads
7287 if {![info exists arcnos($hid)]} return
7288 if {![info exists arcout($hid)]} {
7289 recalcarc [lindex $arcnos($hid) 0]
7291 catch {unset cached_dheads}
7294 proc changedrefs {} {
7295 global cached_dheads cached_dtags cached_atags
7296 global arctags archeads arcnos arcout idheads idtags
7298 foreach id [concat [array names idheads] [array names idtags]] {
7299 if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7300 set a [lindex $arcnos($id) 0]
7301 if {![info exists donearc($a)]} {
7302 recalcarc $a
7303 set donearc($a) 1
7307 catch {unset cached_dtags}
7308 catch {unset cached_atags}
7309 catch {unset cached_dheads}
7312 proc rereadrefs {} {
7313 global idtags idheads idotherrefs mainhead
7315 set refids [concat [array names idtags] \
7316 [array names idheads] [array names idotherrefs]]
7317 foreach id $refids {
7318 if {![info exists ref($id)]} {
7319 set ref($id) [listrefs $id]
7322 set oldmainhead $mainhead
7323 readrefs
7324 changedrefs
7325 set refids [lsort -unique [concat $refids [array names idtags] \
7326 [array names idheads] [array names idotherrefs]]]
7327 foreach id $refids {
7328 set v [listrefs $id]
7329 if {![info exists ref($id)] || $ref($id) != $v ||
7330 ($id eq $oldmainhead && $id ne $mainhead) ||
7331 ($id eq $mainhead && $id ne $oldmainhead)} {
7332 redrawtags $id
7335 run refill_reflist
7338 proc listrefs {id} {
7339 global idtags idheads idotherrefs
7341 set x {}
7342 if {[info exists idtags($id)]} {
7343 set x $idtags($id)
7345 set y {}
7346 if {[info exists idheads($id)]} {
7347 set y $idheads($id)
7349 set z {}
7350 if {[info exists idotherrefs($id)]} {
7351 set z $idotherrefs($id)
7353 return [list $x $y $z]
7356 proc showtag {tag isnew} {
7357 global ctext tagcontents tagids linknum tagobjid
7359 if {$isnew} {
7360 addtohistory [list showtag $tag 0]
7362 $ctext conf -state normal
7363 clear_ctext
7364 set linknum 0
7365 if {![info exists tagcontents($tag)]} {
7366 catch {
7367 set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7370 if {[info exists tagcontents($tag)]} {
7371 set text $tagcontents($tag)
7372 } else {
7373 set text "Tag: $tag\nId: $tagids($tag)"
7375 appendwithlinks $text {}
7376 $ctext conf -state disabled
7377 init_flist {}
7380 proc doquit {} {
7381 global stopped
7382 set stopped 100
7383 savestuff .
7384 destroy .
7387 proc doprefs {} {
7388 global maxwidth maxgraphpct diffopts
7389 global oldprefs prefstop showneartags showlocalchanges
7390 global bgcolor fgcolor ctext diffcolors selectbgcolor
7391 global uifont tabstop
7393 set top .gitkprefs
7394 set prefstop $top
7395 if {[winfo exists $top]} {
7396 raise $top
7397 return
7399 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7400 set oldprefs($v) [set $v]
7402 toplevel $top
7403 wm title $top "Gitk preferences"
7404 label $top.ldisp -text "Commit list display options"
7405 $top.ldisp configure -font $uifont
7406 grid $top.ldisp - -sticky w -pady 10
7407 label $top.spacer -text " "
7408 label $top.maxwidthl -text "Maximum graph width (lines)" \
7409 -font optionfont
7410 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7411 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7412 label $top.maxpctl -text "Maximum graph width (% of pane)" \
7413 -font optionfont
7414 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7415 grid x $top.maxpctl $top.maxpct -sticky w
7416 frame $top.showlocal
7417 label $top.showlocal.l -text "Show local changes" -font optionfont
7418 checkbutton $top.showlocal.b -variable showlocalchanges
7419 pack $top.showlocal.b $top.showlocal.l -side left
7420 grid x $top.showlocal -sticky w
7422 label $top.ddisp -text "Diff display options"
7423 $top.ddisp configure -font $uifont
7424 grid $top.ddisp - -sticky w -pady 10
7425 label $top.diffoptl -text "Options for diff program" \
7426 -font optionfont
7427 entry $top.diffopt -width 20 -textvariable diffopts
7428 grid x $top.diffoptl $top.diffopt -sticky w
7429 frame $top.ntag
7430 label $top.ntag.l -text "Display nearby tags" -font optionfont
7431 checkbutton $top.ntag.b -variable showneartags
7432 pack $top.ntag.b $top.ntag.l -side left
7433 grid x $top.ntag -sticky w
7434 label $top.tabstopl -text "tabstop" -font optionfont
7435 spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7436 grid x $top.tabstopl $top.tabstop -sticky w
7438 label $top.cdisp -text "Colors: press to choose"
7439 $top.cdisp configure -font $uifont
7440 grid $top.cdisp - -sticky w -pady 10
7441 label $top.bg -padx 40 -relief sunk -background $bgcolor
7442 button $top.bgbut -text "Background" -font optionfont \
7443 -command [list choosecolor bgcolor 0 $top.bg background setbg]
7444 grid x $top.bgbut $top.bg -sticky w
7445 label $top.fg -padx 40 -relief sunk -background $fgcolor
7446 button $top.fgbut -text "Foreground" -font optionfont \
7447 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7448 grid x $top.fgbut $top.fg -sticky w
7449 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7450 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
7451 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
7452 [list $ctext tag conf d0 -foreground]]
7453 grid x $top.diffoldbut $top.diffold -sticky w
7454 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
7455 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
7456 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
7457 [list $ctext tag conf d1 -foreground]]
7458 grid x $top.diffnewbut $top.diffnew -sticky w
7459 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
7460 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
7461 -command [list choosecolor diffcolors 2 $top.hunksep \
7462 "diff hunk header" \
7463 [list $ctext tag conf hunksep -foreground]]
7464 grid x $top.hunksepbut $top.hunksep -sticky w
7465 label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
7466 button $top.selbgbut -text "Select bg" -font optionfont \
7467 -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
7468 grid x $top.selbgbut $top.selbgsep -sticky w
7470 frame $top.buts
7471 button $top.buts.ok -text "OK" -command prefsok -default active
7472 $top.buts.ok configure -font $uifont
7473 button $top.buts.can -text "Cancel" -command prefscan -default normal
7474 $top.buts.can configure -font $uifont
7475 grid $top.buts.ok $top.buts.can
7476 grid columnconfigure $top.buts 0 -weight 1 -uniform a
7477 grid columnconfigure $top.buts 1 -weight 1 -uniform a
7478 grid $top.buts - - -pady 10 -sticky ew
7479 bind $top <Visibility> "focus $top.buts.ok"
7482 proc choosecolor {v vi w x cmd} {
7483 global $v
7485 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
7486 -title "Gitk: choose color for $x"]
7487 if {$c eq {}} return
7488 $w conf -background $c
7489 lset $v $vi $c
7490 eval $cmd $c
7493 proc setselbg {c} {
7494 global bglist cflist
7495 foreach w $bglist {
7496 $w configure -selectbackground $c
7498 $cflist tag configure highlight \
7499 -background [$cflist cget -selectbackground]
7500 allcanvs itemconf secsel -fill $c
7503 proc setbg {c} {
7504 global bglist
7506 foreach w $bglist {
7507 $w conf -background $c
7511 proc setfg {c} {
7512 global fglist canv
7514 foreach w $fglist {
7515 $w conf -foreground $c
7517 allcanvs itemconf text -fill $c
7518 $canv itemconf circle -outline $c
7521 proc prefscan {} {
7522 global maxwidth maxgraphpct diffopts
7523 global oldprefs prefstop showneartags showlocalchanges
7525 foreach v {maxwidth maxgraphpct diffopts showneartags showlocalchanges} {
7526 set $v $oldprefs($v)
7528 catch {destroy $prefstop}
7529 unset prefstop
7532 proc prefsok {} {
7533 global maxwidth maxgraphpct
7534 global oldprefs prefstop showneartags showlocalchanges
7535 global charspc ctext tabstop
7537 catch {destroy $prefstop}
7538 unset prefstop
7539 $ctext configure -tabs "[expr {$tabstop * $charspc}]"
7540 if {$showlocalchanges != $oldprefs(showlocalchanges)} {
7541 if {$showlocalchanges} {
7542 doshowlocalchanges
7543 } else {
7544 dohidelocalchanges
7547 if {$maxwidth != $oldprefs(maxwidth)
7548 || $maxgraphpct != $oldprefs(maxgraphpct)} {
7549 redisplay
7550 } elseif {$showneartags != $oldprefs(showneartags)} {
7551 reselectline
7555 proc formatdate {d} {
7556 global datetimeformat
7557 if {$d ne {}} {
7558 set d [clock format $d -format $datetimeformat]
7560 return $d
7563 # This list of encoding names and aliases is distilled from
7564 # http://www.iana.org/assignments/character-sets.
7565 # Not all of them are supported by Tcl.
7566 set encoding_aliases {
7567 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
7568 ISO646-US US-ASCII us IBM367 cp367 csASCII }
7569 { ISO-10646-UTF-1 csISO10646UTF1 }
7570 { ISO_646.basic:1983 ref csISO646basic1983 }
7571 { INVARIANT csINVARIANT }
7572 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
7573 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
7574 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
7575 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
7576 { NATS-DANO iso-ir-9-1 csNATSDANO }
7577 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
7578 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
7579 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
7580 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
7581 { ISO-2022-KR csISO2022KR }
7582 { EUC-KR csEUCKR }
7583 { ISO-2022-JP csISO2022JP }
7584 { ISO-2022-JP-2 csISO2022JP2 }
7585 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
7586 csISO13JISC6220jp }
7587 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
7588 { IT iso-ir-15 ISO646-IT csISO15Italian }
7589 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
7590 { ES iso-ir-17 ISO646-ES csISO17Spanish }
7591 { greek7-old iso-ir-18 csISO18Greek7Old }
7592 { latin-greek iso-ir-19 csISO19LatinGreek }
7593 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
7594 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
7595 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
7596 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
7597 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
7598 { BS_viewdata iso-ir-47 csISO47BSViewdata }
7599 { INIS iso-ir-49 csISO49INIS }
7600 { INIS-8 iso-ir-50 csISO50INIS8 }
7601 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
7602 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
7603 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
7604 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
7605 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
7606 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
7607 csISO60Norwegian1 }
7608 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
7609 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
7610 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
7611 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
7612 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
7613 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
7614 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
7615 { greek7 iso-ir-88 csISO88Greek7 }
7616 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
7617 { iso-ir-90 csISO90 }
7618 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
7619 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
7620 csISO92JISC62991984b }
7621 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
7622 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
7623 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
7624 csISO95JIS62291984handadd }
7625 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
7626 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
7627 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
7628 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
7629 CP819 csISOLatin1 }
7630 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
7631 { T.61-7bit iso-ir-102 csISO102T617bit }
7632 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
7633 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
7634 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
7635 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
7636 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
7637 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
7638 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
7639 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
7640 arabic csISOLatinArabic }
7641 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
7642 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
7643 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
7644 greek greek8 csISOLatinGreek }
7645 { T.101-G2 iso-ir-128 csISO128T101G2 }
7646 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
7647 csISOLatinHebrew }
7648 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
7649 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
7650 { CSN_369103 iso-ir-139 csISO139CSN369103 }
7651 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
7652 { ISO_6937-2-add iso-ir-142 csISOTextComm }
7653 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
7654 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
7655 csISOLatinCyrillic }
7656 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
7657 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
7658 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
7659 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
7660 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
7661 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
7662 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
7663 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
7664 { ISO_10367-box iso-ir-155 csISO10367Box }
7665 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
7666 { latin-lap lap iso-ir-158 csISO158Lap }
7667 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
7668 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
7669 { us-dk csUSDK }
7670 { dk-us csDKUS }
7671 { JIS_X0201 X0201 csHalfWidthKatakana }
7672 { KSC5636 ISO646-KR csKSC5636 }
7673 { ISO-10646-UCS-2 csUnicode }
7674 { ISO-10646-UCS-4 csUCS4 }
7675 { DEC-MCS dec csDECMCS }
7676 { hp-roman8 roman8 r8 csHPRoman8 }
7677 { macintosh mac csMacintosh }
7678 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
7679 csIBM037 }
7680 { IBM038 EBCDIC-INT cp038 csIBM038 }
7681 { IBM273 CP273 csIBM273 }
7682 { IBM274 EBCDIC-BE CP274 csIBM274 }
7683 { IBM275 EBCDIC-BR cp275 csIBM275 }
7684 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
7685 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
7686 { IBM280 CP280 ebcdic-cp-it csIBM280 }
7687 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
7688 { IBM284 CP284 ebcdic-cp-es csIBM284 }
7689 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
7690 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
7691 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
7692 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
7693 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
7694 { IBM424 cp424 ebcdic-cp-he csIBM424 }
7695 { IBM437 cp437 437 csPC8CodePage437 }
7696 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
7697 { IBM775 cp775 csPC775Baltic }
7698 { IBM850 cp850 850 csPC850Multilingual }
7699 { IBM851 cp851 851 csIBM851 }
7700 { IBM852 cp852 852 csPCp852 }
7701 { IBM855 cp855 855 csIBM855 }
7702 { IBM857 cp857 857 csIBM857 }
7703 { IBM860 cp860 860 csIBM860 }
7704 { IBM861 cp861 861 cp-is csIBM861 }
7705 { IBM862 cp862 862 csPC862LatinHebrew }
7706 { IBM863 cp863 863 csIBM863 }
7707 { IBM864 cp864 csIBM864 }
7708 { IBM865 cp865 865 csIBM865 }
7709 { IBM866 cp866 866 csIBM866 }
7710 { IBM868 CP868 cp-ar csIBM868 }
7711 { IBM869 cp869 869 cp-gr csIBM869 }
7712 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
7713 { IBM871 CP871 ebcdic-cp-is csIBM871 }
7714 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
7715 { IBM891 cp891 csIBM891 }
7716 { IBM903 cp903 csIBM903 }
7717 { IBM904 cp904 904 csIBBM904 }
7718 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
7719 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
7720 { IBM1026 CP1026 csIBM1026 }
7721 { EBCDIC-AT-DE csIBMEBCDICATDE }
7722 { EBCDIC-AT-DE-A csEBCDICATDEA }
7723 { EBCDIC-CA-FR csEBCDICCAFR }
7724 { EBCDIC-DK-NO csEBCDICDKNO }
7725 { EBCDIC-DK-NO-A csEBCDICDKNOA }
7726 { EBCDIC-FI-SE csEBCDICFISE }
7727 { EBCDIC-FI-SE-A csEBCDICFISEA }
7728 { EBCDIC-FR csEBCDICFR }
7729 { EBCDIC-IT csEBCDICIT }
7730 { EBCDIC-PT csEBCDICPT }
7731 { EBCDIC-ES csEBCDICES }
7732 { EBCDIC-ES-A csEBCDICESA }
7733 { EBCDIC-ES-S csEBCDICESS }
7734 { EBCDIC-UK csEBCDICUK }
7735 { EBCDIC-US csEBCDICUS }
7736 { UNKNOWN-8BIT csUnknown8BiT }
7737 { MNEMONIC csMnemonic }
7738 { MNEM csMnem }
7739 { VISCII csVISCII }
7740 { VIQR csVIQR }
7741 { KOI8-R csKOI8R }
7742 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
7743 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
7744 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
7745 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
7746 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
7747 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
7748 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
7749 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
7750 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
7751 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
7752 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
7753 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
7754 { IBM1047 IBM-1047 }
7755 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
7756 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
7757 { UNICODE-1-1 csUnicode11 }
7758 { CESU-8 csCESU-8 }
7759 { BOCU-1 csBOCU-1 }
7760 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
7761 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
7762 l8 }
7763 { ISO-8859-15 ISO_8859-15 Latin-9 }
7764 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
7765 { GBK CP936 MS936 windows-936 }
7766 { JIS_Encoding csJISEncoding }
7767 { Shift_JIS MS_Kanji csShiftJIS }
7768 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
7769 EUC-JP }
7770 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
7771 { ISO-10646-UCS-Basic csUnicodeASCII }
7772 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
7773 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
7774 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
7775 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
7776 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
7777 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
7778 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
7779 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
7780 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
7781 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
7782 { Adobe-Standard-Encoding csAdobeStandardEncoding }
7783 { Ventura-US csVenturaUS }
7784 { Ventura-International csVenturaInternational }
7785 { PC8-Danish-Norwegian csPC8DanishNorwegian }
7786 { PC8-Turkish csPC8Turkish }
7787 { IBM-Symbols csIBMSymbols }
7788 { IBM-Thai csIBMThai }
7789 { HP-Legal csHPLegal }
7790 { HP-Pi-font csHPPiFont }
7791 { HP-Math8 csHPMath8 }
7792 { Adobe-Symbol-Encoding csHPPSMath }
7793 { HP-DeskTop csHPDesktop }
7794 { Ventura-Math csVenturaMath }
7795 { Microsoft-Publishing csMicrosoftPublishing }
7796 { Windows-31J csWindows31J }
7797 { GB2312 csGB2312 }
7798 { Big5 csBig5 }
7801 proc tcl_encoding {enc} {
7802 global encoding_aliases
7803 set names [encoding names]
7804 set lcnames [string tolower $names]
7805 set enc [string tolower $enc]
7806 set i [lsearch -exact $lcnames $enc]
7807 if {$i < 0} {
7808 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
7809 if {[regsub {^iso[-_]} $enc iso encx]} {
7810 set i [lsearch -exact $lcnames $encx]
7813 if {$i < 0} {
7814 foreach l $encoding_aliases {
7815 set ll [string tolower $l]
7816 if {[lsearch -exact $ll $enc] < 0} continue
7817 # look through the aliases for one that tcl knows about
7818 foreach e $ll {
7819 set i [lsearch -exact $lcnames $e]
7820 if {$i < 0} {
7821 if {[regsub {^iso[-_]} $e iso ex]} {
7822 set i [lsearch -exact $lcnames $ex]
7825 if {$i >= 0} break
7827 break
7830 if {$i >= 0} {
7831 return [lindex $names $i]
7833 return {}
7836 # defaults...
7837 set datemode 0
7838 set diffopts "-U 5 -p"
7839 set wrcomcmd "git diff-tree --stdin -p --pretty"
7841 set gitencoding {}
7842 catch {
7843 set gitencoding [exec git config --get i18n.commitencoding]
7845 if {$gitencoding == ""} {
7846 set gitencoding "utf-8"
7848 set tclencoding [tcl_encoding $gitencoding]
7849 if {$tclencoding == {}} {
7850 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
7853 set mainfont {Helvetica 9}
7854 set textfont {Courier 9}
7855 set uifont {Helvetica 9 bold}
7856 set tabstop 8
7857 set findmergefiles 0
7858 set maxgraphpct 50
7859 set maxwidth 16
7860 set revlistorder 0
7861 set fastdate 0
7862 set uparrowlen 7
7863 set downarrowlen 7
7864 set mingaplen 30
7865 set cmitmode "patch"
7866 set wrapcomment "none"
7867 set showneartags 1
7868 set maxrefs 20
7869 set maxlinelen 200
7870 set showlocalchanges 1
7871 set datetimeformat "%Y-%m-%d %H:%M:%S"
7873 set colors {green red blue magenta darkgrey brown orange}
7874 set bgcolor white
7875 set fgcolor black
7876 set diffcolors {red "#00a000" blue}
7877 set diffcontext 3
7878 set selectbgcolor gray85
7880 catch {source ~/.gitk}
7882 font create optionfont -family sans-serif -size -12
7884 # check that we can find a .git directory somewhere...
7885 if {[catch {set gitdir [gitdir]}]} {
7886 show_error {} . "Cannot find a git repository here."
7887 exit 1
7889 if {![file isdirectory $gitdir]} {
7890 show_error {} . "Cannot find the git directory \"$gitdir\"."
7891 exit 1
7894 set revtreeargs {}
7895 set cmdline_files {}
7896 set i 0
7897 foreach arg $argv {
7898 switch -- $arg {
7899 "" { }
7900 "-d" { set datemode 1 }
7901 "--" {
7902 set cmdline_files [lrange $argv [expr {$i + 1}] end]
7903 break
7905 default {
7906 lappend revtreeargs $arg
7909 incr i
7912 if {$i >= [llength $argv] && $revtreeargs ne {}} {
7913 # no -- on command line, but some arguments (other than -d)
7914 if {[catch {
7915 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
7916 set cmdline_files [split $f "\n"]
7917 set n [llength $cmdline_files]
7918 set revtreeargs [lrange $revtreeargs 0 end-$n]
7919 # Unfortunately git rev-parse doesn't produce an error when
7920 # something is both a revision and a filename. To be consistent
7921 # with git log and git rev-list, check revtreeargs for filenames.
7922 foreach arg $revtreeargs {
7923 if {[file exists $arg]} {
7924 show_error {} . "Ambiguous argument '$arg': both revision\
7925 and filename"
7926 exit 1
7929 } err]} {
7930 # unfortunately we get both stdout and stderr in $err,
7931 # so look for "fatal:".
7932 set i [string first "fatal:" $err]
7933 if {$i > 0} {
7934 set err [string range $err [expr {$i + 6}] end]
7936 show_error {} . "Bad arguments to gitk:\n$err"
7937 exit 1
7941 set nullid "0000000000000000000000000000000000000000"
7942 set nullid2 "0000000000000000000000000000000000000001"
7945 set runq {}
7946 set history {}
7947 set historyindex 0
7948 set fh_serial 0
7949 set nhl_names {}
7950 set highlight_paths {}
7951 set searchdirn -forwards
7952 set boldrows {}
7953 set boldnamerows {}
7954 set diffelide {0 0}
7955 set markingmatches 0
7957 set optim_delay 16
7959 set nextviewnum 1
7960 set curview 0
7961 set selectedview 0
7962 set selectedhlview None
7963 set viewfiles(0) {}
7964 set viewperm(0) 0
7965 set viewargs(0) {}
7967 set cmdlineok 0
7968 set stopped 0
7969 set stuffsaved 0
7970 set patchnum 0
7971 set lookingforhead 0
7972 set localirow -1
7973 set localfrow -1
7974 set lserial 0
7975 setcoords
7976 makewindow
7977 # wait for the window to become visible
7978 tkwait visibility .
7979 wm title . "[file tail $argv0]: [file tail [pwd]]"
7980 readrefs
7982 if {$cmdline_files ne {} || $revtreeargs ne {}} {
7983 # create a view for the files/dirs specified on the command line
7984 set curview 1
7985 set selectedview 1
7986 set nextviewnum 2
7987 set viewname(1) "Command line"
7988 set viewfiles(1) $cmdline_files
7989 set viewargs(1) $revtreeargs
7990 set viewperm(1) 0
7991 addviewmenu 1
7992 .bar.view entryconf Edit* -state normal
7993 .bar.view entryconf Delete* -state normal
7996 if {[info exists permviews]} {
7997 foreach v $permviews {
7998 set n $nextviewnum
7999 incr nextviewnum
8000 set viewname($n) [lindex $v 0]
8001 set viewfiles($n) [lindex $v 1]
8002 set viewargs($n) [lindex $v 2]
8003 set viewperm($n) 1
8004 addviewmenu $n
8007 getcommits