git-blame: Add Emacs Lisp file headers and GNU GPL boilerplate
[git/dscho.git] / gitk
blob1c36235bff8c127faa60eca051f15f35fb14f484
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return [exec git rev-parse --git-dir]
19 proc start_rev_list {view} {
20 global startmsecs nextupdate
21 global commfd leftover tclencoding datemode
22 global viewargs viewfiles commitidx
24 set startmsecs [clock clicks -milliseconds]
25 set nextupdate [expr {$startmsecs + 100}]
26 set commitidx($view) 0
27 set args $viewargs($view)
28 if {$viewfiles($view) ne {}} {
29 set args [concat $args "--" $viewfiles($view)]
31 set order "--topo-order"
32 if {$datemode} {
33 set order "--date-order"
35 if {[catch {
36 set fd [open [concat | git rev-list --header $order \
37 --parents --boundary --default HEAD $args] r]
38 } err]} {
39 puts stderr "Error executing git rev-list: $err"
40 exit 1
42 set commfd($view) $fd
43 set leftover($view) {}
44 fconfigure $fd -blocking 0 -translation lf
45 if {$tclencoding != {}} {
46 fconfigure $fd -encoding $tclencoding
48 fileevent $fd readable [list getcommitlines $fd $view]
49 nowbusy $view
52 proc stop_rev_list {} {
53 global commfd curview
55 if {![info exists commfd($curview)]} return
56 set fd $commfd($curview)
57 catch {
58 set pid [pid $fd]
59 exec kill $pid
61 catch {close $fd}
62 unset commfd($curview)
65 proc getcommits {} {
66 global phase canv mainfont curview
68 set phase getcommits
69 initlayout
70 start_rev_list $curview
71 show_status "Reading commits..."
74 proc getcommitlines {fd view} {
75 global commitlisted nextupdate
76 global leftover commfd
77 global displayorder commitidx commitrow commitdata
78 global parentlist childlist children curview hlview
79 global vparentlist vchildlist vdisporder vcmitlisted
81 set stuff [read $fd 500000]
82 if {$stuff == {}} {
83 if {![eof $fd]} return
84 global viewname
85 unset commfd($view)
86 notbusy $view
87 # set it blocking so we wait for the process to terminate
88 fconfigure $fd -blocking 1
89 if {[catch {close $fd} err]} {
90 set fv {}
91 if {$view != $curview} {
92 set fv " for the \"$viewname($view)\" view"
94 if {[string range $err 0 4] == "usage"} {
95 set err "Gitk: error reading commits$fv:\
96 bad arguments to git rev-list."
97 if {$viewname($view) eq "Command line"} {
98 append err \
99 " (Note: arguments to gitk are passed to git rev-list\
100 to allow selection of commits to be displayed.)"
102 } else {
103 set err "Error reading commits$fv: $err"
105 error_popup $err
107 if {$view == $curview} {
108 after idle finishcommits
110 return
112 set start 0
113 set gotsome 0
114 while 1 {
115 set i [string first "\0" $stuff $start]
116 if {$i < 0} {
117 append leftover($view) [string range $stuff $start end]
118 break
120 if {$start == 0} {
121 set cmit $leftover($view)
122 append cmit [string range $stuff 0 [expr {$i - 1}]]
123 set leftover($view) {}
124 } else {
125 set cmit [string range $stuff $start [expr {$i - 1}]]
127 set start [expr {$i + 1}]
128 set j [string first "\n" $cmit]
129 set ok 0
130 set listed 1
131 if {$j >= 0} {
132 set ids [string range $cmit 0 [expr {$j - 1}]]
133 if {[string range $ids 0 0] == "-"} {
134 set listed 0
135 set ids [string range $ids 1 end]
137 set ok 1
138 foreach id $ids {
139 if {[string length $id] != 40} {
140 set ok 0
141 break
145 if {!$ok} {
146 set shortcmit $cmit
147 if {[string length $shortcmit] > 80} {
148 set shortcmit "[string range $shortcmit 0 80]..."
150 error_popup "Can't parse git rev-list output: {$shortcmit}"
151 exit 1
153 set id [lindex $ids 0]
154 if {$listed} {
155 set olds [lrange $ids 1 end]
156 set i 0
157 foreach p $olds {
158 if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
159 lappend children($view,$p) $id
161 incr i
163 } else {
164 set olds {}
166 if {![info exists children($view,$id)]} {
167 set children($view,$id) {}
169 set commitdata($id) [string range $cmit [expr {$j + 1}] end]
170 set commitrow($view,$id) $commitidx($view)
171 incr commitidx($view)
172 if {$view == $curview} {
173 lappend parentlist $olds
174 lappend childlist $children($view,$id)
175 lappend displayorder $id
176 lappend commitlisted $listed
177 } else {
178 lappend vparentlist($view) $olds
179 lappend vchildlist($view) $children($view,$id)
180 lappend vdisporder($view) $id
181 lappend vcmitlisted($view) $listed
183 set gotsome 1
185 if {$gotsome} {
186 if {$view == $curview} {
187 while {[layoutmore $nextupdate]} doupdate
188 } elseif {[info exists hlview] && $view == $hlview} {
189 vhighlightmore
192 if {[clock clicks -milliseconds] >= $nextupdate} {
193 doupdate
197 proc doupdate {} {
198 global commfd nextupdate numcommits
200 foreach v [array names commfd] {
201 fileevent $commfd($v) readable {}
203 update
204 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
205 foreach v [array names commfd] {
206 set fd $commfd($v)
207 fileevent $fd readable [list getcommitlines $fd $v]
211 proc readcommit {id} {
212 if {[catch {set contents [exec git cat-file commit $id]}]} return
213 parsecommit $id $contents 0
216 proc updatecommits {} {
217 global viewdata curview phase displayorder
218 global children commitrow selectedline thickerline
220 if {$phase ne {}} {
221 stop_rev_list
222 set phase {}
224 set n $curview
225 foreach id $displayorder {
226 catch {unset children($n,$id)}
227 catch {unset commitrow($n,$id)}
229 set curview -1
230 catch {unset selectedline}
231 catch {unset thickerline}
232 catch {unset viewdata($n)}
233 discardallcommits
234 readrefs
235 showview $n
238 proc parsecommit {id contents listed} {
239 global commitinfo cdate
241 set inhdr 1
242 set comment {}
243 set headline {}
244 set auname {}
245 set audate {}
246 set comname {}
247 set comdate {}
248 set hdrend [string first "\n\n" $contents]
249 if {$hdrend < 0} {
250 # should never happen...
251 set hdrend [string length $contents]
253 set header [string range $contents 0 [expr {$hdrend - 1}]]
254 set comment [string range $contents [expr {$hdrend + 2}] end]
255 foreach line [split $header "\n"] {
256 set tag [lindex $line 0]
257 if {$tag == "author"} {
258 set audate [lindex $line end-1]
259 set auname [lrange $line 1 end-2]
260 } elseif {$tag == "committer"} {
261 set comdate [lindex $line end-1]
262 set comname [lrange $line 1 end-2]
265 set headline {}
266 # take the first line of the comment as the headline
267 set i [string first "\n" $comment]
268 if {$i >= 0} {
269 set headline [string trim [string range $comment 0 $i]]
270 } else {
271 set headline $comment
273 if {!$listed} {
274 # git rev-list indents the comment by 4 spaces;
275 # if we got this via git cat-file, add the indentation
276 set newcomment {}
277 foreach line [split $comment "\n"] {
278 append newcomment " "
279 append newcomment $line
280 append newcomment "\n"
282 set comment $newcomment
284 if {$comdate != {}} {
285 set cdate($id) $comdate
287 set commitinfo($id) [list $headline $auname $audate \
288 $comname $comdate $comment]
291 proc getcommit {id} {
292 global commitdata commitinfo
294 if {[info exists commitdata($id)]} {
295 parsecommit $id $commitdata($id) 1
296 } else {
297 readcommit $id
298 if {![info exists commitinfo($id)]} {
299 set commitinfo($id) {"No commit information available"}
302 return 1
305 proc readrefs {} {
306 global tagids idtags headids idheads tagcontents
307 global otherrefids idotherrefs mainhead
309 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
310 catch {unset $v}
312 set refd [open [list | git show-ref] r]
313 while {0 <= [set n [gets $refd line]]} {
314 if {![regexp {^([0-9a-f]{40}) refs/([^^]*)$} $line \
315 match id path]} {
316 continue
318 if {[regexp {^remotes/.*/HEAD$} $path match]} {
319 continue
321 if {![regexp {^(tags|heads)/(.*)$} $path match type name]} {
322 set type others
323 set name $path
325 if {[regexp {^remotes/} $path match]} {
326 set type heads
328 if {$type == "tags"} {
329 set tagids($name) $id
330 lappend idtags($id) $name
331 set obj {}
332 set type {}
333 set tag {}
334 catch {
335 set commit [exec git rev-parse "$id^0"]
336 if {$commit != $id} {
337 set tagids($name) $commit
338 lappend idtags($commit) $name
341 catch {
342 set tagcontents($name) [exec git cat-file tag $id]
344 } elseif { $type == "heads" } {
345 set headids($name) $id
346 lappend idheads($id) $name
347 } else {
348 set otherrefids($name) $id
349 lappend idotherrefs($id) $name
352 close $refd
353 set mainhead {}
354 catch {
355 set thehead [exec git symbolic-ref HEAD]
356 if {[string match "refs/heads/*" $thehead]} {
357 set mainhead [string range $thehead 11 end]
362 proc show_error {w top msg} {
363 message $w.m -text $msg -justify center -aspect 400
364 pack $w.m -side top -fill x -padx 20 -pady 20
365 button $w.ok -text OK -command "destroy $top"
366 pack $w.ok -side bottom -fill x
367 bind $top <Visibility> "grab $top; focus $top"
368 bind $top <Key-Return> "destroy $top"
369 tkwait window $top
372 proc error_popup msg {
373 set w .error
374 toplevel $w
375 wm transient $w .
376 show_error $w $w $msg
379 proc confirm_popup msg {
380 global confirm_ok
381 set confirm_ok 0
382 set w .confirm
383 toplevel $w
384 wm transient $w .
385 message $w.m -text $msg -justify center -aspect 400
386 pack $w.m -side top -fill x -padx 20 -pady 20
387 button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
388 pack $w.ok -side left -fill x
389 button $w.cancel -text Cancel -command "destroy $w"
390 pack $w.cancel -side right -fill x
391 bind $w <Visibility> "grab $w; focus $w"
392 tkwait window $w
393 return $confirm_ok
396 proc makewindow {} {
397 global canv canv2 canv3 linespc charspc ctext cflist
398 global textfont mainfont uifont
399 global findtype findtypemenu findloc findstring fstring geometry
400 global entries sha1entry sha1string sha1but
401 global maincursor textcursor curtextcursor
402 global rowctxmenu mergemax wrapcomment
403 global highlight_files gdttype
404 global searchstring sstring
405 global bgcolor fgcolor bglist fglist diffcolors
406 global headctxmenu
408 menu .bar
409 .bar add cascade -label "File" -menu .bar.file
410 .bar configure -font $uifont
411 menu .bar.file
412 .bar.file add command -label "Update" -command updatecommits
413 .bar.file add command -label "Reread references" -command rereadrefs
414 .bar.file add command -label "Quit" -command doquit
415 .bar.file configure -font $uifont
416 menu .bar.edit
417 .bar add cascade -label "Edit" -menu .bar.edit
418 .bar.edit add command -label "Preferences" -command doprefs
419 .bar.edit configure -font $uifont
421 menu .bar.view -font $uifont
422 .bar add cascade -label "View" -menu .bar.view
423 .bar.view add command -label "New view..." -command {newview 0}
424 .bar.view add command -label "Edit view..." -command editview \
425 -state disabled
426 .bar.view add command -label "Delete view" -command delview -state disabled
427 .bar.view add separator
428 .bar.view add radiobutton -label "All files" -command {showview 0} \
429 -variable selectedview -value 0
431 menu .bar.help
432 .bar add cascade -label "Help" -menu .bar.help
433 .bar.help add command -label "About gitk" -command about
434 .bar.help add command -label "Key bindings" -command keys
435 .bar.help configure -font $uifont
436 . configure -menu .bar
438 # the gui has upper and lower half, parts of a paned window.
439 panedwindow .ctop -orient vertical
441 # possibly use assumed geometry
442 if {![info exists geometry(topheight)]} {
443 set geometry(topheight) [expr {15 * $linespc}]
444 set geometry(topwidth) [expr {80 * $charspc}]
445 set geometry(botheight) [expr {15 * $linespc}]
446 set geometry(botwidth) [expr {50 * $charspc}]
447 set geometry(canv) [expr {40 * $charspc}]
448 set geometry(canv2) [expr {20 * $charspc}]
449 set geometry(canv3) [expr {20 * $charspc}]
452 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
453 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
454 frame .tf.histframe
455 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
457 # create three canvases
458 set cscroll .tf.histframe.csb
459 set canv .tf.histframe.pwclist.canv
460 canvas $canv -width $geometry(canv) \
461 -background $bgcolor -bd 0 \
462 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
463 .tf.histframe.pwclist add $canv
464 set canv2 .tf.histframe.pwclist.canv2
465 canvas $canv2 -width $geometry(canv2) \
466 -background $bgcolor -bd 0 -yscrollincr $linespc
467 .tf.histframe.pwclist add $canv2
468 set canv3 .tf.histframe.pwclist.canv3
469 canvas $canv3 -width $geometry(canv3) \
470 -background $bgcolor -bd 0 -yscrollincr $linespc
471 .tf.histframe.pwclist add $canv3
473 # a scroll bar to rule them
474 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
475 pack $cscroll -side right -fill y
476 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
477 lappend bglist $canv $canv2 $canv3
478 pack .tf.histframe.pwclist -fill both -expand 1 -side left
480 # we have two button bars at bottom of top frame. Bar 1
481 frame .tf.bar
482 frame .tf.lbar -height 15
484 set sha1entry .tf.bar.sha1
485 set entries $sha1entry
486 set sha1but .tf.bar.sha1label
487 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
488 -command gotocommit -width 8 -font $uifont
489 $sha1but conf -disabledforeground [$sha1but cget -foreground]
490 pack .tf.bar.sha1label -side left
491 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
492 trace add variable sha1string write sha1change
493 pack $sha1entry -side left -pady 2
495 image create bitmap bm-left -data {
496 #define left_width 16
497 #define left_height 16
498 static unsigned char left_bits[] = {
499 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
500 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
501 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
503 image create bitmap bm-right -data {
504 #define right_width 16
505 #define right_height 16
506 static unsigned char right_bits[] = {
507 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
508 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
509 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
511 button .tf.bar.leftbut -image bm-left -command goback \
512 -state disabled -width 26
513 pack .tf.bar.leftbut -side left -fill y
514 button .tf.bar.rightbut -image bm-right -command goforw \
515 -state disabled -width 26
516 pack .tf.bar.rightbut -side left -fill y
518 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
519 pack .tf.bar.findbut -side left
520 set findstring {}
521 set fstring .tf.bar.findstring
522 lappend entries $fstring
523 entry $fstring -width 30 -font $textfont -textvariable findstring
524 trace add variable findstring write find_change
525 pack $fstring -side left -expand 1 -fill x -in .tf.bar
526 set findtype Exact
527 set findtypemenu [tk_optionMenu .tf.bar.findtype \
528 findtype Exact IgnCase Regexp]
529 trace add variable findtype write find_change
530 .tf.bar.findtype configure -font $uifont
531 .tf.bar.findtype.menu configure -font $uifont
532 set findloc "All fields"
533 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
534 Comments Author Committer
535 trace add variable findloc write find_change
536 .tf.bar.findloc configure -font $uifont
537 .tf.bar.findloc.menu configure -font $uifont
538 pack .tf.bar.findloc -side right
539 pack .tf.bar.findtype -side right
541 # build up the bottom bar of upper window
542 label .tf.lbar.flabel -text "Highlight: Commits " \
543 -font $uifont
544 pack .tf.lbar.flabel -side left -fill y
545 set gdttype "touching paths:"
546 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
547 "adding/removing string:"]
548 trace add variable gdttype write hfiles_change
549 $gm conf -font $uifont
550 .tf.lbar.gdttype conf -font $uifont
551 pack .tf.lbar.gdttype -side left -fill y
552 entry .tf.lbar.fent -width 25 -font $textfont \
553 -textvariable highlight_files
554 trace add variable highlight_files write hfiles_change
555 lappend entries .tf.lbar.fent
556 pack .tf.lbar.fent -side left -fill x -expand 1
557 label .tf.lbar.vlabel -text " OR in view" -font $uifont
558 pack .tf.lbar.vlabel -side left -fill y
559 global viewhlmenu selectedhlview
560 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
561 $viewhlmenu entryconf None -command delvhighlight
562 $viewhlmenu conf -font $uifont
563 .tf.lbar.vhl conf -font $uifont
564 pack .tf.lbar.vhl -side left -fill y
565 label .tf.lbar.rlabel -text " OR " -font $uifont
566 pack .tf.lbar.rlabel -side left -fill y
567 global highlight_related
568 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
569 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
570 $m conf -font $uifont
571 .tf.lbar.relm conf -font $uifont
572 trace add variable highlight_related write vrel_change
573 pack .tf.lbar.relm -side left -fill y
575 # Finish putting the upper half of the viewer together
576 pack .tf.lbar -in .tf -side bottom -fill x
577 pack .tf.bar -in .tf -side bottom -fill x
578 pack .tf.histframe -fill both -side top -expand 1
579 .ctop add .tf
581 # now build up the bottom
582 panedwindow .pwbottom -orient horizontal
584 # lower left, a text box over search bar, scroll bar to the right
585 # if we know window height, then that will set the lower text height, otherwise
586 # we set lower text height which will drive window height
587 if {[info exists geometry(main)]} {
588 frame .bleft -width $geometry(botwidth)
589 } else {
590 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
592 frame .bleft.top
594 button .bleft.top.search -text "Search" -command dosearch \
595 -font $uifont
596 pack .bleft.top.search -side left -padx 5
597 set sstring .bleft.top.sstring
598 entry $sstring -width 20 -font $textfont -textvariable searchstring
599 lappend entries $sstring
600 trace add variable searchstring write incrsearch
601 pack $sstring -side left -expand 1 -fill x
602 set ctext .bleft.ctext
603 text $ctext -background $bgcolor -foreground $fgcolor \
604 -state disabled -font $textfont \
605 -yscrollcommand scrolltext -wrap none
606 scrollbar .bleft.sb -command "$ctext yview"
607 pack .bleft.top -side top -fill x
608 pack .bleft.sb -side right -fill y
609 pack $ctext -side left -fill both -expand 1
610 lappend bglist $ctext
611 lappend fglist $ctext
613 $ctext tag conf comment -wrap $wrapcomment
614 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
615 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
616 $ctext tag conf d0 -fore [lindex $diffcolors 0]
617 $ctext tag conf d1 -fore [lindex $diffcolors 1]
618 $ctext tag conf m0 -fore red
619 $ctext tag conf m1 -fore blue
620 $ctext tag conf m2 -fore green
621 $ctext tag conf m3 -fore purple
622 $ctext tag conf m4 -fore brown
623 $ctext tag conf m5 -fore "#009090"
624 $ctext tag conf m6 -fore magenta
625 $ctext tag conf m7 -fore "#808000"
626 $ctext tag conf m8 -fore "#009000"
627 $ctext tag conf m9 -fore "#ff0080"
628 $ctext tag conf m10 -fore cyan
629 $ctext tag conf m11 -fore "#b07070"
630 $ctext tag conf m12 -fore "#70b0f0"
631 $ctext tag conf m13 -fore "#70f0b0"
632 $ctext tag conf m14 -fore "#f0b070"
633 $ctext tag conf m15 -fore "#ff70b0"
634 $ctext tag conf mmax -fore darkgrey
635 set mergemax 16
636 $ctext tag conf mresult -font [concat $textfont bold]
637 $ctext tag conf msep -font [concat $textfont bold]
638 $ctext tag conf found -back yellow
640 .pwbottom add .bleft
642 # lower right
643 frame .bright
644 frame .bright.mode
645 radiobutton .bright.mode.patch -text "Patch" \
646 -command reselectline -variable cmitmode -value "patch"
647 radiobutton .bright.mode.tree -text "Tree" \
648 -command reselectline -variable cmitmode -value "tree"
649 grid .bright.mode.patch .bright.mode.tree -sticky ew
650 pack .bright.mode -side top -fill x
651 set cflist .bright.cfiles
652 set indent [font measure $mainfont "nn"]
653 text $cflist \
654 -background $bgcolor -foreground $fgcolor \
655 -font $mainfont \
656 -tabs [list $indent [expr {2 * $indent}]] \
657 -yscrollcommand ".bright.sb set" \
658 -cursor [. cget -cursor] \
659 -spacing1 1 -spacing3 1
660 lappend bglist $cflist
661 lappend fglist $cflist
662 scrollbar .bright.sb -command "$cflist yview"
663 pack .bright.sb -side right -fill y
664 pack $cflist -side left -fill both -expand 1
665 $cflist tag configure highlight \
666 -background [$cflist cget -selectbackground]
667 $cflist tag configure bold -font [concat $mainfont bold]
669 .pwbottom add .bright
670 .ctop add .pwbottom
672 # restore window position if known
673 if {[info exists geometry(main)]} {
674 wm geometry . "$geometry(main)"
677 bind .pwbottom <Configure> {resizecdetpanes %W %w}
678 pack .ctop -fill both -expand 1
679 bindall <1> {selcanvline %W %x %y}
680 #bindall <B1-Motion> {selcanvline %W %x %y}
681 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
682 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
683 bindall <2> "canvscan mark %W %x %y"
684 bindall <B2-Motion> "canvscan dragto %W %x %y"
685 bindkey <Home> selfirstline
686 bindkey <End> sellastline
687 bind . <Key-Up> "selnextline -1"
688 bind . <Key-Down> "selnextline 1"
689 bind . <Shift-Key-Up> "next_highlight -1"
690 bind . <Shift-Key-Down> "next_highlight 1"
691 bindkey <Key-Right> "goforw"
692 bindkey <Key-Left> "goback"
693 bind . <Key-Prior> "selnextpage -1"
694 bind . <Key-Next> "selnextpage 1"
695 bind . <Control-Home> "allcanvs yview moveto 0.0"
696 bind . <Control-End> "allcanvs yview moveto 1.0"
697 bind . <Control-Key-Up> "allcanvs yview scroll -1 units"
698 bind . <Control-Key-Down> "allcanvs yview scroll 1 units"
699 bind . <Control-Key-Prior> "allcanvs yview scroll -1 pages"
700 bind . <Control-Key-Next> "allcanvs yview scroll 1 pages"
701 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
702 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
703 bindkey <Key-space> "$ctext yview scroll 1 pages"
704 bindkey p "selnextline -1"
705 bindkey n "selnextline 1"
706 bindkey z "goback"
707 bindkey x "goforw"
708 bindkey i "selnextline -1"
709 bindkey k "selnextline 1"
710 bindkey j "goback"
711 bindkey l "goforw"
712 bindkey b "$ctext yview scroll -1 pages"
713 bindkey d "$ctext yview scroll 18 units"
714 bindkey u "$ctext yview scroll -18 units"
715 bindkey / {findnext 1}
716 bindkey <Key-Return> {findnext 0}
717 bindkey ? findprev
718 bindkey f nextfile
719 bind . <Control-q> doquit
720 bind . <Control-f> dofind
721 bind . <Control-g> {findnext 0}
722 bind . <Control-r> dosearchback
723 bind . <Control-s> dosearch
724 bind . <Control-equal> {incrfont 1}
725 bind . <Control-KP_Add> {incrfont 1}
726 bind . <Control-minus> {incrfont -1}
727 bind . <Control-KP_Subtract> {incrfont -1}
728 bind . <Destroy> {savestuff %W}
729 bind . <Button-1> "click %W"
730 bind $fstring <Key-Return> dofind
731 bind $sha1entry <Key-Return> gotocommit
732 bind $sha1entry <<PasteSelection>> clearsha1
733 bind $cflist <1> {sel_flist %W %x %y; break}
734 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
735 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
737 set maincursor [. cget -cursor]
738 set textcursor [$ctext cget -cursor]
739 set curtextcursor $textcursor
741 set rowctxmenu .rowctxmenu
742 menu $rowctxmenu -tearoff 0
743 $rowctxmenu add command -label "Diff this -> selected" \
744 -command {diffvssel 0}
745 $rowctxmenu add command -label "Diff selected -> this" \
746 -command {diffvssel 1}
747 $rowctxmenu add command -label "Make patch" -command mkpatch
748 $rowctxmenu add command -label "Create tag" -command mktag
749 $rowctxmenu add command -label "Write commit to file" -command writecommit
750 $rowctxmenu add command -label "Create new branch" -command mkbranch
751 $rowctxmenu add command -label "Cherry-pick this commit" \
752 -command cherrypick
754 set headctxmenu .headctxmenu
755 menu $headctxmenu -tearoff 0
756 $headctxmenu add command -label "Check out this branch" \
757 -command cobranch
758 $headctxmenu add command -label "Remove this branch" \
759 -command rmbranch
762 # mouse-2 makes all windows scan vertically, but only the one
763 # the cursor is in scans horizontally
764 proc canvscan {op w x y} {
765 global canv canv2 canv3
766 foreach c [list $canv $canv2 $canv3] {
767 if {$c == $w} {
768 $c scan $op $x $y
769 } else {
770 $c scan $op 0 $y
775 proc scrollcanv {cscroll f0 f1} {
776 $cscroll set $f0 $f1
777 drawfrac $f0 $f1
778 flushhighlights
781 # when we make a key binding for the toplevel, make sure
782 # it doesn't get triggered when that key is pressed in the
783 # find string entry widget.
784 proc bindkey {ev script} {
785 global entries
786 bind . $ev $script
787 set escript [bind Entry $ev]
788 if {$escript == {}} {
789 set escript [bind Entry <Key>]
791 foreach e $entries {
792 bind $e $ev "$escript; break"
796 # set the focus back to the toplevel for any click outside
797 # the entry widgets
798 proc click {w} {
799 global entries
800 foreach e $entries {
801 if {$w == $e} return
803 focus .
806 proc savestuff {w} {
807 global canv canv2 canv3 ctext cflist mainfont textfont uifont
808 global stuffsaved findmergefiles maxgraphpct
809 global maxwidth showneartags
810 global viewname viewfiles viewargs viewperm nextviewnum
811 global cmitmode wrapcomment
812 global colors bgcolor fgcolor diffcolors
814 if {$stuffsaved} return
815 if {![winfo viewable .]} return
816 catch {
817 set f [open "~/.gitk-new" w]
818 puts $f [list set mainfont $mainfont]
819 puts $f [list set textfont $textfont]
820 puts $f [list set uifont $uifont]
821 puts $f [list set findmergefiles $findmergefiles]
822 puts $f [list set maxgraphpct $maxgraphpct]
823 puts $f [list set maxwidth $maxwidth]
824 puts $f [list set cmitmode $cmitmode]
825 puts $f [list set wrapcomment $wrapcomment]
826 puts $f [list set showneartags $showneartags]
827 puts $f [list set bgcolor $bgcolor]
828 puts $f [list set fgcolor $fgcolor]
829 puts $f [list set colors $colors]
830 puts $f [list set diffcolors $diffcolors]
832 puts $f "set geometry(main) [winfo geometry .]"
833 puts $f "set geometry(topwidth) [winfo width .tf]"
834 puts $f "set geometry(topheight) [winfo height .tf]"
835 puts $f "set geometry(canv) [expr {[winfo width $canv]-0}]"
836 puts $f "set geometry(canv2) [expr {[winfo width $canv2]-0}]"
837 puts $f "set geometry(canv3) [expr {[winfo width $canv3]-0}]"
838 puts $f "set geometry(botwidth) [winfo width .bleft]"
839 puts $f "set geometry(botheight) [winfo height .bleft]"
841 puts -nonewline $f "set permviews {"
842 for {set v 0} {$v < $nextviewnum} {incr v} {
843 if {$viewperm($v)} {
844 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
847 puts $f "}"
848 close $f
849 file rename -force "~/.gitk-new" "~/.gitk"
851 set stuffsaved 1
854 proc resizeclistpanes {win w} {
855 global oldwidth
856 if {[info exists oldwidth($win)]} {
857 set s0 [$win sash coord 0]
858 set s1 [$win sash coord 1]
859 if {$w < 60} {
860 set sash0 [expr {int($w/2 - 2)}]
861 set sash1 [expr {int($w*5/6 - 2)}]
862 } else {
863 set factor [expr {1.0 * $w / $oldwidth($win)}]
864 set sash0 [expr {int($factor * [lindex $s0 0])}]
865 set sash1 [expr {int($factor * [lindex $s1 0])}]
866 if {$sash0 < 30} {
867 set sash0 30
869 if {$sash1 < $sash0 + 20} {
870 set sash1 [expr {$sash0 + 20}]
872 if {$sash1 > $w - 10} {
873 set sash1 [expr {$w - 10}]
874 if {$sash0 > $sash1 - 20} {
875 set sash0 [expr {$sash1 - 20}]
879 $win sash place 0 $sash0 [lindex $s0 1]
880 $win sash place 1 $sash1 [lindex $s1 1]
882 set oldwidth($win) $w
885 proc resizecdetpanes {win w} {
886 global oldwidth
887 if {[info exists oldwidth($win)]} {
888 set s0 [$win sash coord 0]
889 if {$w < 60} {
890 set sash0 [expr {int($w*3/4 - 2)}]
891 } else {
892 set factor [expr {1.0 * $w / $oldwidth($win)}]
893 set sash0 [expr {int($factor * [lindex $s0 0])}]
894 if {$sash0 < 45} {
895 set sash0 45
897 if {$sash0 > $w - 15} {
898 set sash0 [expr {$w - 15}]
901 $win sash place 0 $sash0 [lindex $s0 1]
903 set oldwidth($win) $w
906 proc allcanvs args {
907 global canv canv2 canv3
908 eval $canv $args
909 eval $canv2 $args
910 eval $canv3 $args
913 proc bindall {event action} {
914 global canv canv2 canv3
915 bind $canv $event $action
916 bind $canv2 $event $action
917 bind $canv3 $event $action
920 proc about {} {
921 set w .about
922 if {[winfo exists $w]} {
923 raise $w
924 return
926 toplevel $w
927 wm title $w "About gitk"
928 message $w.m -text {
929 Gitk - a commit viewer for git
931 Copyright © 2005-2006 Paul Mackerras
933 Use and redistribute under the terms of the GNU General Public License} \
934 -justify center -aspect 400
935 pack $w.m -side top -fill x -padx 20 -pady 20
936 button $w.ok -text Close -command "destroy $w"
937 pack $w.ok -side bottom
940 proc keys {} {
941 set w .keys
942 if {[winfo exists $w]} {
943 raise $w
944 return
946 toplevel $w
947 wm title $w "Gitk key bindings"
948 message $w.m -text {
949 Gitk key bindings:
951 <Ctrl-Q> Quit
952 <Home> Move to first commit
953 <End> Move to last commit
954 <Up>, p, i Move up one commit
955 <Down>, n, k Move down one commit
956 <Left>, z, j Go back in history list
957 <Right>, x, l Go forward in history list
958 <PageUp> Move up one page in commit list
959 <PageDown> Move down one page in commit list
960 <Ctrl-Home> Scroll to top of commit list
961 <Ctrl-End> Scroll to bottom of commit list
962 <Ctrl-Up> Scroll commit list up one line
963 <Ctrl-Down> Scroll commit list down one line
964 <Ctrl-PageUp> Scroll commit list up one page
965 <Ctrl-PageDown> Scroll commit list down one page
966 <Shift-Up> Move to previous highlighted line
967 <Shift-Down> Move to next highlighted line
968 <Delete>, b Scroll diff view up one page
969 <Backspace> Scroll diff view up one page
970 <Space> Scroll diff view down one page
971 u Scroll diff view up 18 lines
972 d Scroll diff view down 18 lines
973 <Ctrl-F> Find
974 <Ctrl-G> Move to next find hit
975 <Return> Move to next find hit
976 / Move to next find hit, or redo find
977 ? Move to previous find hit
978 f Scroll diff view to next file
979 <Ctrl-S> Search for next hit in diff view
980 <Ctrl-R> Search for previous hit in diff view
981 <Ctrl-KP+> Increase font size
982 <Ctrl-plus> Increase font size
983 <Ctrl-KP-> Decrease font size
984 <Ctrl-minus> Decrease font size
986 -justify left -bg white -border 2 -relief sunken
987 pack $w.m -side top -fill both
988 button $w.ok -text Close -command "destroy $w"
989 pack $w.ok -side bottom
992 # Procedures for manipulating the file list window at the
993 # bottom right of the overall window.
995 proc treeview {w l openlevs} {
996 global treecontents treediropen treeheight treeparent treeindex
998 set ix 0
999 set treeindex() 0
1000 set lev 0
1001 set prefix {}
1002 set prefixend -1
1003 set prefendstack {}
1004 set htstack {}
1005 set ht 0
1006 set treecontents() {}
1007 $w conf -state normal
1008 foreach f $l {
1009 while {[string range $f 0 $prefixend] ne $prefix} {
1010 if {$lev <= $openlevs} {
1011 $w mark set e:$treeindex($prefix) "end -1c"
1012 $w mark gravity e:$treeindex($prefix) left
1014 set treeheight($prefix) $ht
1015 incr ht [lindex $htstack end]
1016 set htstack [lreplace $htstack end end]
1017 set prefixend [lindex $prefendstack end]
1018 set prefendstack [lreplace $prefendstack end end]
1019 set prefix [string range $prefix 0 $prefixend]
1020 incr lev -1
1022 set tail [string range $f [expr {$prefixend+1}] end]
1023 while {[set slash [string first "/" $tail]] >= 0} {
1024 lappend htstack $ht
1025 set ht 0
1026 lappend prefendstack $prefixend
1027 incr prefixend [expr {$slash + 1}]
1028 set d [string range $tail 0 $slash]
1029 lappend treecontents($prefix) $d
1030 set oldprefix $prefix
1031 append prefix $d
1032 set treecontents($prefix) {}
1033 set treeindex($prefix) [incr ix]
1034 set treeparent($prefix) $oldprefix
1035 set tail [string range $tail [expr {$slash+1}] end]
1036 if {$lev <= $openlevs} {
1037 set ht 1
1038 set treediropen($prefix) [expr {$lev < $openlevs}]
1039 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1040 $w mark set d:$ix "end -1c"
1041 $w mark gravity d:$ix left
1042 set str "\n"
1043 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1044 $w insert end $str
1045 $w image create end -align center -image $bm -padx 1 \
1046 -name a:$ix
1047 $w insert end $d [highlight_tag $prefix]
1048 $w mark set s:$ix "end -1c"
1049 $w mark gravity s:$ix left
1051 incr lev
1053 if {$tail ne {}} {
1054 if {$lev <= $openlevs} {
1055 incr ht
1056 set str "\n"
1057 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1058 $w insert end $str
1059 $w insert end $tail [highlight_tag $f]
1061 lappend treecontents($prefix) $tail
1064 while {$htstack ne {}} {
1065 set treeheight($prefix) $ht
1066 incr ht [lindex $htstack end]
1067 set htstack [lreplace $htstack end end]
1069 $w conf -state disabled
1072 proc linetoelt {l} {
1073 global treeheight treecontents
1075 set y 2
1076 set prefix {}
1077 while {1} {
1078 foreach e $treecontents($prefix) {
1079 if {$y == $l} {
1080 return "$prefix$e"
1082 set n 1
1083 if {[string index $e end] eq "/"} {
1084 set n $treeheight($prefix$e)
1085 if {$y + $n > $l} {
1086 append prefix $e
1087 incr y
1088 break
1091 incr y $n
1096 proc highlight_tree {y prefix} {
1097 global treeheight treecontents cflist
1099 foreach e $treecontents($prefix) {
1100 set path $prefix$e
1101 if {[highlight_tag $path] ne {}} {
1102 $cflist tag add bold $y.0 "$y.0 lineend"
1104 incr y
1105 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1106 set y [highlight_tree $y $path]
1109 return $y
1112 proc treeclosedir {w dir} {
1113 global treediropen treeheight treeparent treeindex
1115 set ix $treeindex($dir)
1116 $w conf -state normal
1117 $w delete s:$ix e:$ix
1118 set treediropen($dir) 0
1119 $w image configure a:$ix -image tri-rt
1120 $w conf -state disabled
1121 set n [expr {1 - $treeheight($dir)}]
1122 while {$dir ne {}} {
1123 incr treeheight($dir) $n
1124 set dir $treeparent($dir)
1128 proc treeopendir {w dir} {
1129 global treediropen treeheight treeparent treecontents treeindex
1131 set ix $treeindex($dir)
1132 $w conf -state normal
1133 $w image configure a:$ix -image tri-dn
1134 $w mark set e:$ix s:$ix
1135 $w mark gravity e:$ix right
1136 set lev 0
1137 set str "\n"
1138 set n [llength $treecontents($dir)]
1139 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1140 incr lev
1141 append str "\t"
1142 incr treeheight($x) $n
1144 foreach e $treecontents($dir) {
1145 set de $dir$e
1146 if {[string index $e end] eq "/"} {
1147 set iy $treeindex($de)
1148 $w mark set d:$iy e:$ix
1149 $w mark gravity d:$iy left
1150 $w insert e:$ix $str
1151 set treediropen($de) 0
1152 $w image create e:$ix -align center -image tri-rt -padx 1 \
1153 -name a:$iy
1154 $w insert e:$ix $e [highlight_tag $de]
1155 $w mark set s:$iy e:$ix
1156 $w mark gravity s:$iy left
1157 set treeheight($de) 1
1158 } else {
1159 $w insert e:$ix $str
1160 $w insert e:$ix $e [highlight_tag $de]
1163 $w mark gravity e:$ix left
1164 $w conf -state disabled
1165 set treediropen($dir) 1
1166 set top [lindex [split [$w index @0,0] .] 0]
1167 set ht [$w cget -height]
1168 set l [lindex [split [$w index s:$ix] .] 0]
1169 if {$l < $top} {
1170 $w yview $l.0
1171 } elseif {$l + $n + 1 > $top + $ht} {
1172 set top [expr {$l + $n + 2 - $ht}]
1173 if {$l < $top} {
1174 set top $l
1176 $w yview $top.0
1180 proc treeclick {w x y} {
1181 global treediropen cmitmode ctext cflist cflist_top
1183 if {$cmitmode ne "tree"} return
1184 if {![info exists cflist_top]} return
1185 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1186 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1187 $cflist tag add highlight $l.0 "$l.0 lineend"
1188 set cflist_top $l
1189 if {$l == 1} {
1190 $ctext yview 1.0
1191 return
1193 set e [linetoelt $l]
1194 if {[string index $e end] ne "/"} {
1195 showfile $e
1196 } elseif {$treediropen($e)} {
1197 treeclosedir $w $e
1198 } else {
1199 treeopendir $w $e
1203 proc setfilelist {id} {
1204 global treefilelist cflist
1206 treeview $cflist $treefilelist($id) 0
1209 image create bitmap tri-rt -background black -foreground blue -data {
1210 #define tri-rt_width 13
1211 #define tri-rt_height 13
1212 static unsigned char tri-rt_bits[] = {
1213 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1214 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1215 0x00, 0x00};
1216 } -maskdata {
1217 #define tri-rt-mask_width 13
1218 #define tri-rt-mask_height 13
1219 static unsigned char tri-rt-mask_bits[] = {
1220 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1221 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1222 0x08, 0x00};
1224 image create bitmap tri-dn -background black -foreground blue -data {
1225 #define tri-dn_width 13
1226 #define tri-dn_height 13
1227 static unsigned char tri-dn_bits[] = {
1228 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1229 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1230 0x00, 0x00};
1231 } -maskdata {
1232 #define tri-dn-mask_width 13
1233 #define tri-dn-mask_height 13
1234 static unsigned char tri-dn-mask_bits[] = {
1235 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1236 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1237 0x00, 0x00};
1240 proc init_flist {first} {
1241 global cflist cflist_top selectedline difffilestart
1243 $cflist conf -state normal
1244 $cflist delete 0.0 end
1245 if {$first ne {}} {
1246 $cflist insert end $first
1247 set cflist_top 1
1248 $cflist tag add highlight 1.0 "1.0 lineend"
1249 } else {
1250 catch {unset cflist_top}
1252 $cflist conf -state disabled
1253 set difffilestart {}
1256 proc highlight_tag {f} {
1257 global highlight_paths
1259 foreach p $highlight_paths {
1260 if {[string match $p $f]} {
1261 return "bold"
1264 return {}
1267 proc highlight_filelist {} {
1268 global cmitmode cflist
1270 $cflist conf -state normal
1271 if {$cmitmode ne "tree"} {
1272 set end [lindex [split [$cflist index end] .] 0]
1273 for {set l 2} {$l < $end} {incr l} {
1274 set line [$cflist get $l.0 "$l.0 lineend"]
1275 if {[highlight_tag $line] ne {}} {
1276 $cflist tag add bold $l.0 "$l.0 lineend"
1279 } else {
1280 highlight_tree 2 {}
1282 $cflist conf -state disabled
1285 proc unhighlight_filelist {} {
1286 global cflist
1288 $cflist conf -state normal
1289 $cflist tag remove bold 1.0 end
1290 $cflist conf -state disabled
1293 proc add_flist {fl} {
1294 global cflist
1296 $cflist conf -state normal
1297 foreach f $fl {
1298 $cflist insert end "\n"
1299 $cflist insert end $f [highlight_tag $f]
1301 $cflist conf -state disabled
1304 proc sel_flist {w x y} {
1305 global ctext difffilestart cflist cflist_top cmitmode
1307 if {$cmitmode eq "tree"} return
1308 if {![info exists cflist_top]} return
1309 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1310 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1311 $cflist tag add highlight $l.0 "$l.0 lineend"
1312 set cflist_top $l
1313 if {$l == 1} {
1314 $ctext yview 1.0
1315 } else {
1316 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1320 # Functions for adding and removing shell-type quoting
1322 proc shellquote {str} {
1323 if {![string match "*\['\"\\ \t]*" $str]} {
1324 return $str
1326 if {![string match "*\['\"\\]*" $str]} {
1327 return "\"$str\""
1329 if {![string match "*'*" $str]} {
1330 return "'$str'"
1332 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1335 proc shellarglist {l} {
1336 set str {}
1337 foreach a $l {
1338 if {$str ne {}} {
1339 append str " "
1341 append str [shellquote $a]
1343 return $str
1346 proc shelldequote {str} {
1347 set ret {}
1348 set used -1
1349 while {1} {
1350 incr used
1351 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1352 append ret [string range $str $used end]
1353 set used [string length $str]
1354 break
1356 set first [lindex $first 0]
1357 set ch [string index $str $first]
1358 if {$first > $used} {
1359 append ret [string range $str $used [expr {$first - 1}]]
1360 set used $first
1362 if {$ch eq " " || $ch eq "\t"} break
1363 incr used
1364 if {$ch eq "'"} {
1365 set first [string first "'" $str $used]
1366 if {$first < 0} {
1367 error "unmatched single-quote"
1369 append ret [string range $str $used [expr {$first - 1}]]
1370 set used $first
1371 continue
1373 if {$ch eq "\\"} {
1374 if {$used >= [string length $str]} {
1375 error "trailing backslash"
1377 append ret [string index $str $used]
1378 continue
1380 # here ch == "\""
1381 while {1} {
1382 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1383 error "unmatched double-quote"
1385 set first [lindex $first 0]
1386 set ch [string index $str $first]
1387 if {$first > $used} {
1388 append ret [string range $str $used [expr {$first - 1}]]
1389 set used $first
1391 if {$ch eq "\""} break
1392 incr used
1393 append ret [string index $str $used]
1394 incr used
1397 return [list $used $ret]
1400 proc shellsplit {str} {
1401 set l {}
1402 while {1} {
1403 set str [string trimleft $str]
1404 if {$str eq {}} break
1405 set dq [shelldequote $str]
1406 set n [lindex $dq 0]
1407 set word [lindex $dq 1]
1408 set str [string range $str $n end]
1409 lappend l $word
1411 return $l
1414 # Code to implement multiple views
1416 proc newview {ishighlight} {
1417 global nextviewnum newviewname newviewperm uifont newishighlight
1418 global newviewargs revtreeargs
1420 set newishighlight $ishighlight
1421 set top .gitkview
1422 if {[winfo exists $top]} {
1423 raise $top
1424 return
1426 set newviewname($nextviewnum) "View $nextviewnum"
1427 set newviewperm($nextviewnum) 0
1428 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1429 vieweditor $top $nextviewnum "Gitk view definition"
1432 proc editview {} {
1433 global curview
1434 global viewname viewperm newviewname newviewperm
1435 global viewargs newviewargs
1437 set top .gitkvedit-$curview
1438 if {[winfo exists $top]} {
1439 raise $top
1440 return
1442 set newviewname($curview) $viewname($curview)
1443 set newviewperm($curview) $viewperm($curview)
1444 set newviewargs($curview) [shellarglist $viewargs($curview)]
1445 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1448 proc vieweditor {top n title} {
1449 global newviewname newviewperm viewfiles
1450 global uifont
1452 toplevel $top
1453 wm title $top $title
1454 label $top.nl -text "Name" -font $uifont
1455 entry $top.name -width 20 -textvariable newviewname($n)
1456 grid $top.nl $top.name -sticky w -pady 5
1457 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n)
1458 grid $top.perm - -pady 5 -sticky w
1459 message $top.al -aspect 1000 -font $uifont \
1460 -text "Commits to include (arguments to git rev-list):"
1461 grid $top.al - -sticky w -pady 5
1462 entry $top.args -width 50 -textvariable newviewargs($n) \
1463 -background white
1464 grid $top.args - -sticky ew -padx 5
1465 message $top.l -aspect 1000 -font $uifont \
1466 -text "Enter files and directories to include, one per line:"
1467 grid $top.l - -sticky w
1468 text $top.t -width 40 -height 10 -background white
1469 if {[info exists viewfiles($n)]} {
1470 foreach f $viewfiles($n) {
1471 $top.t insert end $f
1472 $top.t insert end "\n"
1474 $top.t delete {end - 1c} end
1475 $top.t mark set insert 0.0
1477 grid $top.t - -sticky ew -padx 5
1478 frame $top.buts
1479 button $top.buts.ok -text "OK" -command [list newviewok $top $n]
1480 button $top.buts.can -text "Cancel" -command [list destroy $top]
1481 grid $top.buts.ok $top.buts.can
1482 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1483 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1484 grid $top.buts - -pady 10 -sticky ew
1485 focus $top.t
1488 proc doviewmenu {m first cmd op argv} {
1489 set nmenu [$m index end]
1490 for {set i $first} {$i <= $nmenu} {incr i} {
1491 if {[$m entrycget $i -command] eq $cmd} {
1492 eval $m $op $i $argv
1493 break
1498 proc allviewmenus {n op args} {
1499 global viewhlmenu
1501 doviewmenu .bar.view 5 [list showview $n] $op $args
1502 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1505 proc newviewok {top n} {
1506 global nextviewnum newviewperm newviewname newishighlight
1507 global viewname viewfiles viewperm selectedview curview
1508 global viewargs newviewargs viewhlmenu
1510 if {[catch {
1511 set newargs [shellsplit $newviewargs($n)]
1512 } err]} {
1513 error_popup "Error in commit selection arguments: $err"
1514 wm raise $top
1515 focus $top
1516 return
1518 set files {}
1519 foreach f [split [$top.t get 0.0 end] "\n"] {
1520 set ft [string trim $f]
1521 if {$ft ne {}} {
1522 lappend files $ft
1525 if {![info exists viewfiles($n)]} {
1526 # creating a new view
1527 incr nextviewnum
1528 set viewname($n) $newviewname($n)
1529 set viewperm($n) $newviewperm($n)
1530 set viewfiles($n) $files
1531 set viewargs($n) $newargs
1532 addviewmenu $n
1533 if {!$newishighlight} {
1534 after idle showview $n
1535 } else {
1536 after idle addvhighlight $n
1538 } else {
1539 # editing an existing view
1540 set viewperm($n) $newviewperm($n)
1541 if {$newviewname($n) ne $viewname($n)} {
1542 set viewname($n) $newviewname($n)
1543 doviewmenu .bar.view 5 [list showview $n] \
1544 entryconf [list -label $viewname($n)]
1545 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1546 entryconf [list -label $viewname($n) -value $viewname($n)]
1548 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1549 set viewfiles($n) $files
1550 set viewargs($n) $newargs
1551 if {$curview == $n} {
1552 after idle updatecommits
1556 catch {destroy $top}
1559 proc delview {} {
1560 global curview viewdata viewperm hlview selectedhlview
1562 if {$curview == 0} return
1563 if {[info exists hlview] && $hlview == $curview} {
1564 set selectedhlview None
1565 unset hlview
1567 allviewmenus $curview delete
1568 set viewdata($curview) {}
1569 set viewperm($curview) 0
1570 showview 0
1573 proc addviewmenu {n} {
1574 global viewname viewhlmenu
1576 .bar.view add radiobutton -label $viewname($n) \
1577 -command [list showview $n] -variable selectedview -value $n
1578 $viewhlmenu add radiobutton -label $viewname($n) \
1579 -command [list addvhighlight $n] -variable selectedhlview
1582 proc flatten {var} {
1583 global $var
1585 set ret {}
1586 foreach i [array names $var] {
1587 lappend ret $i [set $var\($i\)]
1589 return $ret
1592 proc unflatten {var l} {
1593 global $var
1595 catch {unset $var}
1596 foreach {i v} $l {
1597 set $var\($i\) $v
1601 proc showview {n} {
1602 global curview viewdata viewfiles
1603 global displayorder parentlist childlist rowidlist rowoffsets
1604 global colormap rowtextx commitrow nextcolor canvxmax
1605 global numcommits rowrangelist commitlisted idrowranges
1606 global selectedline currentid canv canvy0
1607 global matchinglines treediffs
1608 global pending_select phase
1609 global commitidx rowlaidout rowoptim linesegends
1610 global commfd nextupdate
1611 global selectedview
1612 global vparentlist vchildlist vdisporder vcmitlisted
1613 global hlview selectedhlview
1615 if {$n == $curview} return
1616 set selid {}
1617 if {[info exists selectedline]} {
1618 set selid $currentid
1619 set y [yc $selectedline]
1620 set ymax [lindex [$canv cget -scrollregion] 3]
1621 set span [$canv yview]
1622 set ytop [expr {[lindex $span 0] * $ymax}]
1623 set ybot [expr {[lindex $span 1] * $ymax}]
1624 if {$ytop < $y && $y < $ybot} {
1625 set yscreen [expr {$y - $ytop}]
1626 } else {
1627 set yscreen [expr {($ybot - $ytop) / 2}]
1630 unselectline
1631 normalline
1632 stopfindproc
1633 if {$curview >= 0} {
1634 set vparentlist($curview) $parentlist
1635 set vchildlist($curview) $childlist
1636 set vdisporder($curview) $displayorder
1637 set vcmitlisted($curview) $commitlisted
1638 if {$phase ne {}} {
1639 set viewdata($curview) \
1640 [list $phase $rowidlist $rowoffsets $rowrangelist \
1641 [flatten idrowranges] [flatten idinlist] \
1642 $rowlaidout $rowoptim $numcommits $linesegends]
1643 } elseif {![info exists viewdata($curview)]
1644 || [lindex $viewdata($curview) 0] ne {}} {
1645 set viewdata($curview) \
1646 [list {} $rowidlist $rowoffsets $rowrangelist]
1649 catch {unset matchinglines}
1650 catch {unset treediffs}
1651 clear_display
1652 if {[info exists hlview] && $hlview == $n} {
1653 unset hlview
1654 set selectedhlview None
1657 set curview $n
1658 set selectedview $n
1659 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1660 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1662 if {![info exists viewdata($n)]} {
1663 set pending_select $selid
1664 getcommits
1665 return
1668 set v $viewdata($n)
1669 set phase [lindex $v 0]
1670 set displayorder $vdisporder($n)
1671 set parentlist $vparentlist($n)
1672 set childlist $vchildlist($n)
1673 set commitlisted $vcmitlisted($n)
1674 set rowidlist [lindex $v 1]
1675 set rowoffsets [lindex $v 2]
1676 set rowrangelist [lindex $v 3]
1677 if {$phase eq {}} {
1678 set numcommits [llength $displayorder]
1679 catch {unset idrowranges}
1680 } else {
1681 unflatten idrowranges [lindex $v 4]
1682 unflatten idinlist [lindex $v 5]
1683 set rowlaidout [lindex $v 6]
1684 set rowoptim [lindex $v 7]
1685 set numcommits [lindex $v 8]
1686 set linesegends [lindex $v 9]
1689 catch {unset colormap}
1690 catch {unset rowtextx}
1691 set nextcolor 0
1692 set canvxmax [$canv cget -width]
1693 set curview $n
1694 set row 0
1695 setcanvscroll
1696 set yf 0
1697 set row 0
1698 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1699 set row $commitrow($n,$selid)
1700 # try to get the selected row in the same position on the screen
1701 set ymax [lindex [$canv cget -scrollregion] 3]
1702 set ytop [expr {[yc $row] - $yscreen}]
1703 if {$ytop < 0} {
1704 set ytop 0
1706 set yf [expr {$ytop * 1.0 / $ymax}]
1708 allcanvs yview moveto $yf
1709 drawvisible
1710 selectline $row 0
1711 if {$phase ne {}} {
1712 if {$phase eq "getcommits"} {
1713 show_status "Reading commits..."
1715 if {[info exists commfd($n)]} {
1716 layoutmore {}
1717 } else {
1718 finishcommits
1720 } elseif {$numcommits == 0} {
1721 show_status "No commits selected"
1725 # Stuff relating to the highlighting facility
1727 proc ishighlighted {row} {
1728 global vhighlights fhighlights nhighlights rhighlights
1730 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1731 return $nhighlights($row)
1733 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1734 return $vhighlights($row)
1736 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1737 return $fhighlights($row)
1739 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1740 return $rhighlights($row)
1742 return 0
1745 proc bolden {row font} {
1746 global canv linehtag selectedline boldrows
1748 lappend boldrows $row
1749 $canv itemconf $linehtag($row) -font $font
1750 if {[info exists selectedline] && $row == $selectedline} {
1751 $canv delete secsel
1752 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1753 -outline {{}} -tags secsel \
1754 -fill [$canv cget -selectbackground]]
1755 $canv lower $t
1759 proc bolden_name {row font} {
1760 global canv2 linentag selectedline boldnamerows
1762 lappend boldnamerows $row
1763 $canv2 itemconf $linentag($row) -font $font
1764 if {[info exists selectedline] && $row == $selectedline} {
1765 $canv2 delete secsel
1766 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1767 -outline {{}} -tags secsel \
1768 -fill [$canv2 cget -selectbackground]]
1769 $canv2 lower $t
1773 proc unbolden {} {
1774 global mainfont boldrows
1776 set stillbold {}
1777 foreach row $boldrows {
1778 if {![ishighlighted $row]} {
1779 bolden $row $mainfont
1780 } else {
1781 lappend stillbold $row
1784 set boldrows $stillbold
1787 proc addvhighlight {n} {
1788 global hlview curview viewdata vhl_done vhighlights commitidx
1790 if {[info exists hlview]} {
1791 delvhighlight
1793 set hlview $n
1794 if {$n != $curview && ![info exists viewdata($n)]} {
1795 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1796 set vparentlist($n) {}
1797 set vchildlist($n) {}
1798 set vdisporder($n) {}
1799 set vcmitlisted($n) {}
1800 start_rev_list $n
1802 set vhl_done $commitidx($hlview)
1803 if {$vhl_done > 0} {
1804 drawvisible
1808 proc delvhighlight {} {
1809 global hlview vhighlights
1811 if {![info exists hlview]} return
1812 unset hlview
1813 catch {unset vhighlights}
1814 unbolden
1817 proc vhighlightmore {} {
1818 global hlview vhl_done commitidx vhighlights
1819 global displayorder vdisporder curview mainfont
1821 set font [concat $mainfont bold]
1822 set max $commitidx($hlview)
1823 if {$hlview == $curview} {
1824 set disp $displayorder
1825 } else {
1826 set disp $vdisporder($hlview)
1828 set vr [visiblerows]
1829 set r0 [lindex $vr 0]
1830 set r1 [lindex $vr 1]
1831 for {set i $vhl_done} {$i < $max} {incr i} {
1832 set id [lindex $disp $i]
1833 if {[info exists commitrow($curview,$id)]} {
1834 set row $commitrow($curview,$id)
1835 if {$r0 <= $row && $row <= $r1} {
1836 if {![highlighted $row]} {
1837 bolden $row $font
1839 set vhighlights($row) 1
1843 set vhl_done $max
1846 proc askvhighlight {row id} {
1847 global hlview vhighlights commitrow iddrawn mainfont
1849 if {[info exists commitrow($hlview,$id)]} {
1850 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
1851 bolden $row [concat $mainfont bold]
1853 set vhighlights($row) 1
1854 } else {
1855 set vhighlights($row) 0
1859 proc hfiles_change {name ix op} {
1860 global highlight_files filehighlight fhighlights fh_serial
1861 global mainfont highlight_paths
1863 if {[info exists filehighlight]} {
1864 # delete previous highlights
1865 catch {close $filehighlight}
1866 unset filehighlight
1867 catch {unset fhighlights}
1868 unbolden
1869 unhighlight_filelist
1871 set highlight_paths {}
1872 after cancel do_file_hl $fh_serial
1873 incr fh_serial
1874 if {$highlight_files ne {}} {
1875 after 300 do_file_hl $fh_serial
1879 proc makepatterns {l} {
1880 set ret {}
1881 foreach e $l {
1882 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
1883 if {[string index $ee end] eq "/"} {
1884 lappend ret "$ee*"
1885 } else {
1886 lappend ret $ee
1887 lappend ret "$ee/*"
1890 return $ret
1893 proc do_file_hl {serial} {
1894 global highlight_files filehighlight highlight_paths gdttype fhl_list
1896 if {$gdttype eq "touching paths:"} {
1897 if {[catch {set paths [shellsplit $highlight_files]}]} return
1898 set highlight_paths [makepatterns $paths]
1899 highlight_filelist
1900 set gdtargs [concat -- $paths]
1901 } else {
1902 set gdtargs [list "-S$highlight_files"]
1904 set cmd [concat | git-diff-tree -r -s --stdin $gdtargs]
1905 set filehighlight [open $cmd r+]
1906 fconfigure $filehighlight -blocking 0
1907 fileevent $filehighlight readable readfhighlight
1908 set fhl_list {}
1909 drawvisible
1910 flushhighlights
1913 proc flushhighlights {} {
1914 global filehighlight fhl_list
1916 if {[info exists filehighlight]} {
1917 lappend fhl_list {}
1918 puts $filehighlight ""
1919 flush $filehighlight
1923 proc askfilehighlight {row id} {
1924 global filehighlight fhighlights fhl_list
1926 lappend fhl_list $id
1927 set fhighlights($row) -1
1928 puts $filehighlight $id
1931 proc readfhighlight {} {
1932 global filehighlight fhighlights commitrow curview mainfont iddrawn
1933 global fhl_list
1935 while {[gets $filehighlight line] >= 0} {
1936 set line [string trim $line]
1937 set i [lsearch -exact $fhl_list $line]
1938 if {$i < 0} continue
1939 for {set j 0} {$j < $i} {incr j} {
1940 set id [lindex $fhl_list $j]
1941 if {[info exists commitrow($curview,$id)]} {
1942 set fhighlights($commitrow($curview,$id)) 0
1945 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
1946 if {$line eq {}} continue
1947 if {![info exists commitrow($curview,$line)]} continue
1948 set row $commitrow($curview,$line)
1949 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
1950 bolden $row [concat $mainfont bold]
1952 set fhighlights($row) 1
1954 if {[eof $filehighlight]} {
1955 # strange...
1956 puts "oops, git-diff-tree died"
1957 catch {close $filehighlight}
1958 unset filehighlight
1960 next_hlcont
1963 proc find_change {name ix op} {
1964 global nhighlights mainfont boldnamerows
1965 global findstring findpattern findtype
1967 # delete previous highlights, if any
1968 foreach row $boldnamerows {
1969 bolden_name $row $mainfont
1971 set boldnamerows {}
1972 catch {unset nhighlights}
1973 unbolden
1974 if {$findtype ne "Regexp"} {
1975 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
1976 $findstring]
1977 set findpattern "*$e*"
1979 drawvisible
1982 proc askfindhighlight {row id} {
1983 global nhighlights commitinfo iddrawn mainfont
1984 global findstring findtype findloc findpattern
1986 if {![info exists commitinfo($id)]} {
1987 getcommit $id
1989 set info $commitinfo($id)
1990 set isbold 0
1991 set fldtypes {Headline Author Date Committer CDate Comments}
1992 foreach f $info ty $fldtypes {
1993 if {$findloc ne "All fields" && $findloc ne $ty} {
1994 continue
1996 if {$findtype eq "Regexp"} {
1997 set doesmatch [regexp $findstring $f]
1998 } elseif {$findtype eq "IgnCase"} {
1999 set doesmatch [string match -nocase $findpattern $f]
2000 } else {
2001 set doesmatch [string match $findpattern $f]
2003 if {$doesmatch} {
2004 if {$ty eq "Author"} {
2005 set isbold 2
2006 } else {
2007 set isbold 1
2011 if {[info exists iddrawn($id)]} {
2012 if {$isbold && ![ishighlighted $row]} {
2013 bolden $row [concat $mainfont bold]
2015 if {$isbold >= 2} {
2016 bolden_name $row [concat $mainfont bold]
2019 set nhighlights($row) $isbold
2022 proc vrel_change {name ix op} {
2023 global highlight_related
2025 rhighlight_none
2026 if {$highlight_related ne "None"} {
2027 after idle drawvisible
2031 # prepare for testing whether commits are descendents or ancestors of a
2032 proc rhighlight_sel {a} {
2033 global descendent desc_todo ancestor anc_todo
2034 global highlight_related rhighlights
2036 catch {unset descendent}
2037 set desc_todo [list $a]
2038 catch {unset ancestor}
2039 set anc_todo [list $a]
2040 if {$highlight_related ne "None"} {
2041 rhighlight_none
2042 after idle drawvisible
2046 proc rhighlight_none {} {
2047 global rhighlights
2049 catch {unset rhighlights}
2050 unbolden
2053 proc is_descendent {a} {
2054 global curview children commitrow descendent desc_todo
2056 set v $curview
2057 set la $commitrow($v,$a)
2058 set todo $desc_todo
2059 set leftover {}
2060 set done 0
2061 for {set i 0} {$i < [llength $todo]} {incr i} {
2062 set do [lindex $todo $i]
2063 if {$commitrow($v,$do) < $la} {
2064 lappend leftover $do
2065 continue
2067 foreach nk $children($v,$do) {
2068 if {![info exists descendent($nk)]} {
2069 set descendent($nk) 1
2070 lappend todo $nk
2071 if {$nk eq $a} {
2072 set done 1
2076 if {$done} {
2077 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2078 return
2081 set descendent($a) 0
2082 set desc_todo $leftover
2085 proc is_ancestor {a} {
2086 global curview parentlist commitrow ancestor anc_todo
2088 set v $curview
2089 set la $commitrow($v,$a)
2090 set todo $anc_todo
2091 set leftover {}
2092 set done 0
2093 for {set i 0} {$i < [llength $todo]} {incr i} {
2094 set do [lindex $todo $i]
2095 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2096 lappend leftover $do
2097 continue
2099 foreach np [lindex $parentlist $commitrow($v,$do)] {
2100 if {![info exists ancestor($np)]} {
2101 set ancestor($np) 1
2102 lappend todo $np
2103 if {$np eq $a} {
2104 set done 1
2108 if {$done} {
2109 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2110 return
2113 set ancestor($a) 0
2114 set anc_todo $leftover
2117 proc askrelhighlight {row id} {
2118 global descendent highlight_related iddrawn mainfont rhighlights
2119 global selectedline ancestor
2121 if {![info exists selectedline]} return
2122 set isbold 0
2123 if {$highlight_related eq "Descendent" ||
2124 $highlight_related eq "Not descendent"} {
2125 if {![info exists descendent($id)]} {
2126 is_descendent $id
2128 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2129 set isbold 1
2131 } elseif {$highlight_related eq "Ancestor" ||
2132 $highlight_related eq "Not ancestor"} {
2133 if {![info exists ancestor($id)]} {
2134 is_ancestor $id
2136 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2137 set isbold 1
2140 if {[info exists iddrawn($id)]} {
2141 if {$isbold && ![ishighlighted $row]} {
2142 bolden $row [concat $mainfont bold]
2145 set rhighlights($row) $isbold
2148 proc next_hlcont {} {
2149 global fhl_row fhl_dirn displayorder numcommits
2150 global vhighlights fhighlights nhighlights rhighlights
2151 global hlview filehighlight findstring highlight_related
2153 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2154 set row $fhl_row
2155 while {1} {
2156 if {$row < 0 || $row >= $numcommits} {
2157 bell
2158 set fhl_dirn 0
2159 return
2161 set id [lindex $displayorder $row]
2162 if {[info exists hlview]} {
2163 if {![info exists vhighlights($row)]} {
2164 askvhighlight $row $id
2166 if {$vhighlights($row) > 0} break
2168 if {$findstring ne {}} {
2169 if {![info exists nhighlights($row)]} {
2170 askfindhighlight $row $id
2172 if {$nhighlights($row) > 0} break
2174 if {$highlight_related ne "None"} {
2175 if {![info exists rhighlights($row)]} {
2176 askrelhighlight $row $id
2178 if {$rhighlights($row) > 0} break
2180 if {[info exists filehighlight]} {
2181 if {![info exists fhighlights($row)]} {
2182 # ask for a few more while we're at it...
2183 set r $row
2184 for {set n 0} {$n < 100} {incr n} {
2185 if {![info exists fhighlights($r)]} {
2186 askfilehighlight $r [lindex $displayorder $r]
2188 incr r $fhl_dirn
2189 if {$r < 0 || $r >= $numcommits} break
2191 flushhighlights
2193 if {$fhighlights($row) < 0} {
2194 set fhl_row $row
2195 return
2197 if {$fhighlights($row) > 0} break
2199 incr row $fhl_dirn
2201 set fhl_dirn 0
2202 selectline $row 1
2205 proc next_highlight {dirn} {
2206 global selectedline fhl_row fhl_dirn
2207 global hlview filehighlight findstring highlight_related
2209 if {![info exists selectedline]} return
2210 if {!([info exists hlview] || $findstring ne {} ||
2211 $highlight_related ne "None" || [info exists filehighlight])} return
2212 set fhl_row [expr {$selectedline + $dirn}]
2213 set fhl_dirn $dirn
2214 next_hlcont
2217 proc cancel_next_highlight {} {
2218 global fhl_dirn
2220 set fhl_dirn 0
2223 # Graph layout functions
2225 proc shortids {ids} {
2226 set res {}
2227 foreach id $ids {
2228 if {[llength $id] > 1} {
2229 lappend res [shortids $id]
2230 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2231 lappend res [string range $id 0 7]
2232 } else {
2233 lappend res $id
2236 return $res
2239 proc incrange {l x o} {
2240 set n [llength $l]
2241 while {$x < $n} {
2242 set e [lindex $l $x]
2243 if {$e ne {}} {
2244 lset l $x [expr {$e + $o}]
2246 incr x
2248 return $l
2251 proc ntimes {n o} {
2252 set ret {}
2253 for {} {$n > 0} {incr n -1} {
2254 lappend ret $o
2256 return $ret
2259 proc usedinrange {id l1 l2} {
2260 global children commitrow childlist curview
2262 if {[info exists commitrow($curview,$id)]} {
2263 set r $commitrow($curview,$id)
2264 if {$l1 <= $r && $r <= $l2} {
2265 return [expr {$r - $l1 + 1}]
2267 set kids [lindex $childlist $r]
2268 } else {
2269 set kids $children($curview,$id)
2271 foreach c $kids {
2272 set r $commitrow($curview,$c)
2273 if {$l1 <= $r && $r <= $l2} {
2274 return [expr {$r - $l1 + 1}]
2277 return 0
2280 proc sanity {row {full 0}} {
2281 global rowidlist rowoffsets
2283 set col -1
2284 set ids [lindex $rowidlist $row]
2285 foreach id $ids {
2286 incr col
2287 if {$id eq {}} continue
2288 if {$col < [llength $ids] - 1 &&
2289 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2290 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2292 set o [lindex $rowoffsets $row $col]
2293 set y $row
2294 set x $col
2295 while {$o ne {}} {
2296 incr y -1
2297 incr x $o
2298 if {[lindex $rowidlist $y $x] != $id} {
2299 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2300 puts " id=[shortids $id] check started at row $row"
2301 for {set i $row} {$i >= $y} {incr i -1} {
2302 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2304 break
2306 if {!$full} break
2307 set o [lindex $rowoffsets $y $x]
2312 proc makeuparrow {oid x y z} {
2313 global rowidlist rowoffsets uparrowlen idrowranges
2315 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2316 incr y -1
2317 incr x $z
2318 set off0 [lindex $rowoffsets $y]
2319 for {set x0 $x} {1} {incr x0} {
2320 if {$x0 >= [llength $off0]} {
2321 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2322 break
2324 set z [lindex $off0 $x0]
2325 if {$z ne {}} {
2326 incr x0 $z
2327 break
2330 set z [expr {$x0 - $x}]
2331 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2332 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2334 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2335 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2336 lappend idrowranges($oid) $y
2339 proc initlayout {} {
2340 global rowidlist rowoffsets displayorder commitlisted
2341 global rowlaidout rowoptim
2342 global idinlist rowchk rowrangelist idrowranges
2343 global numcommits canvxmax canv
2344 global nextcolor
2345 global parentlist childlist children
2346 global colormap rowtextx
2347 global linesegends
2349 set numcommits 0
2350 set displayorder {}
2351 set commitlisted {}
2352 set parentlist {}
2353 set childlist {}
2354 set rowrangelist {}
2355 set nextcolor 0
2356 set rowidlist {{}}
2357 set rowoffsets {{}}
2358 catch {unset idinlist}
2359 catch {unset rowchk}
2360 set rowlaidout 0
2361 set rowoptim 0
2362 set canvxmax [$canv cget -width]
2363 catch {unset colormap}
2364 catch {unset rowtextx}
2365 catch {unset idrowranges}
2366 set linesegends {}
2369 proc setcanvscroll {} {
2370 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2372 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2373 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2374 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2375 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2378 proc visiblerows {} {
2379 global canv numcommits linespc
2381 set ymax [lindex [$canv cget -scrollregion] 3]
2382 if {$ymax eq {} || $ymax == 0} return
2383 set f [$canv yview]
2384 set y0 [expr {int([lindex $f 0] * $ymax)}]
2385 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2386 if {$r0 < 0} {
2387 set r0 0
2389 set y1 [expr {int([lindex $f 1] * $ymax)}]
2390 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2391 if {$r1 >= $numcommits} {
2392 set r1 [expr {$numcommits - 1}]
2394 return [list $r0 $r1]
2397 proc layoutmore {tmax} {
2398 global rowlaidout rowoptim commitidx numcommits optim_delay
2399 global uparrowlen curview
2401 while {1} {
2402 if {$rowoptim - $optim_delay > $numcommits} {
2403 showstuff [expr {$rowoptim - $optim_delay}]
2404 } elseif {$rowlaidout - $uparrowlen - 1 > $rowoptim} {
2405 set nr [expr {$rowlaidout - $uparrowlen - 1 - $rowoptim}]
2406 if {$nr > 100} {
2407 set nr 100
2409 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2410 incr rowoptim $nr
2411 } elseif {$commitidx($curview) > $rowlaidout} {
2412 set nr [expr {$commitidx($curview) - $rowlaidout}]
2413 # may need to increase this threshold if uparrowlen or
2414 # mingaplen are increased...
2415 if {$nr > 150} {
2416 set nr 150
2418 set row $rowlaidout
2419 set rowlaidout [layoutrows $row [expr {$row + $nr}] 0]
2420 if {$rowlaidout == $row} {
2421 return 0
2423 } else {
2424 return 0
2426 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2427 return 1
2432 proc showstuff {canshow} {
2433 global numcommits commitrow pending_select selectedline
2434 global linesegends idrowranges idrangedrawn curview
2436 if {$numcommits == 0} {
2437 global phase
2438 set phase "incrdraw"
2439 allcanvs delete all
2441 set row $numcommits
2442 set numcommits $canshow
2443 setcanvscroll
2444 set rows [visiblerows]
2445 set r0 [lindex $rows 0]
2446 set r1 [lindex $rows 1]
2447 set selrow -1
2448 for {set r $row} {$r < $canshow} {incr r} {
2449 foreach id [lindex $linesegends [expr {$r+1}]] {
2450 set i -1
2451 foreach {s e} [rowranges $id] {
2452 incr i
2453 if {$e ne {} && $e < $numcommits && $s <= $r1 && $e >= $r0
2454 && ![info exists idrangedrawn($id,$i)]} {
2455 drawlineseg $id $i
2456 set idrangedrawn($id,$i) 1
2461 if {$canshow > $r1} {
2462 set canshow $r1
2464 while {$row < $canshow} {
2465 drawcmitrow $row
2466 incr row
2468 if {[info exists pending_select] &&
2469 [info exists commitrow($curview,$pending_select)] &&
2470 $commitrow($curview,$pending_select) < $numcommits} {
2471 selectline $commitrow($curview,$pending_select) 1
2473 if {![info exists selectedline] && ![info exists pending_select]} {
2474 selectline 0 1
2478 proc layoutrows {row endrow last} {
2479 global rowidlist rowoffsets displayorder
2480 global uparrowlen downarrowlen maxwidth mingaplen
2481 global childlist parentlist
2482 global idrowranges linesegends
2483 global commitidx curview
2484 global idinlist rowchk rowrangelist
2486 set idlist [lindex $rowidlist $row]
2487 set offs [lindex $rowoffsets $row]
2488 while {$row < $endrow} {
2489 set id [lindex $displayorder $row]
2490 set oldolds {}
2491 set newolds {}
2492 foreach p [lindex $parentlist $row] {
2493 if {![info exists idinlist($p)]} {
2494 lappend newolds $p
2495 } elseif {!$idinlist($p)} {
2496 lappend oldolds $p
2499 set lse {}
2500 set nev [expr {[llength $idlist] + [llength $newolds]
2501 + [llength $oldolds] - $maxwidth + 1}]
2502 if {$nev > 0} {
2503 if {!$last &&
2504 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2505 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2506 set i [lindex $idlist $x]
2507 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2508 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2509 [expr {$row + $uparrowlen + $mingaplen}]]
2510 if {$r == 0} {
2511 set idlist [lreplace $idlist $x $x]
2512 set offs [lreplace $offs $x $x]
2513 set offs [incrange $offs $x 1]
2514 set idinlist($i) 0
2515 set rm1 [expr {$row - 1}]
2516 lappend lse $i
2517 lappend idrowranges($i) $rm1
2518 if {[incr nev -1] <= 0} break
2519 continue
2521 set rowchk($id) [expr {$row + $r}]
2524 lset rowidlist $row $idlist
2525 lset rowoffsets $row $offs
2527 lappend linesegends $lse
2528 set col [lsearch -exact $idlist $id]
2529 if {$col < 0} {
2530 set col [llength $idlist]
2531 lappend idlist $id
2532 lset rowidlist $row $idlist
2533 set z {}
2534 if {[lindex $childlist $row] ne {}} {
2535 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2536 unset idinlist($id)
2538 lappend offs $z
2539 lset rowoffsets $row $offs
2540 if {$z ne {}} {
2541 makeuparrow $id $col $row $z
2543 } else {
2544 unset idinlist($id)
2546 set ranges {}
2547 if {[info exists idrowranges($id)]} {
2548 set ranges $idrowranges($id)
2549 lappend ranges $row
2550 unset idrowranges($id)
2552 lappend rowrangelist $ranges
2553 incr row
2554 set offs [ntimes [llength $idlist] 0]
2555 set l [llength $newolds]
2556 set idlist [eval lreplace \$idlist $col $col $newolds]
2557 set o 0
2558 if {$l != 1} {
2559 set offs [lrange $offs 0 [expr {$col - 1}]]
2560 foreach x $newolds {
2561 lappend offs {}
2562 incr o -1
2564 incr o
2565 set tmp [expr {[llength $idlist] - [llength $offs]}]
2566 if {$tmp > 0} {
2567 set offs [concat $offs [ntimes $tmp $o]]
2569 } else {
2570 lset offs $col {}
2572 foreach i $newolds {
2573 set idinlist($i) 1
2574 set idrowranges($i) $row
2576 incr col $l
2577 foreach oid $oldolds {
2578 set idinlist($oid) 1
2579 set idlist [linsert $idlist $col $oid]
2580 set offs [linsert $offs $col $o]
2581 makeuparrow $oid $col $row $o
2582 incr col
2584 lappend rowidlist $idlist
2585 lappend rowoffsets $offs
2587 return $row
2590 proc addextraid {id row} {
2591 global displayorder commitrow commitinfo
2592 global commitidx commitlisted
2593 global parentlist childlist children curview
2595 incr commitidx($curview)
2596 lappend displayorder $id
2597 lappend commitlisted 0
2598 lappend parentlist {}
2599 set commitrow($curview,$id) $row
2600 readcommit $id
2601 if {![info exists commitinfo($id)]} {
2602 set commitinfo($id) {"No commit information available"}
2604 if {![info exists children($curview,$id)]} {
2605 set children($curview,$id) {}
2607 lappend childlist $children($curview,$id)
2610 proc layouttail {} {
2611 global rowidlist rowoffsets idinlist commitidx curview
2612 global idrowranges rowrangelist
2614 set row $commitidx($curview)
2615 set idlist [lindex $rowidlist $row]
2616 while {$idlist ne {}} {
2617 set col [expr {[llength $idlist] - 1}]
2618 set id [lindex $idlist $col]
2619 addextraid $id $row
2620 unset idinlist($id)
2621 lappend idrowranges($id) $row
2622 lappend rowrangelist $idrowranges($id)
2623 unset idrowranges($id)
2624 incr row
2625 set offs [ntimes $col 0]
2626 set idlist [lreplace $idlist $col $col]
2627 lappend rowidlist $idlist
2628 lappend rowoffsets $offs
2631 foreach id [array names idinlist] {
2632 addextraid $id $row
2633 lset rowidlist $row [list $id]
2634 lset rowoffsets $row 0
2635 makeuparrow $id 0 $row 0
2636 lappend idrowranges($id) $row
2637 lappend rowrangelist $idrowranges($id)
2638 unset idrowranges($id)
2639 incr row
2640 lappend rowidlist {}
2641 lappend rowoffsets {}
2645 proc insert_pad {row col npad} {
2646 global rowidlist rowoffsets
2648 set pad [ntimes $npad {}]
2649 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2650 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2651 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2654 proc optimize_rows {row col endrow} {
2655 global rowidlist rowoffsets idrowranges displayorder
2657 for {} {$row < $endrow} {incr row} {
2658 set idlist [lindex $rowidlist $row]
2659 set offs [lindex $rowoffsets $row]
2660 set haspad 0
2661 for {} {$col < [llength $offs]} {incr col} {
2662 if {[lindex $idlist $col] eq {}} {
2663 set haspad 1
2664 continue
2666 set z [lindex $offs $col]
2667 if {$z eq {}} continue
2668 set isarrow 0
2669 set x0 [expr {$col + $z}]
2670 set y0 [expr {$row - 1}]
2671 set z0 [lindex $rowoffsets $y0 $x0]
2672 if {$z0 eq {}} {
2673 set id [lindex $idlist $col]
2674 set ranges [rowranges $id]
2675 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2676 set isarrow 1
2679 if {$z < -1 || ($z < 0 && $isarrow)} {
2680 set npad [expr {-1 - $z + $isarrow}]
2681 set offs [incrange $offs $col $npad]
2682 insert_pad $y0 $x0 $npad
2683 if {$y0 > 0} {
2684 optimize_rows $y0 $x0 $row
2686 set z [lindex $offs $col]
2687 set x0 [expr {$col + $z}]
2688 set z0 [lindex $rowoffsets $y0 $x0]
2689 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2690 set npad [expr {$z - 1 + $isarrow}]
2691 set y1 [expr {$row + 1}]
2692 set offs2 [lindex $rowoffsets $y1]
2693 set x1 -1
2694 foreach z $offs2 {
2695 incr x1
2696 if {$z eq {} || $x1 + $z < $col} continue
2697 if {$x1 + $z > $col} {
2698 incr npad
2700 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2701 break
2703 set pad [ntimes $npad {}]
2704 set idlist [eval linsert \$idlist $col $pad]
2705 set tmp [eval linsert \$offs $col $pad]
2706 incr col $npad
2707 set offs [incrange $tmp $col [expr {-$npad}]]
2708 set z [lindex $offs $col]
2709 set haspad 1
2711 if {$z0 eq {} && !$isarrow} {
2712 # this line links to its first child on row $row-2
2713 set rm2 [expr {$row - 2}]
2714 set id [lindex $displayorder $rm2]
2715 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2716 if {$xc >= 0} {
2717 set z0 [expr {$xc - $x0}]
2720 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2721 insert_pad $y0 $x0 1
2722 set offs [incrange $offs $col 1]
2723 optimize_rows $y0 [expr {$x0 + 1}] $row
2726 if {!$haspad} {
2727 set o {}
2728 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
2729 set o [lindex $offs $col]
2730 if {$o eq {}} {
2731 # check if this is the link to the first child
2732 set id [lindex $idlist $col]
2733 set ranges [rowranges $id]
2734 if {$ranges ne {} && $row == [lindex $ranges 0]} {
2735 # it is, work out offset to child
2736 set y0 [expr {$row - 1}]
2737 set id [lindex $displayorder $y0]
2738 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
2739 if {$x0 >= 0} {
2740 set o [expr {$x0 - $col}]
2744 if {$o eq {} || $o <= 0} break
2746 if {$o ne {} && [incr col] < [llength $idlist]} {
2747 set y1 [expr {$row + 1}]
2748 set offs2 [lindex $rowoffsets $y1]
2749 set x1 -1
2750 foreach z $offs2 {
2751 incr x1
2752 if {$z eq {} || $x1 + $z < $col} continue
2753 lset rowoffsets $y1 [incrange $offs2 $x1 1]
2754 break
2756 set idlist [linsert $idlist $col {}]
2757 set tmp [linsert $offs $col {}]
2758 incr col
2759 set offs [incrange $tmp $col -1]
2762 lset rowidlist $row $idlist
2763 lset rowoffsets $row $offs
2764 set col 0
2768 proc xc {row col} {
2769 global canvx0 linespc
2770 return [expr {$canvx0 + $col * $linespc}]
2773 proc yc {row} {
2774 global canvy0 linespc
2775 return [expr {$canvy0 + $row * $linespc}]
2778 proc linewidth {id} {
2779 global thickerline lthickness
2781 set wid $lthickness
2782 if {[info exists thickerline] && $id eq $thickerline} {
2783 set wid [expr {2 * $lthickness}]
2785 return $wid
2788 proc rowranges {id} {
2789 global phase idrowranges commitrow rowlaidout rowrangelist curview
2791 set ranges {}
2792 if {$phase eq {} ||
2793 ([info exists commitrow($curview,$id)]
2794 && $commitrow($curview,$id) < $rowlaidout)} {
2795 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
2796 } elseif {[info exists idrowranges($id)]} {
2797 set ranges $idrowranges($id)
2799 return $ranges
2802 proc drawlineseg {id i} {
2803 global rowoffsets rowidlist
2804 global displayorder
2805 global canv colormap linespc
2806 global numcommits commitrow curview
2808 set ranges [rowranges $id]
2809 set downarrow 1
2810 if {[info exists commitrow($curview,$id)]
2811 && $commitrow($curview,$id) < $numcommits} {
2812 set downarrow [expr {$i < [llength $ranges] / 2 - 1}]
2813 } else {
2814 set downarrow 1
2816 set startrow [lindex $ranges [expr {2 * $i}]]
2817 set row [lindex $ranges [expr {2 * $i + 1}]]
2818 if {$startrow == $row} return
2819 assigncolor $id
2820 set coords {}
2821 set col [lsearch -exact [lindex $rowidlist $row] $id]
2822 if {$col < 0} {
2823 puts "oops: drawline: id $id not on row $row"
2824 return
2826 set lasto {}
2827 set ns 0
2828 while {1} {
2829 set o [lindex $rowoffsets $row $col]
2830 if {$o eq {}} break
2831 if {$o ne $lasto} {
2832 # changing direction
2833 set x [xc $row $col]
2834 set y [yc $row]
2835 lappend coords $x $y
2836 set lasto $o
2838 incr col $o
2839 incr row -1
2841 set x [xc $row $col]
2842 set y [yc $row]
2843 lappend coords $x $y
2844 if {$i == 0} {
2845 # draw the link to the first child as part of this line
2846 incr row -1
2847 set child [lindex $displayorder $row]
2848 set ccol [lsearch -exact [lindex $rowidlist $row] $child]
2849 if {$ccol >= 0} {
2850 set x [xc $row $ccol]
2851 set y [yc $row]
2852 if {$ccol < $col - 1} {
2853 lappend coords [xc $row [expr {$col - 1}]] [yc $row]
2854 } elseif {$ccol > $col + 1} {
2855 lappend coords [xc $row [expr {$col + 1}]] [yc $row]
2857 lappend coords $x $y
2860 if {[llength $coords] < 4} return
2861 if {$downarrow} {
2862 # This line has an arrow at the lower end: check if the arrow is
2863 # on a diagonal segment, and if so, work around the Tk 8.4
2864 # refusal to draw arrows on diagonal lines.
2865 set x0 [lindex $coords 0]
2866 set x1 [lindex $coords 2]
2867 if {$x0 != $x1} {
2868 set y0 [lindex $coords 1]
2869 set y1 [lindex $coords 3]
2870 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
2871 # we have a nearby vertical segment, just trim off the diag bit
2872 set coords [lrange $coords 2 end]
2873 } else {
2874 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
2875 set xi [expr {$x0 - $slope * $linespc / 2}]
2876 set yi [expr {$y0 - $linespc / 2}]
2877 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
2881 set arrow [expr {2 * ($i > 0) + $downarrow}]
2882 set arrow [lindex {none first last both} $arrow]
2883 set t [$canv create line $coords -width [linewidth $id] \
2884 -fill $colormap($id) -tags lines.$id -arrow $arrow]
2885 $canv lower $t
2886 bindline $t $id
2889 proc drawparentlinks {id row col olds} {
2890 global rowidlist canv colormap
2892 set row2 [expr {$row + 1}]
2893 set x [xc $row $col]
2894 set y [yc $row]
2895 set y2 [yc $row2]
2896 set ids [lindex $rowidlist $row2]
2897 # rmx = right-most X coord used
2898 set rmx 0
2899 foreach p $olds {
2900 set i [lsearch -exact $ids $p]
2901 if {$i < 0} {
2902 puts "oops, parent $p of $id not in list"
2903 continue
2905 set x2 [xc $row2 $i]
2906 if {$x2 > $rmx} {
2907 set rmx $x2
2909 set ranges [rowranges $p]
2910 if {$ranges ne {} && $row2 == [lindex $ranges 0]
2911 && $row2 < [lindex $ranges 1]} {
2912 # drawlineseg will do this one for us
2913 continue
2915 assigncolor $p
2916 # should handle duplicated parents here...
2917 set coords [list $x $y]
2918 if {$i < $col - 1} {
2919 lappend coords [xc $row [expr {$i + 1}]] $y
2920 } elseif {$i > $col + 1} {
2921 lappend coords [xc $row [expr {$i - 1}]] $y
2923 lappend coords $x2 $y2
2924 set t [$canv create line $coords -width [linewidth $p] \
2925 -fill $colormap($p) -tags lines.$p]
2926 $canv lower $t
2927 bindline $t $p
2929 return $rmx
2932 proc drawlines {id} {
2933 global colormap canv
2934 global idrangedrawn
2935 global children iddrawn commitrow rowidlist curview
2937 $canv delete lines.$id
2938 set nr [expr {[llength [rowranges $id]] / 2}]
2939 for {set i 0} {$i < $nr} {incr i} {
2940 if {[info exists idrangedrawn($id,$i)]} {
2941 drawlineseg $id $i
2944 foreach child $children($curview,$id) {
2945 if {[info exists iddrawn($child)]} {
2946 set row $commitrow($curview,$child)
2947 set col [lsearch -exact [lindex $rowidlist $row] $child]
2948 if {$col >= 0} {
2949 drawparentlinks $child $row $col [list $id]
2955 proc drawcmittext {id row col rmx} {
2956 global linespc canv canv2 canv3 canvy0 fgcolor
2957 global commitlisted commitinfo rowidlist
2958 global rowtextx idpos idtags idheads idotherrefs
2959 global linehtag linentag linedtag
2960 global mainfont canvxmax boldrows boldnamerows fgcolor
2962 set ofill [expr {[lindex $commitlisted $row]? "blue": "white"}]
2963 set x [xc $row $col]
2964 set y [yc $row]
2965 set orad [expr {$linespc / 3}]
2966 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
2967 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
2968 -fill $ofill -outline $fgcolor -width 1 -tags circle]
2969 $canv raise $t
2970 $canv bind $t <1> {selcanvline {} %x %y}
2971 set xt [xc $row [llength [lindex $rowidlist $row]]]
2972 if {$xt < $rmx} {
2973 set xt $rmx
2975 set rowtextx($row) $xt
2976 set idpos($id) [list $x $xt $y]
2977 if {[info exists idtags($id)] || [info exists idheads($id)]
2978 || [info exists idotherrefs($id)]} {
2979 set xt [drawtags $id $x $xt $y]
2981 set headline [lindex $commitinfo($id) 0]
2982 set name [lindex $commitinfo($id) 1]
2983 set date [lindex $commitinfo($id) 2]
2984 set date [formatdate $date]
2985 set font $mainfont
2986 set nfont $mainfont
2987 set isbold [ishighlighted $row]
2988 if {$isbold > 0} {
2989 lappend boldrows $row
2990 lappend font bold
2991 if {$isbold > 1} {
2992 lappend boldnamerows $row
2993 lappend nfont bold
2996 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
2997 -text $headline -font $font -tags text]
2998 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
2999 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3000 -text $name -font $nfont -tags text]
3001 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3002 -text $date -font $mainfont -tags text]
3003 set xr [expr {$xt + [font measure $mainfont $headline]}]
3004 if {$xr > $canvxmax} {
3005 set canvxmax $xr
3006 setcanvscroll
3010 proc drawcmitrow {row} {
3011 global displayorder rowidlist
3012 global idrangedrawn iddrawn
3013 global commitinfo parentlist numcommits
3014 global filehighlight fhighlights findstring nhighlights
3015 global hlview vhighlights
3016 global highlight_related rhighlights
3018 if {$row >= $numcommits} return
3019 foreach id [lindex $rowidlist $row] {
3020 if {$id eq {}} continue
3021 set i -1
3022 foreach {s e} [rowranges $id] {
3023 incr i
3024 if {$row < $s} continue
3025 if {$e eq {}} break
3026 if {$row <= $e} {
3027 if {$e < $numcommits && ![info exists idrangedrawn($id,$i)]} {
3028 drawlineseg $id $i
3029 set idrangedrawn($id,$i) 1
3031 break
3036 set id [lindex $displayorder $row]
3037 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3038 askvhighlight $row $id
3040 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3041 askfilehighlight $row $id
3043 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3044 askfindhighlight $row $id
3046 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3047 askrelhighlight $row $id
3049 if {[info exists iddrawn($id)]} return
3050 set col [lsearch -exact [lindex $rowidlist $row] $id]
3051 if {$col < 0} {
3052 puts "oops, row $row id $id not in list"
3053 return
3055 if {![info exists commitinfo($id)]} {
3056 getcommit $id
3058 assigncolor $id
3059 set olds [lindex $parentlist $row]
3060 if {$olds ne {}} {
3061 set rmx [drawparentlinks $id $row $col $olds]
3062 } else {
3063 set rmx 0
3065 drawcmittext $id $row $col $rmx
3066 set iddrawn($id) 1
3069 proc drawfrac {f0 f1} {
3070 global numcommits canv
3071 global linespc
3073 set ymax [lindex [$canv cget -scrollregion] 3]
3074 if {$ymax eq {} || $ymax == 0} return
3075 set y0 [expr {int($f0 * $ymax)}]
3076 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3077 if {$row < 0} {
3078 set row 0
3080 set y1 [expr {int($f1 * $ymax)}]
3081 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3082 if {$endrow >= $numcommits} {
3083 set endrow [expr {$numcommits - 1}]
3085 for {} {$row <= $endrow} {incr row} {
3086 drawcmitrow $row
3090 proc drawvisible {} {
3091 global canv
3092 eval drawfrac [$canv yview]
3095 proc clear_display {} {
3096 global iddrawn idrangedrawn
3097 global vhighlights fhighlights nhighlights rhighlights
3099 allcanvs delete all
3100 catch {unset iddrawn}
3101 catch {unset idrangedrawn}
3102 catch {unset vhighlights}
3103 catch {unset fhighlights}
3104 catch {unset nhighlights}
3105 catch {unset rhighlights}
3108 proc findcrossings {id} {
3109 global rowidlist parentlist numcommits rowoffsets displayorder
3111 set cross {}
3112 set ccross {}
3113 foreach {s e} [rowranges $id] {
3114 if {$e >= $numcommits} {
3115 set e [expr {$numcommits - 1}]
3117 if {$e <= $s} continue
3118 set x [lsearch -exact [lindex $rowidlist $e] $id]
3119 if {$x < 0} {
3120 puts "findcrossings: oops, no [shortids $id] in row $e"
3121 continue
3123 for {set row $e} {[incr row -1] >= $s} {} {
3124 set olds [lindex $parentlist $row]
3125 set kid [lindex $displayorder $row]
3126 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3127 if {$kidx < 0} continue
3128 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3129 foreach p $olds {
3130 set px [lsearch -exact $nextrow $p]
3131 if {$px < 0} continue
3132 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3133 if {[lsearch -exact $ccross $p] >= 0} continue
3134 if {$x == $px + ($kidx < $px? -1: 1)} {
3135 lappend ccross $p
3136 } elseif {[lsearch -exact $cross $p] < 0} {
3137 lappend cross $p
3141 set inc [lindex $rowoffsets $row $x]
3142 if {$inc eq {}} break
3143 incr x $inc
3146 return [concat $ccross {{}} $cross]
3149 proc assigncolor {id} {
3150 global colormap colors nextcolor
3151 global commitrow parentlist children children curview
3153 if {[info exists colormap($id)]} return
3154 set ncolors [llength $colors]
3155 if {[info exists children($curview,$id)]} {
3156 set kids $children($curview,$id)
3157 } else {
3158 set kids {}
3160 if {[llength $kids] == 1} {
3161 set child [lindex $kids 0]
3162 if {[info exists colormap($child)]
3163 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3164 set colormap($id) $colormap($child)
3165 return
3168 set badcolors {}
3169 set origbad {}
3170 foreach x [findcrossings $id] {
3171 if {$x eq {}} {
3172 # delimiter between corner crossings and other crossings
3173 if {[llength $badcolors] >= $ncolors - 1} break
3174 set origbad $badcolors
3176 if {[info exists colormap($x)]
3177 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3178 lappend badcolors $colormap($x)
3181 if {[llength $badcolors] >= $ncolors} {
3182 set badcolors $origbad
3184 set origbad $badcolors
3185 if {[llength $badcolors] < $ncolors - 1} {
3186 foreach child $kids {
3187 if {[info exists colormap($child)]
3188 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3189 lappend badcolors $colormap($child)
3191 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3192 if {[info exists colormap($p)]
3193 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3194 lappend badcolors $colormap($p)
3198 if {[llength $badcolors] >= $ncolors} {
3199 set badcolors $origbad
3202 for {set i 0} {$i <= $ncolors} {incr i} {
3203 set c [lindex $colors $nextcolor]
3204 if {[incr nextcolor] >= $ncolors} {
3205 set nextcolor 0
3207 if {[lsearch -exact $badcolors $c]} break
3209 set colormap($id) $c
3212 proc bindline {t id} {
3213 global canv
3215 $canv bind $t <Enter> "lineenter %x %y $id"
3216 $canv bind $t <Motion> "linemotion %x %y $id"
3217 $canv bind $t <Leave> "lineleave $id"
3218 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3221 proc drawtags {id x xt y1} {
3222 global idtags idheads idotherrefs mainhead
3223 global linespc lthickness
3224 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3226 set marks {}
3227 set ntags 0
3228 set nheads 0
3229 if {[info exists idtags($id)]} {
3230 set marks $idtags($id)
3231 set ntags [llength $marks]
3233 if {[info exists idheads($id)]} {
3234 set marks [concat $marks $idheads($id)]
3235 set nheads [llength $idheads($id)]
3237 if {[info exists idotherrefs($id)]} {
3238 set marks [concat $marks $idotherrefs($id)]
3240 if {$marks eq {}} {
3241 return $xt
3244 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3245 set yt [expr {$y1 - 0.5 * $linespc}]
3246 set yb [expr {$yt + $linespc - 1}]
3247 set xvals {}
3248 set wvals {}
3249 set i -1
3250 foreach tag $marks {
3251 incr i
3252 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3253 set wid [font measure [concat $mainfont bold] $tag]
3254 } else {
3255 set wid [font measure $mainfont $tag]
3257 lappend xvals $xt
3258 lappend wvals $wid
3259 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3261 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3262 -width $lthickness -fill black -tags tag.$id]
3263 $canv lower $t
3264 foreach tag $marks x $xvals wid $wvals {
3265 set xl [expr {$x + $delta}]
3266 set xr [expr {$x + $delta + $wid + $lthickness}]
3267 set font $mainfont
3268 if {[incr ntags -1] >= 0} {
3269 # draw a tag
3270 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3271 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3272 -width 1 -outline black -fill yellow -tags tag.$id]
3273 $canv bind $t <1> [list showtag $tag 1]
3274 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3275 } else {
3276 # draw a head or other ref
3277 if {[incr nheads -1] >= 0} {
3278 set col green
3279 if {$tag eq $mainhead} {
3280 lappend font bold
3282 } else {
3283 set col "#ddddff"
3285 set xl [expr {$xl - $delta/2}]
3286 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3287 -width 1 -outline black -fill $col -tags tag.$id
3288 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3289 set rwid [font measure $mainfont $remoteprefix]
3290 set xi [expr {$x + 1}]
3291 set yti [expr {$yt + 1}]
3292 set xri [expr {$x + $rwid}]
3293 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3294 -width 0 -fill "#ffddaa" -tags tag.$id
3297 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3298 -font $font -tags [list tag.$id text]]
3299 if {$ntags >= 0} {
3300 $canv bind $t <1> [list showtag $tag 1]
3301 } elseif {$nheads >= 0} {
3302 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3305 return $xt
3308 proc xcoord {i level ln} {
3309 global canvx0 xspc1 xspc2
3311 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3312 if {$i > 0 && $i == $level} {
3313 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3314 } elseif {$i > $level} {
3315 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3317 return $x
3320 proc show_status {msg} {
3321 global canv mainfont fgcolor
3323 clear_display
3324 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3325 -tags text -fill $fgcolor
3328 proc finishcommits {} {
3329 global commitidx phase curview
3330 global pending_select
3332 if {$commitidx($curview) > 0} {
3333 drawrest
3334 } else {
3335 show_status "No commits selected"
3337 set phase {}
3338 catch {unset pending_select}
3341 # Insert a new commit as the child of the commit on row $row.
3342 # The new commit will be displayed on row $row and the commits
3343 # on that row and below will move down one row.
3344 proc insertrow {row newcmit} {
3345 global displayorder parentlist childlist commitlisted
3346 global commitrow curview rowidlist rowoffsets numcommits
3347 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3348 global linesegends selectedline
3350 if {$row >= $numcommits} {
3351 puts "oops, inserting new row $row but only have $numcommits rows"
3352 return
3354 set p [lindex $displayorder $row]
3355 set displayorder [linsert $displayorder $row $newcmit]
3356 set parentlist [linsert $parentlist $row $p]
3357 set kids [lindex $childlist $row]
3358 lappend kids $newcmit
3359 lset childlist $row $kids
3360 set childlist [linsert $childlist $row {}]
3361 set commitlisted [linsert $commitlisted $row 1]
3362 set l [llength $displayorder]
3363 for {set r $row} {$r < $l} {incr r} {
3364 set id [lindex $displayorder $r]
3365 set commitrow($curview,$id) $r
3368 set idlist [lindex $rowidlist $row]
3369 set offs [lindex $rowoffsets $row]
3370 set newoffs {}
3371 foreach x $idlist {
3372 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3373 lappend newoffs {}
3374 } else {
3375 lappend newoffs 0
3378 if {[llength $kids] == 1} {
3379 set col [lsearch -exact $idlist $p]
3380 lset idlist $col $newcmit
3381 } else {
3382 set col [llength $idlist]
3383 lappend idlist $newcmit
3384 lappend offs {}
3385 lset rowoffsets $row $offs
3387 set rowidlist [linsert $rowidlist $row $idlist]
3388 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3390 set rowrangelist [linsert $rowrangelist $row {}]
3391 set l [llength $rowrangelist]
3392 for {set r 0} {$r < $l} {incr r} {
3393 set ranges [lindex $rowrangelist $r]
3394 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3395 set newranges {}
3396 foreach x $ranges {
3397 if {$x >= $row} {
3398 lappend newranges [expr {$x + 1}]
3399 } else {
3400 lappend newranges $x
3403 lset rowrangelist $r $newranges
3406 if {[llength $kids] > 1} {
3407 set rp1 [expr {$row + 1}]
3408 set ranges [lindex $rowrangelist $rp1]
3409 if {$ranges eq {}} {
3410 set ranges [list $row $rp1]
3411 } elseif {[lindex $ranges end-1] == $rp1} {
3412 lset ranges end-1 $row
3414 lset rowrangelist $rp1 $ranges
3416 foreach id [array names idrowranges] {
3417 set ranges $idrowranges($id)
3418 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3419 set newranges {}
3420 foreach x $ranges {
3421 if {$x >= $row} {
3422 lappend newranges [expr {$x + 1}]
3423 } else {
3424 lappend newranges $x
3427 set idrowranges($id) $newranges
3431 set linesegends [linsert $linesegends $row {}]
3433 incr rowlaidout
3434 incr rowoptim
3435 incr numcommits
3437 if {[info exists selectedline] && $selectedline >= $row} {
3438 incr selectedline
3440 redisplay
3443 # Don't change the text pane cursor if it is currently the hand cursor,
3444 # showing that we are over a sha1 ID link.
3445 proc settextcursor {c} {
3446 global ctext curtextcursor
3448 if {[$ctext cget -cursor] == $curtextcursor} {
3449 $ctext config -cursor $c
3451 set curtextcursor $c
3454 proc nowbusy {what} {
3455 global isbusy
3457 if {[array names isbusy] eq {}} {
3458 . config -cursor watch
3459 settextcursor watch
3461 set isbusy($what) 1
3464 proc notbusy {what} {
3465 global isbusy maincursor textcursor
3467 catch {unset isbusy($what)}
3468 if {[array names isbusy] eq {}} {
3469 . config -cursor $maincursor
3470 settextcursor $textcursor
3474 proc drawrest {} {
3475 global startmsecs
3476 global rowlaidout commitidx curview
3477 global pending_select
3479 set row $rowlaidout
3480 layoutrows $rowlaidout $commitidx($curview) 1
3481 layouttail
3482 optimize_rows $row 0 $commitidx($curview)
3483 showstuff $commitidx($curview)
3484 if {[info exists pending_select]} {
3485 selectline 0 1
3488 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
3489 #global numcommits
3490 #puts "overall $drawmsecs ms for $numcommits commits"
3493 proc findmatches {f} {
3494 global findtype foundstring foundstrlen
3495 if {$findtype == "Regexp"} {
3496 set matches [regexp -indices -all -inline $foundstring $f]
3497 } else {
3498 if {$findtype == "IgnCase"} {
3499 set str [string tolower $f]
3500 } else {
3501 set str $f
3503 set matches {}
3504 set i 0
3505 while {[set j [string first $foundstring $str $i]] >= 0} {
3506 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
3507 set i [expr {$j + $foundstrlen}]
3510 return $matches
3513 proc dofind {} {
3514 global findtype findloc findstring markedmatches commitinfo
3515 global numcommits displayorder linehtag linentag linedtag
3516 global mainfont canv canv2 canv3 selectedline
3517 global matchinglines foundstring foundstrlen matchstring
3518 global commitdata
3520 stopfindproc
3521 unmarkmatches
3522 cancel_next_highlight
3523 focus .
3524 set matchinglines {}
3525 if {$findtype == "IgnCase"} {
3526 set foundstring [string tolower $findstring]
3527 } else {
3528 set foundstring $findstring
3530 set foundstrlen [string length $findstring]
3531 if {$foundstrlen == 0} return
3532 regsub -all {[*?\[\\]} $foundstring {\\&} matchstring
3533 set matchstring "*$matchstring*"
3534 if {![info exists selectedline]} {
3535 set oldsel -1
3536 } else {
3537 set oldsel $selectedline
3539 set didsel 0
3540 set fldtypes {Headline Author Date Committer CDate Comments}
3541 set l -1
3542 foreach id $displayorder {
3543 set d $commitdata($id)
3544 incr l
3545 if {$findtype == "Regexp"} {
3546 set doesmatch [regexp $foundstring $d]
3547 } elseif {$findtype == "IgnCase"} {
3548 set doesmatch [string match -nocase $matchstring $d]
3549 } else {
3550 set doesmatch [string match $matchstring $d]
3552 if {!$doesmatch} continue
3553 if {![info exists commitinfo($id)]} {
3554 getcommit $id
3556 set info $commitinfo($id)
3557 set doesmatch 0
3558 foreach f $info ty $fldtypes {
3559 if {$findloc != "All fields" && $findloc != $ty} {
3560 continue
3562 set matches [findmatches $f]
3563 if {$matches == {}} continue
3564 set doesmatch 1
3565 if {$ty == "Headline"} {
3566 drawcmitrow $l
3567 markmatches $canv $l $f $linehtag($l) $matches $mainfont
3568 } elseif {$ty == "Author"} {
3569 drawcmitrow $l
3570 markmatches $canv2 $l $f $linentag($l) $matches $mainfont
3571 } elseif {$ty == "Date"} {
3572 drawcmitrow $l
3573 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
3576 if {$doesmatch} {
3577 lappend matchinglines $l
3578 if {!$didsel && $l > $oldsel} {
3579 findselectline $l
3580 set didsel 1
3584 if {$matchinglines == {}} {
3585 bell
3586 } elseif {!$didsel} {
3587 findselectline [lindex $matchinglines 0]
3591 proc findselectline {l} {
3592 global findloc commentend ctext
3593 selectline $l 1
3594 if {$findloc == "All fields" || $findloc == "Comments"} {
3595 # highlight the matches in the comments
3596 set f [$ctext get 1.0 $commentend]
3597 set matches [findmatches $f]
3598 foreach match $matches {
3599 set start [lindex $match 0]
3600 set end [expr {[lindex $match 1] + 1}]
3601 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
3606 proc findnext {restart} {
3607 global matchinglines selectedline
3608 if {![info exists matchinglines]} {
3609 if {$restart} {
3610 dofind
3612 return
3614 if {![info exists selectedline]} return
3615 foreach l $matchinglines {
3616 if {$l > $selectedline} {
3617 findselectline $l
3618 return
3621 bell
3624 proc findprev {} {
3625 global matchinglines selectedline
3626 if {![info exists matchinglines]} {
3627 dofind
3628 return
3630 if {![info exists selectedline]} return
3631 set prev {}
3632 foreach l $matchinglines {
3633 if {$l >= $selectedline} break
3634 set prev $l
3636 if {$prev != {}} {
3637 findselectline $prev
3638 } else {
3639 bell
3643 proc stopfindproc {{done 0}} {
3644 global findprocpid findprocfile findids
3645 global ctext findoldcursor phase maincursor textcursor
3646 global findinprogress
3648 catch {unset findids}
3649 if {[info exists findprocpid]} {
3650 if {!$done} {
3651 catch {exec kill $findprocpid}
3653 catch {close $findprocfile}
3654 unset findprocpid
3656 catch {unset findinprogress}
3657 notbusy find
3660 # mark a commit as matching by putting a yellow background
3661 # behind the headline
3662 proc markheadline {l id} {
3663 global canv mainfont linehtag
3665 drawcmitrow $l
3666 set bbox [$canv bbox $linehtag($l)]
3667 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
3668 $canv lower $t
3671 # mark the bits of a headline, author or date that match a find string
3672 proc markmatches {canv l str tag matches font} {
3673 set bbox [$canv bbox $tag]
3674 set x0 [lindex $bbox 0]
3675 set y0 [lindex $bbox 1]
3676 set y1 [lindex $bbox 3]
3677 foreach match $matches {
3678 set start [lindex $match 0]
3679 set end [lindex $match 1]
3680 if {$start > $end} continue
3681 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
3682 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
3683 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
3684 [expr {$x0+$xlen+2}] $y1 \
3685 -outline {} -tags matches -fill yellow]
3686 $canv lower $t
3690 proc unmarkmatches {} {
3691 global matchinglines findids
3692 allcanvs delete matches
3693 catch {unset matchinglines}
3694 catch {unset findids}
3697 proc selcanvline {w x y} {
3698 global canv canvy0 ctext linespc
3699 global rowtextx
3700 set ymax [lindex [$canv cget -scrollregion] 3]
3701 if {$ymax == {}} return
3702 set yfrac [lindex [$canv yview] 0]
3703 set y [expr {$y + $yfrac * $ymax}]
3704 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
3705 if {$l < 0} {
3706 set l 0
3708 if {$w eq $canv} {
3709 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
3711 unmarkmatches
3712 selectline $l 1
3715 proc commit_descriptor {p} {
3716 global commitinfo
3717 if {![info exists commitinfo($p)]} {
3718 getcommit $p
3720 set l "..."
3721 if {[llength $commitinfo($p)] > 1} {
3722 set l [lindex $commitinfo($p) 0]
3724 return "$p ($l)\n"
3727 # append some text to the ctext widget, and make any SHA1 ID
3728 # that we know about be a clickable link.
3729 proc appendwithlinks {text tags} {
3730 global ctext commitrow linknum curview
3732 set start [$ctext index "end - 1c"]
3733 $ctext insert end $text $tags
3734 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
3735 foreach l $links {
3736 set s [lindex $l 0]
3737 set e [lindex $l 1]
3738 set linkid [string range $text $s $e]
3739 if {![info exists commitrow($curview,$linkid)]} continue
3740 incr e
3741 $ctext tag add link "$start + $s c" "$start + $e c"
3742 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
3743 $ctext tag bind link$linknum <1> \
3744 [list selectline $commitrow($curview,$linkid) 1]
3745 incr linknum
3747 $ctext tag conf link -foreground blue -underline 1
3748 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3749 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3752 proc viewnextline {dir} {
3753 global canv linespc
3755 $canv delete hover
3756 set ymax [lindex [$canv cget -scrollregion] 3]
3757 set wnow [$canv yview]
3758 set wtop [expr {[lindex $wnow 0] * $ymax}]
3759 set newtop [expr {$wtop + $dir * $linespc}]
3760 if {$newtop < 0} {
3761 set newtop 0
3762 } elseif {$newtop > $ymax} {
3763 set newtop $ymax
3765 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3768 # add a list of tag or branch names at position pos
3769 # returns the number of names inserted
3770 proc appendrefs {pos tags var} {
3771 global ctext commitrow linknum curview $var
3773 if {[catch {$ctext index $pos}]} {
3774 return 0
3776 set tags [lsort $tags]
3777 set sep {}
3778 foreach tag $tags {
3779 set id [set $var\($tag\)]
3780 set lk link$linknum
3781 incr linknum
3782 $ctext insert $pos $sep
3783 $ctext insert $pos $tag $lk
3784 $ctext tag conf $lk -foreground blue
3785 if {[info exists commitrow($curview,$id)]} {
3786 $ctext tag bind $lk <1> \
3787 [list selectline $commitrow($curview,$id) 1]
3788 $ctext tag conf $lk -underline 1
3789 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
3790 $ctext tag bind $lk <Leave> { %W configure -cursor $curtextcursor }
3792 set sep ", "
3794 return [llength $tags]
3797 proc taglist {ids} {
3798 global idtags
3800 set tags {}
3801 foreach id $ids {
3802 foreach tag $idtags($id) {
3803 lappend tags $tag
3806 return $tags
3809 # called when we have finished computing the nearby tags
3810 proc dispneartags {} {
3811 global selectedline currentid ctext anc_tags desc_tags showneartags
3812 global desc_heads
3814 if {![info exists selectedline] || !$showneartags} return
3815 set id $currentid
3816 $ctext conf -state normal
3817 if {[info exists desc_heads($id)]} {
3818 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3819 $ctext insert "branch -2c" "es"
3822 if {[info exists anc_tags($id)]} {
3823 appendrefs follows [taglist $anc_tags($id)] tagids
3825 if {[info exists desc_tags($id)]} {
3826 appendrefs precedes [taglist $desc_tags($id)] tagids
3828 $ctext conf -state disabled
3831 proc selectline {l isnew} {
3832 global canv canv2 canv3 ctext commitinfo selectedline
3833 global displayorder linehtag linentag linedtag
3834 global canvy0 linespc parentlist childlist
3835 global currentid sha1entry
3836 global commentend idtags linknum
3837 global mergemax numcommits pending_select
3838 global cmitmode desc_tags anc_tags showneartags allcommits desc_heads
3840 catch {unset pending_select}
3841 $canv delete hover
3842 normalline
3843 cancel_next_highlight
3844 if {$l < 0 || $l >= $numcommits} return
3845 set y [expr {$canvy0 + $l * $linespc}]
3846 set ymax [lindex [$canv cget -scrollregion] 3]
3847 set ytop [expr {$y - $linespc - 1}]
3848 set ybot [expr {$y + $linespc + 1}]
3849 set wnow [$canv yview]
3850 set wtop [expr {[lindex $wnow 0] * $ymax}]
3851 set wbot [expr {[lindex $wnow 1] * $ymax}]
3852 set wh [expr {$wbot - $wtop}]
3853 set newtop $wtop
3854 if {$ytop < $wtop} {
3855 if {$ybot < $wtop} {
3856 set newtop [expr {$y - $wh / 2.0}]
3857 } else {
3858 set newtop $ytop
3859 if {$newtop > $wtop - $linespc} {
3860 set newtop [expr {$wtop - $linespc}]
3863 } elseif {$ybot > $wbot} {
3864 if {$ytop > $wbot} {
3865 set newtop [expr {$y - $wh / 2.0}]
3866 } else {
3867 set newtop [expr {$ybot - $wh}]
3868 if {$newtop < $wtop + $linespc} {
3869 set newtop [expr {$wtop + $linespc}]
3873 if {$newtop != $wtop} {
3874 if {$newtop < 0} {
3875 set newtop 0
3877 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3878 drawvisible
3881 if {![info exists linehtag($l)]} return
3882 $canv delete secsel
3883 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
3884 -tags secsel -fill [$canv cget -selectbackground]]
3885 $canv lower $t
3886 $canv2 delete secsel
3887 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
3888 -tags secsel -fill [$canv2 cget -selectbackground]]
3889 $canv2 lower $t
3890 $canv3 delete secsel
3891 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
3892 -tags secsel -fill [$canv3 cget -selectbackground]]
3893 $canv3 lower $t
3895 if {$isnew} {
3896 addtohistory [list selectline $l 0]
3899 set selectedline $l
3901 set id [lindex $displayorder $l]
3902 set currentid $id
3903 $sha1entry delete 0 end
3904 $sha1entry insert 0 $id
3905 $sha1entry selection from 0
3906 $sha1entry selection to end
3907 rhighlight_sel $id
3909 $ctext conf -state normal
3910 clear_ctext
3911 set linknum 0
3912 set info $commitinfo($id)
3913 set date [formatdate [lindex $info 2]]
3914 $ctext insert end "Author: [lindex $info 1] $date\n"
3915 set date [formatdate [lindex $info 4]]
3916 $ctext insert end "Committer: [lindex $info 3] $date\n"
3917 if {[info exists idtags($id)]} {
3918 $ctext insert end "Tags:"
3919 foreach tag $idtags($id) {
3920 $ctext insert end " $tag"
3922 $ctext insert end "\n"
3925 set headers {}
3926 set olds [lindex $parentlist $l]
3927 if {[llength $olds] > 1} {
3928 set np 0
3929 foreach p $olds {
3930 if {$np >= $mergemax} {
3931 set tag mmax
3932 } else {
3933 set tag m$np
3935 $ctext insert end "Parent: " $tag
3936 appendwithlinks [commit_descriptor $p] {}
3937 incr np
3939 } else {
3940 foreach p $olds {
3941 append headers "Parent: [commit_descriptor $p]"
3945 foreach c [lindex $childlist $l] {
3946 append headers "Child: [commit_descriptor $c]"
3949 # make anything that looks like a SHA1 ID be a clickable link
3950 appendwithlinks $headers {}
3951 if {$showneartags} {
3952 if {![info exists allcommits]} {
3953 getallcommits
3955 $ctext insert end "Branch: "
3956 $ctext mark set branch "end -1c"
3957 $ctext mark gravity branch left
3958 if {[info exists desc_heads($id)]} {
3959 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3960 # turn "Branch" into "Branches"
3961 $ctext insert "branch -2c" "es"
3964 $ctext insert end "\nFollows: "
3965 $ctext mark set follows "end -1c"
3966 $ctext mark gravity follows left
3967 if {[info exists anc_tags($id)]} {
3968 appendrefs follows [taglist $anc_tags($id)] tagids
3970 $ctext insert end "\nPrecedes: "
3971 $ctext mark set precedes "end -1c"
3972 $ctext mark gravity precedes left
3973 if {[info exists desc_tags($id)]} {
3974 appendrefs precedes [taglist $desc_tags($id)] tagids
3976 $ctext insert end "\n"
3978 $ctext insert end "\n"
3979 appendwithlinks [lindex $info 5] {comment}
3981 $ctext tag delete Comments
3982 $ctext tag remove found 1.0 end
3983 $ctext conf -state disabled
3984 set commentend [$ctext index "end - 1c"]
3986 init_flist "Comments"
3987 if {$cmitmode eq "tree"} {
3988 gettree $id
3989 } elseif {[llength $olds] <= 1} {
3990 startdiff $id
3991 } else {
3992 mergediff $id $l
3996 proc selfirstline {} {
3997 unmarkmatches
3998 selectline 0 1
4001 proc sellastline {} {
4002 global numcommits
4003 unmarkmatches
4004 set l [expr {$numcommits - 1}]
4005 selectline $l 1
4008 proc selnextline {dir} {
4009 global selectedline
4010 if {![info exists selectedline]} return
4011 set l [expr {$selectedline + $dir}]
4012 unmarkmatches
4013 selectline $l 1
4016 proc selnextpage {dir} {
4017 global canv linespc selectedline numcommits
4019 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4020 if {$lpp < 1} {
4021 set lpp 1
4023 allcanvs yview scroll [expr {$dir * $lpp}] units
4024 drawvisible
4025 if {![info exists selectedline]} return
4026 set l [expr {$selectedline + $dir * $lpp}]
4027 if {$l < 0} {
4028 set l 0
4029 } elseif {$l >= $numcommits} {
4030 set l [expr $numcommits - 1]
4032 unmarkmatches
4033 selectline $l 1
4036 proc unselectline {} {
4037 global selectedline currentid
4039 catch {unset selectedline}
4040 catch {unset currentid}
4041 allcanvs delete secsel
4042 rhighlight_none
4043 cancel_next_highlight
4046 proc reselectline {} {
4047 global selectedline
4049 if {[info exists selectedline]} {
4050 selectline $selectedline 0
4054 proc addtohistory {cmd} {
4055 global history historyindex curview
4057 set elt [list $curview $cmd]
4058 if {$historyindex > 0
4059 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4060 return
4063 if {$historyindex < [llength $history]} {
4064 set history [lreplace $history $historyindex end $elt]
4065 } else {
4066 lappend history $elt
4068 incr historyindex
4069 if {$historyindex > 1} {
4070 .tf.bar.leftbut conf -state normal
4071 } else {
4072 .tf.bar.leftbut conf -state disabled
4074 .tf.bar.rightbut conf -state disabled
4077 proc godo {elt} {
4078 global curview
4080 set view [lindex $elt 0]
4081 set cmd [lindex $elt 1]
4082 if {$curview != $view} {
4083 showview $view
4085 eval $cmd
4088 proc goback {} {
4089 global history historyindex
4091 if {$historyindex > 1} {
4092 incr historyindex -1
4093 godo [lindex $history [expr {$historyindex - 1}]]
4094 .tf.bar.rightbut conf -state normal
4096 if {$historyindex <= 1} {
4097 .tf.bar.leftbut conf -state disabled
4101 proc goforw {} {
4102 global history historyindex
4104 if {$historyindex < [llength $history]} {
4105 set cmd [lindex $history $historyindex]
4106 incr historyindex
4107 godo $cmd
4108 .tf.bar.leftbut conf -state normal
4110 if {$historyindex >= [llength $history]} {
4111 .tf.bar.rightbut conf -state disabled
4115 proc gettree {id} {
4116 global treefilelist treeidlist diffids diffmergeid treepending
4118 set diffids $id
4119 catch {unset diffmergeid}
4120 if {![info exists treefilelist($id)]} {
4121 if {![info exists treepending]} {
4122 if {[catch {set gtf [open [concat | git ls-tree -r $id] r]}]} {
4123 return
4125 set treepending $id
4126 set treefilelist($id) {}
4127 set treeidlist($id) {}
4128 fconfigure $gtf -blocking 0
4129 fileevent $gtf readable [list gettreeline $gtf $id]
4131 } else {
4132 setfilelist $id
4136 proc gettreeline {gtf id} {
4137 global treefilelist treeidlist treepending cmitmode diffids
4139 while {[gets $gtf line] >= 0} {
4140 if {[lindex $line 1] ne "blob"} continue
4141 set sha1 [lindex $line 2]
4142 set fname [lindex $line 3]
4143 lappend treefilelist($id) $fname
4144 lappend treeidlist($id) $sha1
4146 if {![eof $gtf]} return
4147 close $gtf
4148 unset treepending
4149 if {$cmitmode ne "tree"} {
4150 if {![info exists diffmergeid]} {
4151 gettreediffs $diffids
4153 } elseif {$id ne $diffids} {
4154 gettree $diffids
4155 } else {
4156 setfilelist $id
4160 proc showfile {f} {
4161 global treefilelist treeidlist diffids
4162 global ctext commentend
4164 set i [lsearch -exact $treefilelist($diffids) $f]
4165 if {$i < 0} {
4166 puts "oops, $f not in list for id $diffids"
4167 return
4169 set blob [lindex $treeidlist($diffids) $i]
4170 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4171 puts "oops, error reading blob $blob: $err"
4172 return
4174 fconfigure $bf -blocking 0
4175 fileevent $bf readable [list getblobline $bf $diffids]
4176 $ctext config -state normal
4177 clear_ctext $commentend
4178 $ctext insert end "\n"
4179 $ctext insert end "$f\n" filesep
4180 $ctext config -state disabled
4181 $ctext yview $commentend
4184 proc getblobline {bf id} {
4185 global diffids cmitmode ctext
4187 if {$id ne $diffids || $cmitmode ne "tree"} {
4188 catch {close $bf}
4189 return
4191 $ctext config -state normal
4192 while {[gets $bf line] >= 0} {
4193 $ctext insert end "$line\n"
4195 if {[eof $bf]} {
4196 # delete last newline
4197 $ctext delete "end - 2c" "end - 1c"
4198 close $bf
4200 $ctext config -state disabled
4203 proc mergediff {id l} {
4204 global diffmergeid diffopts mdifffd
4205 global diffids
4206 global parentlist
4208 set diffmergeid $id
4209 set diffids $id
4210 # this doesn't seem to actually affect anything...
4211 set env(GIT_DIFF_OPTS) $diffopts
4212 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4213 if {[catch {set mdf [open $cmd r]} err]} {
4214 error_popup "Error getting merge diffs: $err"
4215 return
4217 fconfigure $mdf -blocking 0
4218 set mdifffd($id) $mdf
4219 set np [llength [lindex $parentlist $l]]
4220 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4221 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4224 proc getmergediffline {mdf id np} {
4225 global diffmergeid ctext cflist nextupdate mergemax
4226 global difffilestart mdifffd
4228 set n [gets $mdf line]
4229 if {$n < 0} {
4230 if {[eof $mdf]} {
4231 close $mdf
4233 return
4235 if {![info exists diffmergeid] || $id != $diffmergeid
4236 || $mdf != $mdifffd($id)} {
4237 return
4239 $ctext conf -state normal
4240 if {[regexp {^diff --cc (.*)} $line match fname]} {
4241 # start of a new file
4242 $ctext insert end "\n"
4243 set here [$ctext index "end - 1c"]
4244 lappend difffilestart $here
4245 add_flist [list $fname]
4246 set l [expr {(78 - [string length $fname]) / 2}]
4247 set pad [string range "----------------------------------------" 1 $l]
4248 $ctext insert end "$pad $fname $pad\n" filesep
4249 } elseif {[regexp {^@@} $line]} {
4250 $ctext insert end "$line\n" hunksep
4251 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4252 # do nothing
4253 } else {
4254 # parse the prefix - one ' ', '-' or '+' for each parent
4255 set spaces {}
4256 set minuses {}
4257 set pluses {}
4258 set isbad 0
4259 for {set j 0} {$j < $np} {incr j} {
4260 set c [string range $line $j $j]
4261 if {$c == " "} {
4262 lappend spaces $j
4263 } elseif {$c == "-"} {
4264 lappend minuses $j
4265 } elseif {$c == "+"} {
4266 lappend pluses $j
4267 } else {
4268 set isbad 1
4269 break
4272 set tags {}
4273 set num {}
4274 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4275 # line doesn't appear in result, parents in $minuses have the line
4276 set num [lindex $minuses 0]
4277 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4278 # line appears in result, parents in $pluses don't have the line
4279 lappend tags mresult
4280 set num [lindex $spaces 0]
4282 if {$num ne {}} {
4283 if {$num >= $mergemax} {
4284 set num "max"
4286 lappend tags m$num
4288 $ctext insert end "$line\n" $tags
4290 $ctext conf -state disabled
4291 if {[clock clicks -milliseconds] >= $nextupdate} {
4292 incr nextupdate 100
4293 fileevent $mdf readable {}
4294 update
4295 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4299 proc startdiff {ids} {
4300 global treediffs diffids treepending diffmergeid
4302 set diffids $ids
4303 catch {unset diffmergeid}
4304 if {![info exists treediffs($ids)]} {
4305 if {![info exists treepending]} {
4306 gettreediffs $ids
4308 } else {
4309 addtocflist $ids
4313 proc addtocflist {ids} {
4314 global treediffs cflist
4315 add_flist $treediffs($ids)
4316 getblobdiffs $ids
4319 proc gettreediffs {ids} {
4320 global treediff treepending
4321 set treepending $ids
4322 set treediff {}
4323 if {[catch \
4324 {set gdtf [open [concat | git diff-tree --no-commit-id -r $ids] r]} \
4325 ]} return
4326 fconfigure $gdtf -blocking 0
4327 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
4330 proc gettreediffline {gdtf ids} {
4331 global treediff treediffs treepending diffids diffmergeid
4332 global cmitmode
4334 set n [gets $gdtf line]
4335 if {$n < 0} {
4336 if {![eof $gdtf]} return
4337 close $gdtf
4338 set treediffs($ids) $treediff
4339 unset treepending
4340 if {$cmitmode eq "tree"} {
4341 gettree $diffids
4342 } elseif {$ids != $diffids} {
4343 if {![info exists diffmergeid]} {
4344 gettreediffs $diffids
4346 } else {
4347 addtocflist $ids
4349 return
4351 set file [lindex $line 5]
4352 lappend treediff $file
4355 proc getblobdiffs {ids} {
4356 global diffopts blobdifffd diffids env curdifftag curtagstart
4357 global nextupdate diffinhdr treediffs
4359 set env(GIT_DIFF_OPTS) $diffopts
4360 set cmd [concat | git diff-tree --no-commit-id -r -p -C $ids]
4361 if {[catch {set bdf [open $cmd r]} err]} {
4362 puts "error getting diffs: $err"
4363 return
4365 set diffinhdr 0
4366 fconfigure $bdf -blocking 0
4367 set blobdifffd($ids) $bdf
4368 set curdifftag Comments
4369 set curtagstart 0.0
4370 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
4371 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4374 proc setinlist {var i val} {
4375 global $var
4377 while {[llength [set $var]] < $i} {
4378 lappend $var {}
4380 if {[llength [set $var]] == $i} {
4381 lappend $var $val
4382 } else {
4383 lset $var $i $val
4387 proc getblobdiffline {bdf ids} {
4388 global diffids blobdifffd ctext curdifftag curtagstart
4389 global diffnexthead diffnextnote difffilestart
4390 global nextupdate diffinhdr treediffs
4392 set n [gets $bdf line]
4393 if {$n < 0} {
4394 if {[eof $bdf]} {
4395 close $bdf
4396 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
4397 $ctext tag add $curdifftag $curtagstart end
4400 return
4402 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4403 return
4405 $ctext conf -state normal
4406 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
4407 # start of a new file
4408 $ctext insert end "\n"
4409 $ctext tag add $curdifftag $curtagstart end
4410 set here [$ctext index "end - 1c"]
4411 set curtagstart $here
4412 set header $newname
4413 set i [lsearch -exact $treediffs($ids) $fname]
4414 if {$i >= 0} {
4415 setinlist difffilestart $i $here
4417 if {$newname ne $fname} {
4418 set i [lsearch -exact $treediffs($ids) $newname]
4419 if {$i >= 0} {
4420 setinlist difffilestart $i $here
4423 set curdifftag "f:$fname"
4424 $ctext tag delete $curdifftag
4425 set l [expr {(78 - [string length $header]) / 2}]
4426 set pad [string range "----------------------------------------" 1 $l]
4427 $ctext insert end "$pad $header $pad\n" filesep
4428 set diffinhdr 1
4429 } elseif {$diffinhdr && [string compare -length 3 $line "---"] == 0} {
4430 # do nothing
4431 } elseif {$diffinhdr && [string compare -length 3 $line "+++"] == 0} {
4432 set diffinhdr 0
4433 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
4434 $line match f1l f1c f2l f2c rest]} {
4435 $ctext insert end "$line\n" hunksep
4436 set diffinhdr 0
4437 } else {
4438 set x [string range $line 0 0]
4439 if {$x == "-" || $x == "+"} {
4440 set tag [expr {$x == "+"}]
4441 $ctext insert end "$line\n" d$tag
4442 } elseif {$x == " "} {
4443 $ctext insert end "$line\n"
4444 } elseif {$diffinhdr || $x == "\\"} {
4445 # e.g. "\ No newline at end of file"
4446 $ctext insert end "$line\n" filesep
4447 } else {
4448 # Something else we don't recognize
4449 if {$curdifftag != "Comments"} {
4450 $ctext insert end "\n"
4451 $ctext tag add $curdifftag $curtagstart end
4452 set curtagstart [$ctext index "end - 1c"]
4453 set curdifftag Comments
4455 $ctext insert end "$line\n" filesep
4458 $ctext conf -state disabled
4459 if {[clock clicks -milliseconds] >= $nextupdate} {
4460 incr nextupdate 100
4461 fileevent $bdf readable {}
4462 update
4463 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
4467 proc prevfile {} {
4468 global difffilestart ctext
4469 set prev [lindex $difffilestart 0]
4470 set here [$ctext index @0,0]
4471 foreach loc $difffilestart {
4472 if {[$ctext compare $loc >= $here]} {
4473 $ctext yview $prev
4474 return
4476 set prev $loc
4478 $ctext yview $prev
4481 proc nextfile {} {
4482 global difffilestart ctext
4483 set here [$ctext index @0,0]
4484 foreach loc $difffilestart {
4485 if {[$ctext compare $loc > $here]} {
4486 $ctext yview $loc
4487 return
4492 proc clear_ctext {{first 1.0}} {
4493 global ctext smarktop smarkbot
4495 set l [lindex [split $first .] 0]
4496 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
4497 set smarktop $l
4499 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
4500 set smarkbot $l
4502 $ctext delete $first end
4505 proc incrsearch {name ix op} {
4506 global ctext searchstring searchdirn
4508 $ctext tag remove found 1.0 end
4509 if {[catch {$ctext index anchor}]} {
4510 # no anchor set, use start of selection, or of visible area
4511 set sel [$ctext tag ranges sel]
4512 if {$sel ne {}} {
4513 $ctext mark set anchor [lindex $sel 0]
4514 } elseif {$searchdirn eq "-forwards"} {
4515 $ctext mark set anchor @0,0
4516 } else {
4517 $ctext mark set anchor @0,[winfo height $ctext]
4520 if {$searchstring ne {}} {
4521 set here [$ctext search $searchdirn -- $searchstring anchor]
4522 if {$here ne {}} {
4523 $ctext see $here
4525 searchmarkvisible 1
4529 proc dosearch {} {
4530 global sstring ctext searchstring searchdirn
4532 focus $sstring
4533 $sstring icursor end
4534 set searchdirn -forwards
4535 if {$searchstring ne {}} {
4536 set sel [$ctext tag ranges sel]
4537 if {$sel ne {}} {
4538 set start "[lindex $sel 0] + 1c"
4539 } elseif {[catch {set start [$ctext index anchor]}]} {
4540 set start "@0,0"
4542 set match [$ctext search -count mlen -- $searchstring $start]
4543 $ctext tag remove sel 1.0 end
4544 if {$match eq {}} {
4545 bell
4546 return
4548 $ctext see $match
4549 set mend "$match + $mlen c"
4550 $ctext tag add sel $match $mend
4551 $ctext mark unset anchor
4555 proc dosearchback {} {
4556 global sstring ctext searchstring searchdirn
4558 focus $sstring
4559 $sstring icursor end
4560 set searchdirn -backwards
4561 if {$searchstring ne {}} {
4562 set sel [$ctext tag ranges sel]
4563 if {$sel ne {}} {
4564 set start [lindex $sel 0]
4565 } elseif {[catch {set start [$ctext index anchor]}]} {
4566 set start @0,[winfo height $ctext]
4568 set match [$ctext search -backwards -count ml -- $searchstring $start]
4569 $ctext tag remove sel 1.0 end
4570 if {$match eq {}} {
4571 bell
4572 return
4574 $ctext see $match
4575 set mend "$match + $ml c"
4576 $ctext tag add sel $match $mend
4577 $ctext mark unset anchor
4581 proc searchmark {first last} {
4582 global ctext searchstring
4584 set mend $first.0
4585 while {1} {
4586 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
4587 if {$match eq {}} break
4588 set mend "$match + $mlen c"
4589 $ctext tag add found $match $mend
4593 proc searchmarkvisible {doall} {
4594 global ctext smarktop smarkbot
4596 set topline [lindex [split [$ctext index @0,0] .] 0]
4597 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
4598 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
4599 # no overlap with previous
4600 searchmark $topline $botline
4601 set smarktop $topline
4602 set smarkbot $botline
4603 } else {
4604 if {$topline < $smarktop} {
4605 searchmark $topline [expr {$smarktop-1}]
4606 set smarktop $topline
4608 if {$botline > $smarkbot} {
4609 searchmark [expr {$smarkbot+1}] $botline
4610 set smarkbot $botline
4615 proc scrolltext {f0 f1} {
4616 global searchstring
4618 .bleft.sb set $f0 $f1
4619 if {$searchstring ne {}} {
4620 searchmarkvisible 0
4624 proc setcoords {} {
4625 global linespc charspc canvx0 canvy0 mainfont
4626 global xspc1 xspc2 lthickness
4628 set linespc [font metrics $mainfont -linespace]
4629 set charspc [font measure $mainfont "m"]
4630 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
4631 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
4632 set lthickness [expr {int($linespc / 9) + 1}]
4633 set xspc1(0) $linespc
4634 set xspc2 $linespc
4637 proc redisplay {} {
4638 global canv
4639 global selectedline
4641 set ymax [lindex [$canv cget -scrollregion] 3]
4642 if {$ymax eq {} || $ymax == 0} return
4643 set span [$canv yview]
4644 clear_display
4645 setcanvscroll
4646 allcanvs yview moveto [lindex $span 0]
4647 drawvisible
4648 if {[info exists selectedline]} {
4649 selectline $selectedline 0
4650 allcanvs yview moveto [lindex $span 0]
4654 proc incrfont {inc} {
4655 global mainfont textfont ctext canv phase
4656 global stopped entries
4657 unmarkmatches
4658 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
4659 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
4660 setcoords
4661 $ctext conf -font $textfont
4662 $ctext tag conf filesep -font [concat $textfont bold]
4663 foreach e $entries {
4664 $e conf -font $mainfont
4666 if {$phase eq "getcommits"} {
4667 $canv itemconf textitems -font $mainfont
4669 redisplay
4672 proc clearsha1 {} {
4673 global sha1entry sha1string
4674 if {[string length $sha1string] == 40} {
4675 $sha1entry delete 0 end
4679 proc sha1change {n1 n2 op} {
4680 global sha1string currentid sha1but
4681 if {$sha1string == {}
4682 || ([info exists currentid] && $sha1string == $currentid)} {
4683 set state disabled
4684 } else {
4685 set state normal
4687 if {[$sha1but cget -state] == $state} return
4688 if {$state == "normal"} {
4689 $sha1but conf -state normal -relief raised -text "Goto: "
4690 } else {
4691 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
4695 proc gotocommit {} {
4696 global sha1string currentid commitrow tagids headids
4697 global displayorder numcommits curview
4699 if {$sha1string == {}
4700 || ([info exists currentid] && $sha1string == $currentid)} return
4701 if {[info exists tagids($sha1string)]} {
4702 set id $tagids($sha1string)
4703 } elseif {[info exists headids($sha1string)]} {
4704 set id $headids($sha1string)
4705 } else {
4706 set id [string tolower $sha1string]
4707 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
4708 set matches {}
4709 foreach i $displayorder {
4710 if {[string match $id* $i]} {
4711 lappend matches $i
4714 if {$matches ne {}} {
4715 if {[llength $matches] > 1} {
4716 error_popup "Short SHA1 id $id is ambiguous"
4717 return
4719 set id [lindex $matches 0]
4723 if {[info exists commitrow($curview,$id)]} {
4724 selectline $commitrow($curview,$id) 1
4725 return
4727 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
4728 set type "SHA1 id"
4729 } else {
4730 set type "Tag/Head"
4732 error_popup "$type $sha1string is not known"
4735 proc lineenter {x y id} {
4736 global hoverx hovery hoverid hovertimer
4737 global commitinfo canv
4739 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4740 set hoverx $x
4741 set hovery $y
4742 set hoverid $id
4743 if {[info exists hovertimer]} {
4744 after cancel $hovertimer
4746 set hovertimer [after 500 linehover]
4747 $canv delete hover
4750 proc linemotion {x y id} {
4751 global hoverx hovery hoverid hovertimer
4753 if {[info exists hoverid] && $id == $hoverid} {
4754 set hoverx $x
4755 set hovery $y
4756 if {[info exists hovertimer]} {
4757 after cancel $hovertimer
4759 set hovertimer [after 500 linehover]
4763 proc lineleave {id} {
4764 global hoverid hovertimer canv
4766 if {[info exists hoverid] && $id == $hoverid} {
4767 $canv delete hover
4768 if {[info exists hovertimer]} {
4769 after cancel $hovertimer
4770 unset hovertimer
4772 unset hoverid
4776 proc linehover {} {
4777 global hoverx hovery hoverid hovertimer
4778 global canv linespc lthickness
4779 global commitinfo mainfont
4781 set text [lindex $commitinfo($hoverid) 0]
4782 set ymax [lindex [$canv cget -scrollregion] 3]
4783 if {$ymax == {}} return
4784 set yfrac [lindex [$canv yview] 0]
4785 set x [expr {$hoverx + 2 * $linespc}]
4786 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
4787 set x0 [expr {$x - 2 * $lthickness}]
4788 set y0 [expr {$y - 2 * $lthickness}]
4789 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
4790 set y1 [expr {$y + $linespc + 2 * $lthickness}]
4791 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
4792 -fill \#ffff80 -outline black -width 1 -tags hover]
4793 $canv raise $t
4794 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
4795 -font $mainfont]
4796 $canv raise $t
4799 proc clickisonarrow {id y} {
4800 global lthickness
4802 set ranges [rowranges $id]
4803 set thresh [expr {2 * $lthickness + 6}]
4804 set n [expr {[llength $ranges] - 1}]
4805 for {set i 1} {$i < $n} {incr i} {
4806 set row [lindex $ranges $i]
4807 if {abs([yc $row] - $y) < $thresh} {
4808 return $i
4811 return {}
4814 proc arrowjump {id n y} {
4815 global canv
4817 # 1 <-> 2, 3 <-> 4, etc...
4818 set n [expr {(($n - 1) ^ 1) + 1}]
4819 set row [lindex [rowranges $id] $n]
4820 set yt [yc $row]
4821 set ymax [lindex [$canv cget -scrollregion] 3]
4822 if {$ymax eq {} || $ymax <= 0} return
4823 set view [$canv yview]
4824 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
4825 set yfrac [expr {$yt / $ymax - $yspan / 2}]
4826 if {$yfrac < 0} {
4827 set yfrac 0
4829 allcanvs yview moveto $yfrac
4832 proc lineclick {x y id isnew} {
4833 global ctext commitinfo children canv thickerline curview
4835 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4836 unmarkmatches
4837 unselectline
4838 normalline
4839 $canv delete hover
4840 # draw this line thicker than normal
4841 set thickerline $id
4842 drawlines $id
4843 if {$isnew} {
4844 set ymax [lindex [$canv cget -scrollregion] 3]
4845 if {$ymax eq {}} return
4846 set yfrac [lindex [$canv yview] 0]
4847 set y [expr {$y + $yfrac * $ymax}]
4849 set dirn [clickisonarrow $id $y]
4850 if {$dirn ne {}} {
4851 arrowjump $id $dirn $y
4852 return
4855 if {$isnew} {
4856 addtohistory [list lineclick $x $y $id 0]
4858 # fill the details pane with info about this line
4859 $ctext conf -state normal
4860 clear_ctext
4861 $ctext tag conf link -foreground blue -underline 1
4862 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4863 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4864 $ctext insert end "Parent:\t"
4865 $ctext insert end $id [list link link0]
4866 $ctext tag bind link0 <1> [list selbyid $id]
4867 set info $commitinfo($id)
4868 $ctext insert end "\n\t[lindex $info 0]\n"
4869 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
4870 set date [formatdate [lindex $info 2]]
4871 $ctext insert end "\tDate:\t$date\n"
4872 set kids $children($curview,$id)
4873 if {$kids ne {}} {
4874 $ctext insert end "\nChildren:"
4875 set i 0
4876 foreach child $kids {
4877 incr i
4878 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
4879 set info $commitinfo($child)
4880 $ctext insert end "\n\t"
4881 $ctext insert end $child [list link link$i]
4882 $ctext tag bind link$i <1> [list selbyid $child]
4883 $ctext insert end "\n\t[lindex $info 0]"
4884 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
4885 set date [formatdate [lindex $info 2]]
4886 $ctext insert end "\n\tDate:\t$date\n"
4889 $ctext conf -state disabled
4890 init_flist {}
4893 proc normalline {} {
4894 global thickerline
4895 if {[info exists thickerline]} {
4896 set id $thickerline
4897 unset thickerline
4898 drawlines $id
4902 proc selbyid {id} {
4903 global commitrow curview
4904 if {[info exists commitrow($curview,$id)]} {
4905 selectline $commitrow($curview,$id) 1
4909 proc mstime {} {
4910 global startmstime
4911 if {![info exists startmstime]} {
4912 set startmstime [clock clicks -milliseconds]
4914 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
4917 proc rowmenu {x y id} {
4918 global rowctxmenu commitrow selectedline rowmenuid curview
4920 if {![info exists selectedline]
4921 || $commitrow($curview,$id) eq $selectedline} {
4922 set state disabled
4923 } else {
4924 set state normal
4926 $rowctxmenu entryconfigure "Diff this*" -state $state
4927 $rowctxmenu entryconfigure "Diff selected*" -state $state
4928 $rowctxmenu entryconfigure "Make patch" -state $state
4929 set rowmenuid $id
4930 tk_popup $rowctxmenu $x $y
4933 proc diffvssel {dirn} {
4934 global rowmenuid selectedline displayorder
4936 if {![info exists selectedline]} return
4937 if {$dirn} {
4938 set oldid [lindex $displayorder $selectedline]
4939 set newid $rowmenuid
4940 } else {
4941 set oldid $rowmenuid
4942 set newid [lindex $displayorder $selectedline]
4944 addtohistory [list doseldiff $oldid $newid]
4945 doseldiff $oldid $newid
4948 proc doseldiff {oldid newid} {
4949 global ctext
4950 global commitinfo
4952 $ctext conf -state normal
4953 clear_ctext
4954 init_flist "Top"
4955 $ctext insert end "From "
4956 $ctext tag conf link -foreground blue -underline 1
4957 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4958 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4959 $ctext tag bind link0 <1> [list selbyid $oldid]
4960 $ctext insert end $oldid [list link link0]
4961 $ctext insert end "\n "
4962 $ctext insert end [lindex $commitinfo($oldid) 0]
4963 $ctext insert end "\n\nTo "
4964 $ctext tag bind link1 <1> [list selbyid $newid]
4965 $ctext insert end $newid [list link link1]
4966 $ctext insert end "\n "
4967 $ctext insert end [lindex $commitinfo($newid) 0]
4968 $ctext insert end "\n"
4969 $ctext conf -state disabled
4970 $ctext tag delete Comments
4971 $ctext tag remove found 1.0 end
4972 startdiff [list $oldid $newid]
4975 proc mkpatch {} {
4976 global rowmenuid currentid commitinfo patchtop patchnum
4978 if {![info exists currentid]} return
4979 set oldid $currentid
4980 set oldhead [lindex $commitinfo($oldid) 0]
4981 set newid $rowmenuid
4982 set newhead [lindex $commitinfo($newid) 0]
4983 set top .patch
4984 set patchtop $top
4985 catch {destroy $top}
4986 toplevel $top
4987 label $top.title -text "Generate patch"
4988 grid $top.title - -pady 10
4989 label $top.from -text "From:"
4990 entry $top.fromsha1 -width 40 -relief flat
4991 $top.fromsha1 insert 0 $oldid
4992 $top.fromsha1 conf -state readonly
4993 grid $top.from $top.fromsha1 -sticky w
4994 entry $top.fromhead -width 60 -relief flat
4995 $top.fromhead insert 0 $oldhead
4996 $top.fromhead conf -state readonly
4997 grid x $top.fromhead -sticky w
4998 label $top.to -text "To:"
4999 entry $top.tosha1 -width 40 -relief flat
5000 $top.tosha1 insert 0 $newid
5001 $top.tosha1 conf -state readonly
5002 grid $top.to $top.tosha1 -sticky w
5003 entry $top.tohead -width 60 -relief flat
5004 $top.tohead insert 0 $newhead
5005 $top.tohead conf -state readonly
5006 grid x $top.tohead -sticky w
5007 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5008 grid $top.rev x -pady 10
5009 label $top.flab -text "Output file:"
5010 entry $top.fname -width 60
5011 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5012 incr patchnum
5013 grid $top.flab $top.fname -sticky w
5014 frame $top.buts
5015 button $top.buts.gen -text "Generate" -command mkpatchgo
5016 button $top.buts.can -text "Cancel" -command mkpatchcan
5017 grid $top.buts.gen $top.buts.can
5018 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5019 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5020 grid $top.buts - -pady 10 -sticky ew
5021 focus $top.fname
5024 proc mkpatchrev {} {
5025 global patchtop
5027 set oldid [$patchtop.fromsha1 get]
5028 set oldhead [$patchtop.fromhead get]
5029 set newid [$patchtop.tosha1 get]
5030 set newhead [$patchtop.tohead get]
5031 foreach e [list fromsha1 fromhead tosha1 tohead] \
5032 v [list $newid $newhead $oldid $oldhead] {
5033 $patchtop.$e conf -state normal
5034 $patchtop.$e delete 0 end
5035 $patchtop.$e insert 0 $v
5036 $patchtop.$e conf -state readonly
5040 proc mkpatchgo {} {
5041 global patchtop
5043 set oldid [$patchtop.fromsha1 get]
5044 set newid [$patchtop.tosha1 get]
5045 set fname [$patchtop.fname get]
5046 if {[catch {exec git diff-tree -p $oldid $newid >$fname &} err]} {
5047 error_popup "Error creating patch: $err"
5049 catch {destroy $patchtop}
5050 unset patchtop
5053 proc mkpatchcan {} {
5054 global patchtop
5056 catch {destroy $patchtop}
5057 unset patchtop
5060 proc mktag {} {
5061 global rowmenuid mktagtop commitinfo
5063 set top .maketag
5064 set mktagtop $top
5065 catch {destroy $top}
5066 toplevel $top
5067 label $top.title -text "Create tag"
5068 grid $top.title - -pady 10
5069 label $top.id -text "ID:"
5070 entry $top.sha1 -width 40 -relief flat
5071 $top.sha1 insert 0 $rowmenuid
5072 $top.sha1 conf -state readonly
5073 grid $top.id $top.sha1 -sticky w
5074 entry $top.head -width 60 -relief flat
5075 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5076 $top.head conf -state readonly
5077 grid x $top.head -sticky w
5078 label $top.tlab -text "Tag name:"
5079 entry $top.tag -width 60
5080 grid $top.tlab $top.tag -sticky w
5081 frame $top.buts
5082 button $top.buts.gen -text "Create" -command mktaggo
5083 button $top.buts.can -text "Cancel" -command mktagcan
5084 grid $top.buts.gen $top.buts.can
5085 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5086 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5087 grid $top.buts - -pady 10 -sticky ew
5088 focus $top.tag
5091 proc domktag {} {
5092 global mktagtop env tagids idtags
5094 set id [$mktagtop.sha1 get]
5095 set tag [$mktagtop.tag get]
5096 if {$tag == {}} {
5097 error_popup "No tag name specified"
5098 return
5100 if {[info exists tagids($tag)]} {
5101 error_popup "Tag \"$tag\" already exists"
5102 return
5104 if {[catch {
5105 set dir [gitdir]
5106 set fname [file join $dir "refs/tags" $tag]
5107 set f [open $fname w]
5108 puts $f $id
5109 close $f
5110 } err]} {
5111 error_popup "Error creating tag: $err"
5112 return
5115 set tagids($tag) $id
5116 lappend idtags($id) $tag
5117 redrawtags $id
5118 addedtag $id
5121 proc redrawtags {id} {
5122 global canv linehtag commitrow idpos selectedline curview
5123 global mainfont canvxmax
5125 if {![info exists commitrow($curview,$id)]} return
5126 drawcmitrow $commitrow($curview,$id)
5127 $canv delete tag.$id
5128 set xt [eval drawtags $id $idpos($id)]
5129 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5130 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5131 set xr [expr {$xt + [font measure $mainfont $text]}]
5132 if {$xr > $canvxmax} {
5133 set canvxmax $xr
5134 setcanvscroll
5136 if {[info exists selectedline]
5137 && $selectedline == $commitrow($curview,$id)} {
5138 selectline $selectedline 0
5142 proc mktagcan {} {
5143 global mktagtop
5145 catch {destroy $mktagtop}
5146 unset mktagtop
5149 proc mktaggo {} {
5150 domktag
5151 mktagcan
5154 proc writecommit {} {
5155 global rowmenuid wrcomtop commitinfo wrcomcmd
5157 set top .writecommit
5158 set wrcomtop $top
5159 catch {destroy $top}
5160 toplevel $top
5161 label $top.title -text "Write commit to file"
5162 grid $top.title - -pady 10
5163 label $top.id -text "ID:"
5164 entry $top.sha1 -width 40 -relief flat
5165 $top.sha1 insert 0 $rowmenuid
5166 $top.sha1 conf -state readonly
5167 grid $top.id $top.sha1 -sticky w
5168 entry $top.head -width 60 -relief flat
5169 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5170 $top.head conf -state readonly
5171 grid x $top.head -sticky w
5172 label $top.clab -text "Command:"
5173 entry $top.cmd -width 60 -textvariable wrcomcmd
5174 grid $top.clab $top.cmd -sticky w -pady 10
5175 label $top.flab -text "Output file:"
5176 entry $top.fname -width 60
5177 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5178 grid $top.flab $top.fname -sticky w
5179 frame $top.buts
5180 button $top.buts.gen -text "Write" -command wrcomgo
5181 button $top.buts.can -text "Cancel" -command wrcomcan
5182 grid $top.buts.gen $top.buts.can
5183 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5184 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5185 grid $top.buts - -pady 10 -sticky ew
5186 focus $top.fname
5189 proc wrcomgo {} {
5190 global wrcomtop
5192 set id [$wrcomtop.sha1 get]
5193 set cmd "echo $id | [$wrcomtop.cmd get]"
5194 set fname [$wrcomtop.fname get]
5195 if {[catch {exec sh -c $cmd >$fname &} err]} {
5196 error_popup "Error writing commit: $err"
5198 catch {destroy $wrcomtop}
5199 unset wrcomtop
5202 proc wrcomcan {} {
5203 global wrcomtop
5205 catch {destroy $wrcomtop}
5206 unset wrcomtop
5209 proc mkbranch {} {
5210 global rowmenuid mkbrtop
5212 set top .makebranch
5213 catch {destroy $top}
5214 toplevel $top
5215 label $top.title -text "Create new branch"
5216 grid $top.title - -pady 10
5217 label $top.id -text "ID:"
5218 entry $top.sha1 -width 40 -relief flat
5219 $top.sha1 insert 0 $rowmenuid
5220 $top.sha1 conf -state readonly
5221 grid $top.id $top.sha1 -sticky w
5222 label $top.nlab -text "Name:"
5223 entry $top.name -width 40
5224 grid $top.nlab $top.name -sticky w
5225 frame $top.buts
5226 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5227 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5228 grid $top.buts.go $top.buts.can
5229 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5230 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5231 grid $top.buts - -pady 10 -sticky ew
5232 focus $top.name
5235 proc mkbrgo {top} {
5236 global headids idheads
5238 set name [$top.name get]
5239 set id [$top.sha1 get]
5240 if {$name eq {}} {
5241 error_popup "Please specify a name for the new branch"
5242 return
5244 catch {destroy $top}
5245 nowbusy newbranch
5246 update
5247 if {[catch {
5248 exec git branch $name $id
5249 } err]} {
5250 notbusy newbranch
5251 error_popup $err
5252 } else {
5253 addedhead $id $name
5254 # XXX should update list of heads displayed for selected commit
5255 notbusy newbranch
5256 redrawtags $id
5260 proc cherrypick {} {
5261 global rowmenuid curview commitrow
5262 global mainhead desc_heads anc_tags desc_tags allparents allchildren
5264 if {[info exists desc_heads($rowmenuid)]
5265 && [lsearch -exact $desc_heads($rowmenuid) $mainhead] >= 0} {
5266 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5267 included in branch $mainhead -- really re-apply it?"]
5268 if {!$ok} return
5270 nowbusy cherrypick
5271 update
5272 set oldhead [exec git rev-parse HEAD]
5273 # Unfortunately git-cherry-pick writes stuff to stderr even when
5274 # no error occurs, and exec takes that as an indication of error...
5275 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5276 notbusy cherrypick
5277 error_popup $err
5278 return
5280 set newhead [exec git rev-parse HEAD]
5281 if {$newhead eq $oldhead} {
5282 notbusy cherrypick
5283 error_popup "No changes committed"
5284 return
5286 set allparents($newhead) $oldhead
5287 lappend allchildren($oldhead) $newhead
5288 set desc_heads($newhead) $mainhead
5289 if {[info exists anc_tags($oldhead)]} {
5290 set anc_tags($newhead) $anc_tags($oldhead)
5292 set desc_tags($newhead) {}
5293 if {[info exists commitrow($curview,$oldhead)]} {
5294 insertrow $commitrow($curview,$oldhead) $newhead
5295 if {$mainhead ne {}} {
5296 movedhead $newhead $mainhead
5298 redrawtags $oldhead
5299 redrawtags $newhead
5301 notbusy cherrypick
5304 # context menu for a head
5305 proc headmenu {x y id head} {
5306 global headmenuid headmenuhead headctxmenu
5308 set headmenuid $id
5309 set headmenuhead $head
5310 tk_popup $headctxmenu $x $y
5313 proc cobranch {} {
5314 global headmenuid headmenuhead mainhead headids
5316 # check the tree is clean first??
5317 set oldmainhead $mainhead
5318 nowbusy checkout
5319 update
5320 if {[catch {
5321 exec git checkout $headmenuhead
5322 } err]} {
5323 notbusy checkout
5324 error_popup $err
5325 } else {
5326 notbusy checkout
5327 set mainhead $headmenuhead
5328 if {[info exists headids($oldmainhead)]} {
5329 redrawtags $headids($oldmainhead)
5331 redrawtags $headmenuid
5335 proc rmbranch {} {
5336 global desc_heads headmenuid headmenuhead mainhead
5337 global headids idheads
5339 set head $headmenuhead
5340 set id $headmenuid
5341 if {$head eq $mainhead} {
5342 error_popup "Cannot delete the currently checked-out branch"
5343 return
5345 if {$desc_heads($id) eq $head} {
5346 # the stuff on this branch isn't on any other branch
5347 if {![confirm_popup "The commits on branch $head aren't on any other\
5348 branch.\nReally delete branch $head?"]} return
5350 nowbusy rmbranch
5351 update
5352 if {[catch {exec git branch -D $head} err]} {
5353 notbusy rmbranch
5354 error_popup $err
5355 return
5357 removedhead $id $head
5358 redrawtags $id
5359 notbusy rmbranch
5362 # Stuff for finding nearby tags
5363 proc getallcommits {} {
5364 global allcstart allcommits allcfd allids
5366 set allids {}
5367 set fd [open [concat | git rev-list --all --topo-order --parents] r]
5368 set allcfd $fd
5369 fconfigure $fd -blocking 0
5370 set allcommits "reading"
5371 nowbusy allcommits
5372 restartgetall $fd
5375 proc discardallcommits {} {
5376 global allparents allchildren allcommits allcfd
5377 global desc_tags anc_tags alldtags tagisdesc allids desc_heads
5379 if {![info exists allcommits]} return
5380 if {$allcommits eq "reading"} {
5381 catch {close $allcfd}
5383 foreach v {allcommits allchildren allparents allids desc_tags anc_tags
5384 alldtags tagisdesc desc_heads} {
5385 catch {unset $v}
5389 proc restartgetall {fd} {
5390 global allcstart
5392 fileevent $fd readable [list getallclines $fd]
5393 set allcstart [clock clicks -milliseconds]
5396 proc combine_dtags {l1 l2} {
5397 global tagisdesc notfirstd
5399 set res [lsort -unique [concat $l1 $l2]]
5400 for {set i 0} {$i < [llength $res]} {incr i} {
5401 set x [lindex $res $i]
5402 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5403 set y [lindex $res $j]
5404 if {[info exists tagisdesc($x,$y)]} {
5405 if {$tagisdesc($x,$y) > 0} {
5406 # x is a descendent of y, exclude x
5407 set res [lreplace $res $i $i]
5408 incr i -1
5409 break
5410 } else {
5411 # y is a descendent of x, exclude y
5412 set res [lreplace $res $j $j]
5414 } else {
5415 # no relation, keep going
5416 incr j
5420 return $res
5423 proc combine_atags {l1 l2} {
5424 global tagisdesc
5426 set res [lsort -unique [concat $l1 $l2]]
5427 for {set i 0} {$i < [llength $res]} {incr i} {
5428 set x [lindex $res $i]
5429 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5430 set y [lindex $res $j]
5431 if {[info exists tagisdesc($x,$y)]} {
5432 if {$tagisdesc($x,$y) < 0} {
5433 # x is an ancestor of y, exclude x
5434 set res [lreplace $res $i $i]
5435 incr i -1
5436 break
5437 } else {
5438 # y is an ancestor of x, exclude y
5439 set res [lreplace $res $j $j]
5441 } else {
5442 # no relation, keep going
5443 incr j
5447 return $res
5450 proc forward_pass {id children} {
5451 global idtags desc_tags idheads desc_heads alldtags tagisdesc
5453 set dtags {}
5454 set dheads {}
5455 foreach child $children {
5456 if {[info exists idtags($child)]} {
5457 set ctags [list $child]
5458 } else {
5459 set ctags $desc_tags($child)
5461 if {$dtags eq {}} {
5462 set dtags $ctags
5463 } elseif {$ctags ne $dtags} {
5464 set dtags [combine_dtags $dtags $ctags]
5466 set cheads $desc_heads($child)
5467 if {$dheads eq {}} {
5468 set dheads $cheads
5469 } elseif {$cheads ne $dheads} {
5470 set dheads [lsort -unique [concat $dheads $cheads]]
5473 set desc_tags($id) $dtags
5474 if {[info exists idtags($id)]} {
5475 set adt $dtags
5476 foreach tag $dtags {
5477 set adt [concat $adt $alldtags($tag)]
5479 set adt [lsort -unique $adt]
5480 set alldtags($id) $adt
5481 foreach tag $adt {
5482 set tagisdesc($id,$tag) -1
5483 set tagisdesc($tag,$id) 1
5486 if {[info exists idheads($id)]} {
5487 set dheads [concat $dheads $idheads($id)]
5489 set desc_heads($id) $dheads
5492 proc getallclines {fd} {
5493 global allparents allchildren allcommits allcstart
5494 global desc_tags anc_tags idtags tagisdesc allids
5495 global idheads travindex
5497 while {[gets $fd line] >= 0} {
5498 set id [lindex $line 0]
5499 lappend allids $id
5500 set olds [lrange $line 1 end]
5501 set allparents($id) $olds
5502 if {![info exists allchildren($id)]} {
5503 set allchildren($id) {}
5505 foreach p $olds {
5506 lappend allchildren($p) $id
5508 # compute nearest tagged descendents as we go
5509 # also compute descendent heads
5510 forward_pass $id $allchildren($id)
5511 if {[clock clicks -milliseconds] - $allcstart >= 50} {
5512 fileevent $fd readable {}
5513 after idle restartgetall $fd
5514 return
5517 if {[eof $fd]} {
5518 set travindex [llength $allids]
5519 set allcommits "traversing"
5520 after idle restartatags
5521 if {[catch {close $fd} err]} {
5522 error_popup "Error reading full commit graph: $err.\n\
5523 Results may be incomplete."
5528 # walk backward through the tree and compute nearest tagged ancestors
5529 proc restartatags {} {
5530 global allids allparents idtags anc_tags travindex
5532 set t0 [clock clicks -milliseconds]
5533 set i $travindex
5534 while {[incr i -1] >= 0} {
5535 set id [lindex $allids $i]
5536 set atags {}
5537 foreach p $allparents($id) {
5538 if {[info exists idtags($p)]} {
5539 set ptags [list $p]
5540 } else {
5541 set ptags $anc_tags($p)
5543 if {$atags eq {}} {
5544 set atags $ptags
5545 } elseif {$ptags ne $atags} {
5546 set atags [combine_atags $atags $ptags]
5549 set anc_tags($id) $atags
5550 if {[clock clicks -milliseconds] - $t0 >= 50} {
5551 set travindex $i
5552 after idle restartatags
5553 return
5556 set allcommits "done"
5557 set travindex 0
5558 notbusy allcommits
5559 dispneartags
5562 # update the desc_tags and anc_tags arrays for a new tag just added
5563 proc addedtag {id} {
5564 global desc_tags anc_tags allparents allchildren allcommits
5565 global idtags tagisdesc alldtags
5567 if {![info exists desc_tags($id)]} return
5568 set adt $desc_tags($id)
5569 foreach t $desc_tags($id) {
5570 set adt [concat $adt $alldtags($t)]
5572 set adt [lsort -unique $adt]
5573 set alldtags($id) $adt
5574 foreach t $adt {
5575 set tagisdesc($id,$t) -1
5576 set tagisdesc($t,$id) 1
5578 if {[info exists anc_tags($id)]} {
5579 set todo $anc_tags($id)
5580 while {$todo ne {}} {
5581 set do [lindex $todo 0]
5582 set todo [lrange $todo 1 end]
5583 if {[info exists tagisdesc($id,$do)]} continue
5584 set tagisdesc($do,$id) -1
5585 set tagisdesc($id,$do) 1
5586 if {[info exists anc_tags($do)]} {
5587 set todo [concat $todo $anc_tags($do)]
5592 set lastold $desc_tags($id)
5593 set lastnew [list $id]
5594 set nup 0
5595 set nch 0
5596 set todo $allparents($id)
5597 while {$todo ne {}} {
5598 set do [lindex $todo 0]
5599 set todo [lrange $todo 1 end]
5600 if {![info exists desc_tags($do)]} continue
5601 if {$desc_tags($do) ne $lastold} {
5602 set lastold $desc_tags($do)
5603 set lastnew [combine_dtags $lastold [list $id]]
5604 incr nch
5606 if {$lastold eq $lastnew} continue
5607 set desc_tags($do) $lastnew
5608 incr nup
5609 if {![info exists idtags($do)]} {
5610 set todo [concat $todo $allparents($do)]
5614 if {![info exists anc_tags($id)]} return
5615 set lastold $anc_tags($id)
5616 set lastnew [list $id]
5617 set nup 0
5618 set nch 0
5619 set todo $allchildren($id)
5620 while {$todo ne {}} {
5621 set do [lindex $todo 0]
5622 set todo [lrange $todo 1 end]
5623 if {![info exists anc_tags($do)]} continue
5624 if {$anc_tags($do) ne $lastold} {
5625 set lastold $anc_tags($do)
5626 set lastnew [combine_atags $lastold [list $id]]
5627 incr nch
5629 if {$lastold eq $lastnew} continue
5630 set anc_tags($do) $lastnew
5631 incr nup
5632 if {![info exists idtags($do)]} {
5633 set todo [concat $todo $allchildren($do)]
5638 # update the desc_heads array for a new head just added
5639 proc addedhead {hid head} {
5640 global desc_heads allparents headids idheads
5642 set headids($head) $hid
5643 lappend idheads($hid) $head
5645 set todo [list $hid]
5646 while {$todo ne {}} {
5647 set do [lindex $todo 0]
5648 set todo [lrange $todo 1 end]
5649 if {![info exists desc_heads($do)] ||
5650 [lsearch -exact $desc_heads($do) $head] >= 0} continue
5651 set oldheads $desc_heads($do)
5652 lappend desc_heads($do) $head
5653 set heads $desc_heads($do)
5654 while {1} {
5655 set p $allparents($do)
5656 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5657 $desc_heads($p) ne $oldheads} break
5658 set do $p
5659 set desc_heads($do) $heads
5661 set todo [concat $todo $p]
5665 # update the desc_heads array for a head just removed
5666 proc removedhead {hid head} {
5667 global desc_heads allparents headids idheads
5669 unset headids($head)
5670 if {$idheads($hid) eq $head} {
5671 unset idheads($hid)
5672 } else {
5673 set i [lsearch -exact $idheads($hid) $head]
5674 if {$i >= 0} {
5675 set idheads($hid) [lreplace $idheads($hid) $i $i]
5679 set todo [list $hid]
5680 while {$todo ne {}} {
5681 set do [lindex $todo 0]
5682 set todo [lrange $todo 1 end]
5683 if {![info exists desc_heads($do)]} continue
5684 set i [lsearch -exact $desc_heads($do) $head]
5685 if {$i < 0} continue
5686 set oldheads $desc_heads($do)
5687 set heads [lreplace $desc_heads($do) $i $i]
5688 while {1} {
5689 set desc_heads($do) $heads
5690 set p $allparents($do)
5691 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5692 $desc_heads($p) ne $oldheads} break
5693 set do $p
5695 set todo [concat $todo $p]
5699 # update things for a head moved to a child of its previous location
5700 proc movedhead {id name} {
5701 global headids idheads
5703 set oldid $headids($name)
5704 set headids($name) $id
5705 if {$idheads($oldid) eq $name} {
5706 unset idheads($oldid)
5707 } else {
5708 set i [lsearch -exact $idheads($oldid) $name]
5709 if {$i >= 0} {
5710 set idheads($oldid) [lreplace $idheads($oldid) $i $i]
5713 lappend idheads($id) $name
5716 proc changedrefs {} {
5717 global desc_heads desc_tags anc_tags allcommits allids
5718 global allchildren allparents idtags travindex
5720 if {![info exists allcommits]} return
5721 catch {unset desc_heads}
5722 catch {unset desc_tags}
5723 catch {unset anc_tags}
5724 catch {unset alldtags}
5725 catch {unset tagisdesc}
5726 foreach id $allids {
5727 forward_pass $id $allchildren($id)
5729 if {$allcommits ne "reading"} {
5730 set travindex [llength $allids]
5731 if {$allcommits ne "traversing"} {
5732 set allcommits "traversing"
5733 after idle restartatags
5738 proc rereadrefs {} {
5739 global idtags idheads idotherrefs mainhead
5741 set refids [concat [array names idtags] \
5742 [array names idheads] [array names idotherrefs]]
5743 foreach id $refids {
5744 if {![info exists ref($id)]} {
5745 set ref($id) [listrefs $id]
5748 set oldmainhead $mainhead
5749 readrefs
5750 changedrefs
5751 set refids [lsort -unique [concat $refids [array names idtags] \
5752 [array names idheads] [array names idotherrefs]]]
5753 foreach id $refids {
5754 set v [listrefs $id]
5755 if {![info exists ref($id)] || $ref($id) != $v ||
5756 ($id eq $oldmainhead && $id ne $mainhead) ||
5757 ($id eq $mainhead && $id ne $oldmainhead)} {
5758 redrawtags $id
5763 proc listrefs {id} {
5764 global idtags idheads idotherrefs
5766 set x {}
5767 if {[info exists idtags($id)]} {
5768 set x $idtags($id)
5770 set y {}
5771 if {[info exists idheads($id)]} {
5772 set y $idheads($id)
5774 set z {}
5775 if {[info exists idotherrefs($id)]} {
5776 set z $idotherrefs($id)
5778 return [list $x $y $z]
5781 proc showtag {tag isnew} {
5782 global ctext tagcontents tagids linknum
5784 if {$isnew} {
5785 addtohistory [list showtag $tag 0]
5787 $ctext conf -state normal
5788 clear_ctext
5789 set linknum 0
5790 if {[info exists tagcontents($tag)]} {
5791 set text $tagcontents($tag)
5792 } else {
5793 set text "Tag: $tag\nId: $tagids($tag)"
5795 appendwithlinks $text {}
5796 $ctext conf -state disabled
5797 init_flist {}
5800 proc doquit {} {
5801 global stopped
5802 set stopped 100
5803 destroy .
5806 proc doprefs {} {
5807 global maxwidth maxgraphpct diffopts
5808 global oldprefs prefstop showneartags
5809 global bgcolor fgcolor ctext diffcolors
5811 set top .gitkprefs
5812 set prefstop $top
5813 if {[winfo exists $top]} {
5814 raise $top
5815 return
5817 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5818 set oldprefs($v) [set $v]
5820 toplevel $top
5821 wm title $top "Gitk preferences"
5822 label $top.ldisp -text "Commit list display options"
5823 grid $top.ldisp - -sticky w -pady 10
5824 label $top.spacer -text " "
5825 label $top.maxwidthl -text "Maximum graph width (lines)" \
5826 -font optionfont
5827 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
5828 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
5829 label $top.maxpctl -text "Maximum graph width (% of pane)" \
5830 -font optionfont
5831 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
5832 grid x $top.maxpctl $top.maxpct -sticky w
5834 label $top.ddisp -text "Diff display options"
5835 grid $top.ddisp - -sticky w -pady 10
5836 label $top.diffoptl -text "Options for diff program" \
5837 -font optionfont
5838 entry $top.diffopt -width 20 -textvariable diffopts
5839 grid x $top.diffoptl $top.diffopt -sticky w
5840 frame $top.ntag
5841 label $top.ntag.l -text "Display nearby tags" -font optionfont
5842 checkbutton $top.ntag.b -variable showneartags
5843 pack $top.ntag.b $top.ntag.l -side left
5844 grid x $top.ntag -sticky w
5846 label $top.cdisp -text "Colors: press to choose"
5847 grid $top.cdisp - -sticky w -pady 10
5848 label $top.bg -padx 40 -relief sunk -background $bgcolor
5849 button $top.bgbut -text "Background" -font optionfont \
5850 -command [list choosecolor bgcolor 0 $top.bg background setbg]
5851 grid x $top.bgbut $top.bg -sticky w
5852 label $top.fg -padx 40 -relief sunk -background $fgcolor
5853 button $top.fgbut -text "Foreground" -font optionfont \
5854 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
5855 grid x $top.fgbut $top.fg -sticky w
5856 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
5857 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
5858 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
5859 [list $ctext tag conf d0 -foreground]]
5860 grid x $top.diffoldbut $top.diffold -sticky w
5861 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
5862 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
5863 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
5864 [list $ctext tag conf d1 -foreground]]
5865 grid x $top.diffnewbut $top.diffnew -sticky w
5866 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
5867 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
5868 -command [list choosecolor diffcolors 2 $top.hunksep \
5869 "diff hunk header" \
5870 [list $ctext tag conf hunksep -foreground]]
5871 grid x $top.hunksepbut $top.hunksep -sticky w
5873 frame $top.buts
5874 button $top.buts.ok -text "OK" -command prefsok
5875 button $top.buts.can -text "Cancel" -command prefscan
5876 grid $top.buts.ok $top.buts.can
5877 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5878 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5879 grid $top.buts - - -pady 10 -sticky ew
5882 proc choosecolor {v vi w x cmd} {
5883 global $v
5885 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
5886 -title "Gitk: choose color for $x"]
5887 if {$c eq {}} return
5888 $w conf -background $c
5889 lset $v $vi $c
5890 eval $cmd $c
5893 proc setbg {c} {
5894 global bglist
5896 foreach w $bglist {
5897 $w conf -background $c
5901 proc setfg {c} {
5902 global fglist canv
5904 foreach w $fglist {
5905 $w conf -foreground $c
5907 allcanvs itemconf text -fill $c
5908 $canv itemconf circle -outline $c
5911 proc prefscan {} {
5912 global maxwidth maxgraphpct diffopts
5913 global oldprefs prefstop showneartags
5915 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5916 set $v $oldprefs($v)
5918 catch {destroy $prefstop}
5919 unset prefstop
5922 proc prefsok {} {
5923 global maxwidth maxgraphpct
5924 global oldprefs prefstop showneartags
5926 catch {destroy $prefstop}
5927 unset prefstop
5928 if {$maxwidth != $oldprefs(maxwidth)
5929 || $maxgraphpct != $oldprefs(maxgraphpct)} {
5930 redisplay
5931 } elseif {$showneartags != $oldprefs(showneartags)} {
5932 reselectline
5936 proc formatdate {d} {
5937 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
5940 # This list of encoding names and aliases is distilled from
5941 # http://www.iana.org/assignments/character-sets.
5942 # Not all of them are supported by Tcl.
5943 set encoding_aliases {
5944 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
5945 ISO646-US US-ASCII us IBM367 cp367 csASCII }
5946 { ISO-10646-UTF-1 csISO10646UTF1 }
5947 { ISO_646.basic:1983 ref csISO646basic1983 }
5948 { INVARIANT csINVARIANT }
5949 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
5950 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
5951 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
5952 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
5953 { NATS-DANO iso-ir-9-1 csNATSDANO }
5954 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
5955 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
5956 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
5957 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
5958 { ISO-2022-KR csISO2022KR }
5959 { EUC-KR csEUCKR }
5960 { ISO-2022-JP csISO2022JP }
5961 { ISO-2022-JP-2 csISO2022JP2 }
5962 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
5963 csISO13JISC6220jp }
5964 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
5965 { IT iso-ir-15 ISO646-IT csISO15Italian }
5966 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
5967 { ES iso-ir-17 ISO646-ES csISO17Spanish }
5968 { greek7-old iso-ir-18 csISO18Greek7Old }
5969 { latin-greek iso-ir-19 csISO19LatinGreek }
5970 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
5971 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
5972 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
5973 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
5974 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
5975 { BS_viewdata iso-ir-47 csISO47BSViewdata }
5976 { INIS iso-ir-49 csISO49INIS }
5977 { INIS-8 iso-ir-50 csISO50INIS8 }
5978 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
5979 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
5980 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
5981 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
5982 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
5983 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
5984 csISO60Norwegian1 }
5985 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
5986 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
5987 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
5988 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
5989 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
5990 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
5991 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
5992 { greek7 iso-ir-88 csISO88Greek7 }
5993 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
5994 { iso-ir-90 csISO90 }
5995 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
5996 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
5997 csISO92JISC62991984b }
5998 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
5999 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
6000 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
6001 csISO95JIS62291984handadd }
6002 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
6003 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
6004 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
6005 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
6006 CP819 csISOLatin1 }
6007 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
6008 { T.61-7bit iso-ir-102 csISO102T617bit }
6009 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
6010 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
6011 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
6012 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
6013 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
6014 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
6015 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
6016 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
6017 arabic csISOLatinArabic }
6018 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
6019 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
6020 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
6021 greek greek8 csISOLatinGreek }
6022 { T.101-G2 iso-ir-128 csISO128T101G2 }
6023 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
6024 csISOLatinHebrew }
6025 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
6026 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
6027 { CSN_369103 iso-ir-139 csISO139CSN369103 }
6028 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
6029 { ISO_6937-2-add iso-ir-142 csISOTextComm }
6030 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
6031 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
6032 csISOLatinCyrillic }
6033 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
6034 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
6035 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
6036 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
6037 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
6038 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
6039 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
6040 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
6041 { ISO_10367-box iso-ir-155 csISO10367Box }
6042 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
6043 { latin-lap lap iso-ir-158 csISO158Lap }
6044 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
6045 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
6046 { us-dk csUSDK }
6047 { dk-us csDKUS }
6048 { JIS_X0201 X0201 csHalfWidthKatakana }
6049 { KSC5636 ISO646-KR csKSC5636 }
6050 { ISO-10646-UCS-2 csUnicode }
6051 { ISO-10646-UCS-4 csUCS4 }
6052 { DEC-MCS dec csDECMCS }
6053 { hp-roman8 roman8 r8 csHPRoman8 }
6054 { macintosh mac csMacintosh }
6055 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
6056 csIBM037 }
6057 { IBM038 EBCDIC-INT cp038 csIBM038 }
6058 { IBM273 CP273 csIBM273 }
6059 { IBM274 EBCDIC-BE CP274 csIBM274 }
6060 { IBM275 EBCDIC-BR cp275 csIBM275 }
6061 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
6062 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
6063 { IBM280 CP280 ebcdic-cp-it csIBM280 }
6064 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
6065 { IBM284 CP284 ebcdic-cp-es csIBM284 }
6066 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
6067 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
6068 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
6069 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
6070 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
6071 { IBM424 cp424 ebcdic-cp-he csIBM424 }
6072 { IBM437 cp437 437 csPC8CodePage437 }
6073 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
6074 { IBM775 cp775 csPC775Baltic }
6075 { IBM850 cp850 850 csPC850Multilingual }
6076 { IBM851 cp851 851 csIBM851 }
6077 { IBM852 cp852 852 csPCp852 }
6078 { IBM855 cp855 855 csIBM855 }
6079 { IBM857 cp857 857 csIBM857 }
6080 { IBM860 cp860 860 csIBM860 }
6081 { IBM861 cp861 861 cp-is csIBM861 }
6082 { IBM862 cp862 862 csPC862LatinHebrew }
6083 { IBM863 cp863 863 csIBM863 }
6084 { IBM864 cp864 csIBM864 }
6085 { IBM865 cp865 865 csIBM865 }
6086 { IBM866 cp866 866 csIBM866 }
6087 { IBM868 CP868 cp-ar csIBM868 }
6088 { IBM869 cp869 869 cp-gr csIBM869 }
6089 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
6090 { IBM871 CP871 ebcdic-cp-is csIBM871 }
6091 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
6092 { IBM891 cp891 csIBM891 }
6093 { IBM903 cp903 csIBM903 }
6094 { IBM904 cp904 904 csIBBM904 }
6095 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
6096 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
6097 { IBM1026 CP1026 csIBM1026 }
6098 { EBCDIC-AT-DE csIBMEBCDICATDE }
6099 { EBCDIC-AT-DE-A csEBCDICATDEA }
6100 { EBCDIC-CA-FR csEBCDICCAFR }
6101 { EBCDIC-DK-NO csEBCDICDKNO }
6102 { EBCDIC-DK-NO-A csEBCDICDKNOA }
6103 { EBCDIC-FI-SE csEBCDICFISE }
6104 { EBCDIC-FI-SE-A csEBCDICFISEA }
6105 { EBCDIC-FR csEBCDICFR }
6106 { EBCDIC-IT csEBCDICIT }
6107 { EBCDIC-PT csEBCDICPT }
6108 { EBCDIC-ES csEBCDICES }
6109 { EBCDIC-ES-A csEBCDICESA }
6110 { EBCDIC-ES-S csEBCDICESS }
6111 { EBCDIC-UK csEBCDICUK }
6112 { EBCDIC-US csEBCDICUS }
6113 { UNKNOWN-8BIT csUnknown8BiT }
6114 { MNEMONIC csMnemonic }
6115 { MNEM csMnem }
6116 { VISCII csVISCII }
6117 { VIQR csVIQR }
6118 { KOI8-R csKOI8R }
6119 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
6120 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
6121 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
6122 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
6123 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
6124 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
6125 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
6126 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
6127 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
6128 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
6129 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
6130 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
6131 { IBM1047 IBM-1047 }
6132 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
6133 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
6134 { UNICODE-1-1 csUnicode11 }
6135 { CESU-8 csCESU-8 }
6136 { BOCU-1 csBOCU-1 }
6137 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
6138 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
6139 l8 }
6140 { ISO-8859-15 ISO_8859-15 Latin-9 }
6141 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
6142 { GBK CP936 MS936 windows-936 }
6143 { JIS_Encoding csJISEncoding }
6144 { Shift_JIS MS_Kanji csShiftJIS }
6145 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
6146 EUC-JP }
6147 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
6148 { ISO-10646-UCS-Basic csUnicodeASCII }
6149 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
6150 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
6151 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
6152 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
6153 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
6154 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
6155 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
6156 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
6157 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
6158 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
6159 { Adobe-Standard-Encoding csAdobeStandardEncoding }
6160 { Ventura-US csVenturaUS }
6161 { Ventura-International csVenturaInternational }
6162 { PC8-Danish-Norwegian csPC8DanishNorwegian }
6163 { PC8-Turkish csPC8Turkish }
6164 { IBM-Symbols csIBMSymbols }
6165 { IBM-Thai csIBMThai }
6166 { HP-Legal csHPLegal }
6167 { HP-Pi-font csHPPiFont }
6168 { HP-Math8 csHPMath8 }
6169 { Adobe-Symbol-Encoding csHPPSMath }
6170 { HP-DeskTop csHPDesktop }
6171 { Ventura-Math csVenturaMath }
6172 { Microsoft-Publishing csMicrosoftPublishing }
6173 { Windows-31J csWindows31J }
6174 { GB2312 csGB2312 }
6175 { Big5 csBig5 }
6178 proc tcl_encoding {enc} {
6179 global encoding_aliases
6180 set names [encoding names]
6181 set lcnames [string tolower $names]
6182 set enc [string tolower $enc]
6183 set i [lsearch -exact $lcnames $enc]
6184 if {$i < 0} {
6185 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
6186 if {[regsub {^iso[-_]} $enc iso encx]} {
6187 set i [lsearch -exact $lcnames $encx]
6190 if {$i < 0} {
6191 foreach l $encoding_aliases {
6192 set ll [string tolower $l]
6193 if {[lsearch -exact $ll $enc] < 0} continue
6194 # look through the aliases for one that tcl knows about
6195 foreach e $ll {
6196 set i [lsearch -exact $lcnames $e]
6197 if {$i < 0} {
6198 if {[regsub {^iso[-_]} $e iso ex]} {
6199 set i [lsearch -exact $lcnames $ex]
6202 if {$i >= 0} break
6204 break
6207 if {$i >= 0} {
6208 return [lindex $names $i]
6210 return {}
6213 # defaults...
6214 set datemode 0
6215 set diffopts "-U 5 -p"
6216 set wrcomcmd "git diff-tree --stdin -p --pretty"
6218 set gitencoding {}
6219 catch {
6220 set gitencoding [exec git config --get i18n.commitencoding]
6222 if {$gitencoding == ""} {
6223 set gitencoding "utf-8"
6225 set tclencoding [tcl_encoding $gitencoding]
6226 if {$tclencoding == {}} {
6227 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
6230 set mainfont {Helvetica 9}
6231 set textfont {Courier 9}
6232 set uifont {Helvetica 9 bold}
6233 set findmergefiles 0
6234 set maxgraphpct 50
6235 set maxwidth 16
6236 set revlistorder 0
6237 set fastdate 0
6238 set uparrowlen 7
6239 set downarrowlen 7
6240 set mingaplen 30
6241 set cmitmode "patch"
6242 set wrapcomment "none"
6243 set showneartags 1
6245 set colors {green red blue magenta darkgrey brown orange}
6246 set bgcolor white
6247 set fgcolor black
6248 set diffcolors {red "#00a000" blue}
6250 catch {source ~/.gitk}
6252 font create optionfont -family sans-serif -size -12
6254 set revtreeargs {}
6255 foreach arg $argv {
6256 switch -regexp -- $arg {
6257 "^$" { }
6258 "^-d" { set datemode 1 }
6259 default {
6260 lappend revtreeargs $arg
6265 # check that we can find a .git directory somewhere...
6266 set gitdir [gitdir]
6267 if {![file isdirectory $gitdir]} {
6268 show_error {} . "Cannot find the git directory \"$gitdir\"."
6269 exit 1
6272 set cmdline_files {}
6273 set i [lsearch -exact $revtreeargs "--"]
6274 if {$i >= 0} {
6275 set cmdline_files [lrange $revtreeargs [expr {$i + 1}] end]
6276 set revtreeargs [lrange $revtreeargs 0 [expr {$i - 1}]]
6277 } elseif {$revtreeargs ne {}} {
6278 if {[catch {
6279 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
6280 set cmdline_files [split $f "\n"]
6281 set n [llength $cmdline_files]
6282 set revtreeargs [lrange $revtreeargs 0 end-$n]
6283 } err]} {
6284 # unfortunately we get both stdout and stderr in $err,
6285 # so look for "fatal:".
6286 set i [string first "fatal:" $err]
6287 if {$i > 0} {
6288 set err [string range $err [expr {$i + 6}] end]
6290 show_error {} . "Bad arguments to gitk:\n$err"
6291 exit 1
6295 set history {}
6296 set historyindex 0
6297 set fh_serial 0
6298 set nhl_names {}
6299 set highlight_paths {}
6300 set searchdirn -forwards
6301 set boldrows {}
6302 set boldnamerows {}
6304 set optim_delay 16
6306 set nextviewnum 1
6307 set curview 0
6308 set selectedview 0
6309 set selectedhlview None
6310 set viewfiles(0) {}
6311 set viewperm(0) 0
6312 set viewargs(0) {}
6314 set cmdlineok 0
6315 set stopped 0
6316 set stuffsaved 0
6317 set patchnum 0
6318 setcoords
6319 makewindow
6320 wm title . "[file tail $argv0]: [file tail [pwd]]"
6321 readrefs
6323 if {$cmdline_files ne {} || $revtreeargs ne {}} {
6324 # create a view for the files/dirs specified on the command line
6325 set curview 1
6326 set selectedview 1
6327 set nextviewnum 2
6328 set viewname(1) "Command line"
6329 set viewfiles(1) $cmdline_files
6330 set viewargs(1) $revtreeargs
6331 set viewperm(1) 0
6332 addviewmenu 1
6333 .bar.view entryconf Edit* -state normal
6334 .bar.view entryconf Delete* -state normal
6337 if {[info exists permviews]} {
6338 foreach v $permviews {
6339 set n $nextviewnum
6340 incr nextviewnum
6341 set viewname($n) [lindex $v 0]
6342 set viewfiles($n) [lindex $v 1]
6343 set viewargs($n) [lindex $v 2]
6344 set viewperm($n) 1
6345 addviewmenu $n
6348 getcommits