git-rm: don't remove newly added file without -f
[git/dscho.git] / gitk
blobdb28d745dc005722ff3d7c071aeb37f9fd4fdc21
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(pwsash0)]} {
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(pwsash0) "[expr {40 * $charspc}] 2"
448 set geometry(pwsash1) "[expr {60 * $charspc}] 2"
451 # the upper half will have a paned window, a scroll bar to the right, and some stuff below
452 frame .tf -height $geometry(topheight) -width $geometry(topwidth)
453 frame .tf.histframe
454 panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
456 # create three canvases
457 set cscroll .tf.histframe.csb
458 set canv .tf.histframe.pwclist.canv
459 canvas $canv \
460 -background $bgcolor -bd 0 \
461 -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
462 .tf.histframe.pwclist add $canv
463 set canv2 .tf.histframe.pwclist.canv2
464 canvas $canv2 \
465 -background $bgcolor -bd 0 -yscrollincr $linespc
466 .tf.histframe.pwclist add $canv2
467 set canv3 .tf.histframe.pwclist.canv3
468 canvas $canv3 \
469 -background $bgcolor -bd 0 -yscrollincr $linespc
470 .tf.histframe.pwclist add $canv3
471 eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
472 eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
474 # a scroll bar to rule them
475 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
476 pack $cscroll -side right -fill y
477 bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
478 lappend bglist $canv $canv2 $canv3
479 pack .tf.histframe.pwclist -fill both -expand 1 -side left
481 # we have two button bars at bottom of top frame. Bar 1
482 frame .tf.bar
483 frame .tf.lbar -height 15
485 set sha1entry .tf.bar.sha1
486 set entries $sha1entry
487 set sha1but .tf.bar.sha1label
488 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
489 -command gotocommit -width 8 -font $uifont
490 $sha1but conf -disabledforeground [$sha1but cget -foreground]
491 pack .tf.bar.sha1label -side left
492 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
493 trace add variable sha1string write sha1change
494 pack $sha1entry -side left -pady 2
496 image create bitmap bm-left -data {
497 #define left_width 16
498 #define left_height 16
499 static unsigned char left_bits[] = {
500 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
501 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
502 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
504 image create bitmap bm-right -data {
505 #define right_width 16
506 #define right_height 16
507 static unsigned char right_bits[] = {
508 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
509 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
510 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
512 button .tf.bar.leftbut -image bm-left -command goback \
513 -state disabled -width 26
514 pack .tf.bar.leftbut -side left -fill y
515 button .tf.bar.rightbut -image bm-right -command goforw \
516 -state disabled -width 26
517 pack .tf.bar.rightbut -side left -fill y
519 button .tf.bar.findbut -text "Find" -command dofind -font $uifont
520 pack .tf.bar.findbut -side left
521 set findstring {}
522 set fstring .tf.bar.findstring
523 lappend entries $fstring
524 entry $fstring -width 30 -font $textfont -textvariable findstring
525 trace add variable findstring write find_change
526 pack $fstring -side left -expand 1 -fill x -in .tf.bar
527 set findtype Exact
528 set findtypemenu [tk_optionMenu .tf.bar.findtype \
529 findtype Exact IgnCase Regexp]
530 trace add variable findtype write find_change
531 .tf.bar.findtype configure -font $uifont
532 .tf.bar.findtype.menu configure -font $uifont
533 set findloc "All fields"
534 tk_optionMenu .tf.bar.findloc findloc "All fields" Headline \
535 Comments Author Committer
536 trace add variable findloc write find_change
537 .tf.bar.findloc configure -font $uifont
538 .tf.bar.findloc.menu configure -font $uifont
539 pack .tf.bar.findloc -side right
540 pack .tf.bar.findtype -side right
542 # build up the bottom bar of upper window
543 label .tf.lbar.flabel -text "Highlight: Commits " \
544 -font $uifont
545 pack .tf.lbar.flabel -side left -fill y
546 set gdttype "touching paths:"
547 set gm [tk_optionMenu .tf.lbar.gdttype gdttype "touching paths:" \
548 "adding/removing string:"]
549 trace add variable gdttype write hfiles_change
550 $gm conf -font $uifont
551 .tf.lbar.gdttype conf -font $uifont
552 pack .tf.lbar.gdttype -side left -fill y
553 entry .tf.lbar.fent -width 25 -font $textfont \
554 -textvariable highlight_files
555 trace add variable highlight_files write hfiles_change
556 lappend entries .tf.lbar.fent
557 pack .tf.lbar.fent -side left -fill x -expand 1
558 label .tf.lbar.vlabel -text " OR in view" -font $uifont
559 pack .tf.lbar.vlabel -side left -fill y
560 global viewhlmenu selectedhlview
561 set viewhlmenu [tk_optionMenu .tf.lbar.vhl selectedhlview None]
562 $viewhlmenu entryconf None -command delvhighlight
563 $viewhlmenu conf -font $uifont
564 .tf.lbar.vhl conf -font $uifont
565 pack .tf.lbar.vhl -side left -fill y
566 label .tf.lbar.rlabel -text " OR " -font $uifont
567 pack .tf.lbar.rlabel -side left -fill y
568 global highlight_related
569 set m [tk_optionMenu .tf.lbar.relm highlight_related None \
570 "Descendent" "Not descendent" "Ancestor" "Not ancestor"]
571 $m conf -font $uifont
572 .tf.lbar.relm conf -font $uifont
573 trace add variable highlight_related write vrel_change
574 pack .tf.lbar.relm -side left -fill y
576 # Finish putting the upper half of the viewer together
577 pack .tf.lbar -in .tf -side bottom -fill x
578 pack .tf.bar -in .tf -side bottom -fill x
579 pack .tf.histframe -fill both -side top -expand 1
580 .ctop add .tf
581 .ctop paneconfigure .tf -height $geometry(topheight)
582 .ctop paneconfigure .tf -width $geometry(topwidth)
584 # now build up the bottom
585 panedwindow .pwbottom -orient horizontal
587 # lower left, a text box over search bar, scroll bar to the right
588 # if we know window height, then that will set the lower text height, otherwise
589 # we set lower text height which will drive window height
590 if {[info exists geometry(main)]} {
591 frame .bleft -width $geometry(botwidth)
592 } else {
593 frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
595 frame .bleft.top
597 button .bleft.top.search -text "Search" -command dosearch \
598 -font $uifont
599 pack .bleft.top.search -side left -padx 5
600 set sstring .bleft.top.sstring
601 entry $sstring -width 20 -font $textfont -textvariable searchstring
602 lappend entries $sstring
603 trace add variable searchstring write incrsearch
604 pack $sstring -side left -expand 1 -fill x
605 set ctext .bleft.ctext
606 text $ctext -background $bgcolor -foreground $fgcolor \
607 -state disabled -font $textfont \
608 -yscrollcommand scrolltext -wrap none
609 scrollbar .bleft.sb -command "$ctext yview"
610 pack .bleft.top -side top -fill x
611 pack .bleft.sb -side right -fill y
612 pack $ctext -side left -fill both -expand 1
613 lappend bglist $ctext
614 lappend fglist $ctext
616 $ctext tag conf comment -wrap $wrapcomment
617 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
618 $ctext tag conf hunksep -fore [lindex $diffcolors 2]
619 $ctext tag conf d0 -fore [lindex $diffcolors 0]
620 $ctext tag conf d1 -fore [lindex $diffcolors 1]
621 $ctext tag conf m0 -fore red
622 $ctext tag conf m1 -fore blue
623 $ctext tag conf m2 -fore green
624 $ctext tag conf m3 -fore purple
625 $ctext tag conf m4 -fore brown
626 $ctext tag conf m5 -fore "#009090"
627 $ctext tag conf m6 -fore magenta
628 $ctext tag conf m7 -fore "#808000"
629 $ctext tag conf m8 -fore "#009000"
630 $ctext tag conf m9 -fore "#ff0080"
631 $ctext tag conf m10 -fore cyan
632 $ctext tag conf m11 -fore "#b07070"
633 $ctext tag conf m12 -fore "#70b0f0"
634 $ctext tag conf m13 -fore "#70f0b0"
635 $ctext tag conf m14 -fore "#f0b070"
636 $ctext tag conf m15 -fore "#ff70b0"
637 $ctext tag conf mmax -fore darkgrey
638 set mergemax 16
639 $ctext tag conf mresult -font [concat $textfont bold]
640 $ctext tag conf msep -font [concat $textfont bold]
641 $ctext tag conf found -back yellow
643 .pwbottom add .bleft
644 .pwbottom paneconfigure .bleft -width $geometry(botwidth)
646 # lower right
647 frame .bright
648 frame .bright.mode
649 radiobutton .bright.mode.patch -text "Patch" \
650 -command reselectline -variable cmitmode -value "patch"
651 radiobutton .bright.mode.tree -text "Tree" \
652 -command reselectline -variable cmitmode -value "tree"
653 grid .bright.mode.patch .bright.mode.tree -sticky ew
654 pack .bright.mode -side top -fill x
655 set cflist .bright.cfiles
656 set indent [font measure $mainfont "nn"]
657 text $cflist \
658 -background $bgcolor -foreground $fgcolor \
659 -font $mainfont \
660 -tabs [list $indent [expr {2 * $indent}]] \
661 -yscrollcommand ".bright.sb set" \
662 -cursor [. cget -cursor] \
663 -spacing1 1 -spacing3 1
664 lappend bglist $cflist
665 lappend fglist $cflist
666 scrollbar .bright.sb -command "$cflist yview"
667 pack .bright.sb -side right -fill y
668 pack $cflist -side left -fill both -expand 1
669 $cflist tag configure highlight \
670 -background [$cflist cget -selectbackground]
671 $cflist tag configure bold -font [concat $mainfont bold]
673 .pwbottom add .bright
674 .ctop add .pwbottom
676 # restore window position if known
677 if {[info exists geometry(main)]} {
678 wm geometry . "$geometry(main)"
681 bind .pwbottom <Configure> {resizecdetpanes %W %w}
682 pack .ctop -fill both -expand 1
683 bindall <1> {selcanvline %W %x %y}
684 #bindall <B1-Motion> {selcanvline %W %x %y}
685 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
686 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
687 bindall <2> "canvscan mark %W %x %y"
688 bindall <B2-Motion> "canvscan dragto %W %x %y"
689 bindkey <Home> selfirstline
690 bindkey <End> sellastline
691 bind . <Key-Up> "selnextline -1"
692 bind . <Key-Down> "selnextline 1"
693 bind . <Shift-Key-Up> "next_highlight -1"
694 bind . <Shift-Key-Down> "next_highlight 1"
695 bindkey <Key-Right> "goforw"
696 bindkey <Key-Left> "goback"
697 bind . <Key-Prior> "selnextpage -1"
698 bind . <Key-Next> "selnextpage 1"
699 bind . <Control-Home> "allcanvs yview moveto 0.0"
700 bind . <Control-End> "allcanvs yview moveto 1.0"
701 bind . <Control-Key-Up> "allcanvs yview scroll -1 units"
702 bind . <Control-Key-Down> "allcanvs yview scroll 1 units"
703 bind . <Control-Key-Prior> "allcanvs yview scroll -1 pages"
704 bind . <Control-Key-Next> "allcanvs yview scroll 1 pages"
705 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
706 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
707 bindkey <Key-space> "$ctext yview scroll 1 pages"
708 bindkey p "selnextline -1"
709 bindkey n "selnextline 1"
710 bindkey z "goback"
711 bindkey x "goforw"
712 bindkey i "selnextline -1"
713 bindkey k "selnextline 1"
714 bindkey j "goback"
715 bindkey l "goforw"
716 bindkey b "$ctext yview scroll -1 pages"
717 bindkey d "$ctext yview scroll 18 units"
718 bindkey u "$ctext yview scroll -18 units"
719 bindkey / {findnext 1}
720 bindkey <Key-Return> {findnext 0}
721 bindkey ? findprev
722 bindkey f nextfile
723 bindkey <F5> updatecommits
724 bind . <Control-q> doquit
725 bind . <Control-f> dofind
726 bind . <Control-g> {findnext 0}
727 bind . <Control-r> dosearchback
728 bind . <Control-s> dosearch
729 bind . <Control-equal> {incrfont 1}
730 bind . <Control-KP_Add> {incrfont 1}
731 bind . <Control-minus> {incrfont -1}
732 bind . <Control-KP_Subtract> {incrfont -1}
733 wm protocol . WM_DELETE_WINDOW doquit
734 bind . <Button-1> "click %W"
735 bind $fstring <Key-Return> dofind
736 bind $sha1entry <Key-Return> gotocommit
737 bind $sha1entry <<PasteSelection>> clearsha1
738 bind $cflist <1> {sel_flist %W %x %y; break}
739 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
740 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
742 set maincursor [. cget -cursor]
743 set textcursor [$ctext cget -cursor]
744 set curtextcursor $textcursor
746 set rowctxmenu .rowctxmenu
747 menu $rowctxmenu -tearoff 0
748 $rowctxmenu add command -label "Diff this -> selected" \
749 -command {diffvssel 0}
750 $rowctxmenu add command -label "Diff selected -> this" \
751 -command {diffvssel 1}
752 $rowctxmenu add command -label "Make patch" -command mkpatch
753 $rowctxmenu add command -label "Create tag" -command mktag
754 $rowctxmenu add command -label "Write commit to file" -command writecommit
755 $rowctxmenu add command -label "Create new branch" -command mkbranch
756 $rowctxmenu add command -label "Cherry-pick this commit" \
757 -command cherrypick
759 set headctxmenu .headctxmenu
760 menu $headctxmenu -tearoff 0
761 $headctxmenu add command -label "Check out this branch" \
762 -command cobranch
763 $headctxmenu add command -label "Remove this branch" \
764 -command rmbranch
767 # mouse-2 makes all windows scan vertically, but only the one
768 # the cursor is in scans horizontally
769 proc canvscan {op w x y} {
770 global canv canv2 canv3
771 foreach c [list $canv $canv2 $canv3] {
772 if {$c == $w} {
773 $c scan $op $x $y
774 } else {
775 $c scan $op 0 $y
780 proc scrollcanv {cscroll f0 f1} {
781 $cscroll set $f0 $f1
782 drawfrac $f0 $f1
783 flushhighlights
786 # when we make a key binding for the toplevel, make sure
787 # it doesn't get triggered when that key is pressed in the
788 # find string entry widget.
789 proc bindkey {ev script} {
790 global entries
791 bind . $ev $script
792 set escript [bind Entry $ev]
793 if {$escript == {}} {
794 set escript [bind Entry <Key>]
796 foreach e $entries {
797 bind $e $ev "$escript; break"
801 # set the focus back to the toplevel for any click outside
802 # the entry widgets
803 proc click {w} {
804 global entries
805 foreach e $entries {
806 if {$w == $e} return
808 focus .
811 proc savestuff {w} {
812 global canv canv2 canv3 ctext cflist mainfont textfont uifont
813 global stuffsaved findmergefiles maxgraphpct
814 global maxwidth showneartags
815 global viewname viewfiles viewargs viewperm nextviewnum
816 global cmitmode wrapcomment
817 global colors bgcolor fgcolor diffcolors
819 if {$stuffsaved} return
820 if {![winfo viewable .]} return
821 catch {
822 set f [open "~/.gitk-new" w]
823 puts $f [list set mainfont $mainfont]
824 puts $f [list set textfont $textfont]
825 puts $f [list set uifont $uifont]
826 puts $f [list set findmergefiles $findmergefiles]
827 puts $f [list set maxgraphpct $maxgraphpct]
828 puts $f [list set maxwidth $maxwidth]
829 puts $f [list set cmitmode $cmitmode]
830 puts $f [list set wrapcomment $wrapcomment]
831 puts $f [list set showneartags $showneartags]
832 puts $f [list set bgcolor $bgcolor]
833 puts $f [list set fgcolor $fgcolor]
834 puts $f [list set colors $colors]
835 puts $f [list set diffcolors $diffcolors]
837 puts $f "set geometry(main) [wm geometry .]"
838 puts $f "set geometry(topwidth) [winfo width .tf]"
839 puts $f "set geometry(topheight) [winfo height .tf]"
840 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
841 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
842 puts $f "set geometry(botwidth) [winfo width .bleft]"
843 puts $f "set geometry(botheight) [winfo height .bleft]"
845 puts -nonewline $f "set permviews {"
846 for {set v 0} {$v < $nextviewnum} {incr v} {
847 if {$viewperm($v)} {
848 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
851 puts $f "}"
852 close $f
853 file rename -force "~/.gitk-new" "~/.gitk"
855 set stuffsaved 1
858 proc resizeclistpanes {win w} {
859 global oldwidth
860 if {[info exists oldwidth($win)]} {
861 set s0 [$win sash coord 0]
862 set s1 [$win sash coord 1]
863 if {$w < 60} {
864 set sash0 [expr {int($w/2 - 2)}]
865 set sash1 [expr {int($w*5/6 - 2)}]
866 } else {
867 set factor [expr {1.0 * $w / $oldwidth($win)}]
868 set sash0 [expr {int($factor * [lindex $s0 0])}]
869 set sash1 [expr {int($factor * [lindex $s1 0])}]
870 if {$sash0 < 30} {
871 set sash0 30
873 if {$sash1 < $sash0 + 20} {
874 set sash1 [expr {$sash0 + 20}]
876 if {$sash1 > $w - 10} {
877 set sash1 [expr {$w - 10}]
878 if {$sash0 > $sash1 - 20} {
879 set sash0 [expr {$sash1 - 20}]
883 $win sash place 0 $sash0 [lindex $s0 1]
884 $win sash place 1 $sash1 [lindex $s1 1]
886 set oldwidth($win) $w
889 proc resizecdetpanes {win w} {
890 global oldwidth
891 if {[info exists oldwidth($win)]} {
892 set s0 [$win sash coord 0]
893 if {$w < 60} {
894 set sash0 [expr {int($w*3/4 - 2)}]
895 } else {
896 set factor [expr {1.0 * $w / $oldwidth($win)}]
897 set sash0 [expr {int($factor * [lindex $s0 0])}]
898 if {$sash0 < 45} {
899 set sash0 45
901 if {$sash0 > $w - 15} {
902 set sash0 [expr {$w - 15}]
905 $win sash place 0 $sash0 [lindex $s0 1]
907 set oldwidth($win) $w
910 proc allcanvs args {
911 global canv canv2 canv3
912 eval $canv $args
913 eval $canv2 $args
914 eval $canv3 $args
917 proc bindall {event action} {
918 global canv canv2 canv3
919 bind $canv $event $action
920 bind $canv2 $event $action
921 bind $canv3 $event $action
924 proc about {} {
925 set w .about
926 if {[winfo exists $w]} {
927 raise $w
928 return
930 toplevel $w
931 wm title $w "About gitk"
932 message $w.m -text {
933 Gitk - a commit viewer for git
935 Copyright © 2005-2006 Paul Mackerras
937 Use and redistribute under the terms of the GNU General Public License} \
938 -justify center -aspect 400
939 pack $w.m -side top -fill x -padx 20 -pady 20
940 button $w.ok -text Close -command "destroy $w"
941 pack $w.ok -side bottom
944 proc keys {} {
945 set w .keys
946 if {[winfo exists $w]} {
947 raise $w
948 return
950 toplevel $w
951 wm title $w "Gitk key bindings"
952 message $w.m -text {
953 Gitk key bindings:
955 <Ctrl-Q> Quit
956 <Home> Move to first commit
957 <End> Move to last commit
958 <Up>, p, i Move up one commit
959 <Down>, n, k Move down one commit
960 <Left>, z, j Go back in history list
961 <Right>, x, l Go forward in history list
962 <PageUp> Move up one page in commit list
963 <PageDown> Move down one page in commit list
964 <Ctrl-Home> Scroll to top of commit list
965 <Ctrl-End> Scroll to bottom of commit list
966 <Ctrl-Up> Scroll commit list up one line
967 <Ctrl-Down> Scroll commit list down one line
968 <Ctrl-PageUp> Scroll commit list up one page
969 <Ctrl-PageDown> Scroll commit list down one page
970 <Shift-Up> Move to previous highlighted line
971 <Shift-Down> Move to next highlighted line
972 <Delete>, b Scroll diff view up one page
973 <Backspace> Scroll diff view up one page
974 <Space> Scroll diff view down one page
975 u Scroll diff view up 18 lines
976 d Scroll diff view down 18 lines
977 <Ctrl-F> Find
978 <Ctrl-G> Move to next find hit
979 <Return> Move to next find hit
980 / Move to next find hit, or redo find
981 ? Move to previous find hit
982 f Scroll diff view to next file
983 <Ctrl-S> Search for next hit in diff view
984 <Ctrl-R> Search for previous hit in diff view
985 <Ctrl-KP+> Increase font size
986 <Ctrl-plus> Increase font size
987 <Ctrl-KP-> Decrease font size
988 <Ctrl-minus> Decrease font size
989 <F5> Update
991 -justify left -bg white -border 2 -relief sunken
992 pack $w.m -side top -fill both
993 button $w.ok -text Close -command "destroy $w"
994 pack $w.ok -side bottom
997 # Procedures for manipulating the file list window at the
998 # bottom right of the overall window.
1000 proc treeview {w l openlevs} {
1001 global treecontents treediropen treeheight treeparent treeindex
1003 set ix 0
1004 set treeindex() 0
1005 set lev 0
1006 set prefix {}
1007 set prefixend -1
1008 set prefendstack {}
1009 set htstack {}
1010 set ht 0
1011 set treecontents() {}
1012 $w conf -state normal
1013 foreach f $l {
1014 while {[string range $f 0 $prefixend] ne $prefix} {
1015 if {$lev <= $openlevs} {
1016 $w mark set e:$treeindex($prefix) "end -1c"
1017 $w mark gravity e:$treeindex($prefix) left
1019 set treeheight($prefix) $ht
1020 incr ht [lindex $htstack end]
1021 set htstack [lreplace $htstack end end]
1022 set prefixend [lindex $prefendstack end]
1023 set prefendstack [lreplace $prefendstack end end]
1024 set prefix [string range $prefix 0 $prefixend]
1025 incr lev -1
1027 set tail [string range $f [expr {$prefixend+1}] end]
1028 while {[set slash [string first "/" $tail]] >= 0} {
1029 lappend htstack $ht
1030 set ht 0
1031 lappend prefendstack $prefixend
1032 incr prefixend [expr {$slash + 1}]
1033 set d [string range $tail 0 $slash]
1034 lappend treecontents($prefix) $d
1035 set oldprefix $prefix
1036 append prefix $d
1037 set treecontents($prefix) {}
1038 set treeindex($prefix) [incr ix]
1039 set treeparent($prefix) $oldprefix
1040 set tail [string range $tail [expr {$slash+1}] end]
1041 if {$lev <= $openlevs} {
1042 set ht 1
1043 set treediropen($prefix) [expr {$lev < $openlevs}]
1044 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1045 $w mark set d:$ix "end -1c"
1046 $w mark gravity d:$ix left
1047 set str "\n"
1048 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1049 $w insert end $str
1050 $w image create end -align center -image $bm -padx 1 \
1051 -name a:$ix
1052 $w insert end $d [highlight_tag $prefix]
1053 $w mark set s:$ix "end -1c"
1054 $w mark gravity s:$ix left
1056 incr lev
1058 if {$tail ne {}} {
1059 if {$lev <= $openlevs} {
1060 incr ht
1061 set str "\n"
1062 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1063 $w insert end $str
1064 $w insert end $tail [highlight_tag $f]
1066 lappend treecontents($prefix) $tail
1069 while {$htstack ne {}} {
1070 set treeheight($prefix) $ht
1071 incr ht [lindex $htstack end]
1072 set htstack [lreplace $htstack end end]
1074 $w conf -state disabled
1077 proc linetoelt {l} {
1078 global treeheight treecontents
1080 set y 2
1081 set prefix {}
1082 while {1} {
1083 foreach e $treecontents($prefix) {
1084 if {$y == $l} {
1085 return "$prefix$e"
1087 set n 1
1088 if {[string index $e end] eq "/"} {
1089 set n $treeheight($prefix$e)
1090 if {$y + $n > $l} {
1091 append prefix $e
1092 incr y
1093 break
1096 incr y $n
1101 proc highlight_tree {y prefix} {
1102 global treeheight treecontents cflist
1104 foreach e $treecontents($prefix) {
1105 set path $prefix$e
1106 if {[highlight_tag $path] ne {}} {
1107 $cflist tag add bold $y.0 "$y.0 lineend"
1109 incr y
1110 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1111 set y [highlight_tree $y $path]
1114 return $y
1117 proc treeclosedir {w dir} {
1118 global treediropen treeheight treeparent treeindex
1120 set ix $treeindex($dir)
1121 $w conf -state normal
1122 $w delete s:$ix e:$ix
1123 set treediropen($dir) 0
1124 $w image configure a:$ix -image tri-rt
1125 $w conf -state disabled
1126 set n [expr {1 - $treeheight($dir)}]
1127 while {$dir ne {}} {
1128 incr treeheight($dir) $n
1129 set dir $treeparent($dir)
1133 proc treeopendir {w dir} {
1134 global treediropen treeheight treeparent treecontents treeindex
1136 set ix $treeindex($dir)
1137 $w conf -state normal
1138 $w image configure a:$ix -image tri-dn
1139 $w mark set e:$ix s:$ix
1140 $w mark gravity e:$ix right
1141 set lev 0
1142 set str "\n"
1143 set n [llength $treecontents($dir)]
1144 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1145 incr lev
1146 append str "\t"
1147 incr treeheight($x) $n
1149 foreach e $treecontents($dir) {
1150 set de $dir$e
1151 if {[string index $e end] eq "/"} {
1152 set iy $treeindex($de)
1153 $w mark set d:$iy e:$ix
1154 $w mark gravity d:$iy left
1155 $w insert e:$ix $str
1156 set treediropen($de) 0
1157 $w image create e:$ix -align center -image tri-rt -padx 1 \
1158 -name a:$iy
1159 $w insert e:$ix $e [highlight_tag $de]
1160 $w mark set s:$iy e:$ix
1161 $w mark gravity s:$iy left
1162 set treeheight($de) 1
1163 } else {
1164 $w insert e:$ix $str
1165 $w insert e:$ix $e [highlight_tag $de]
1168 $w mark gravity e:$ix left
1169 $w conf -state disabled
1170 set treediropen($dir) 1
1171 set top [lindex [split [$w index @0,0] .] 0]
1172 set ht [$w cget -height]
1173 set l [lindex [split [$w index s:$ix] .] 0]
1174 if {$l < $top} {
1175 $w yview $l.0
1176 } elseif {$l + $n + 1 > $top + $ht} {
1177 set top [expr {$l + $n + 2 - $ht}]
1178 if {$l < $top} {
1179 set top $l
1181 $w yview $top.0
1185 proc treeclick {w x y} {
1186 global treediropen cmitmode ctext cflist cflist_top
1188 if {$cmitmode ne "tree"} return
1189 if {![info exists cflist_top]} return
1190 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1191 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1192 $cflist tag add highlight $l.0 "$l.0 lineend"
1193 set cflist_top $l
1194 if {$l == 1} {
1195 $ctext yview 1.0
1196 return
1198 set e [linetoelt $l]
1199 if {[string index $e end] ne "/"} {
1200 showfile $e
1201 } elseif {$treediropen($e)} {
1202 treeclosedir $w $e
1203 } else {
1204 treeopendir $w $e
1208 proc setfilelist {id} {
1209 global treefilelist cflist
1211 treeview $cflist $treefilelist($id) 0
1214 image create bitmap tri-rt -background black -foreground blue -data {
1215 #define tri-rt_width 13
1216 #define tri-rt_height 13
1217 static unsigned char tri-rt_bits[] = {
1218 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1219 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1220 0x00, 0x00};
1221 } -maskdata {
1222 #define tri-rt-mask_width 13
1223 #define tri-rt-mask_height 13
1224 static unsigned char tri-rt-mask_bits[] = {
1225 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1226 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1227 0x08, 0x00};
1229 image create bitmap tri-dn -background black -foreground blue -data {
1230 #define tri-dn_width 13
1231 #define tri-dn_height 13
1232 static unsigned char tri-dn_bits[] = {
1233 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1234 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1235 0x00, 0x00};
1236 } -maskdata {
1237 #define tri-dn-mask_width 13
1238 #define tri-dn-mask_height 13
1239 static unsigned char tri-dn-mask_bits[] = {
1240 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1241 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1242 0x00, 0x00};
1245 proc init_flist {first} {
1246 global cflist cflist_top selectedline difffilestart
1248 $cflist conf -state normal
1249 $cflist delete 0.0 end
1250 if {$first ne {}} {
1251 $cflist insert end $first
1252 set cflist_top 1
1253 $cflist tag add highlight 1.0 "1.0 lineend"
1254 } else {
1255 catch {unset cflist_top}
1257 $cflist conf -state disabled
1258 set difffilestart {}
1261 proc highlight_tag {f} {
1262 global highlight_paths
1264 foreach p $highlight_paths {
1265 if {[string match $p $f]} {
1266 return "bold"
1269 return {}
1272 proc highlight_filelist {} {
1273 global cmitmode cflist
1275 $cflist conf -state normal
1276 if {$cmitmode ne "tree"} {
1277 set end [lindex [split [$cflist index end] .] 0]
1278 for {set l 2} {$l < $end} {incr l} {
1279 set line [$cflist get $l.0 "$l.0 lineend"]
1280 if {[highlight_tag $line] ne {}} {
1281 $cflist tag add bold $l.0 "$l.0 lineend"
1284 } else {
1285 highlight_tree 2 {}
1287 $cflist conf -state disabled
1290 proc unhighlight_filelist {} {
1291 global cflist
1293 $cflist conf -state normal
1294 $cflist tag remove bold 1.0 end
1295 $cflist conf -state disabled
1298 proc add_flist {fl} {
1299 global cflist
1301 $cflist conf -state normal
1302 foreach f $fl {
1303 $cflist insert end "\n"
1304 $cflist insert end $f [highlight_tag $f]
1306 $cflist conf -state disabled
1309 proc sel_flist {w x y} {
1310 global ctext difffilestart cflist cflist_top cmitmode
1312 if {$cmitmode eq "tree"} return
1313 if {![info exists cflist_top]} return
1314 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1315 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1316 $cflist tag add highlight $l.0 "$l.0 lineend"
1317 set cflist_top $l
1318 if {$l == 1} {
1319 $ctext yview 1.0
1320 } else {
1321 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1325 # Functions for adding and removing shell-type quoting
1327 proc shellquote {str} {
1328 if {![string match "*\['\"\\ \t]*" $str]} {
1329 return $str
1331 if {![string match "*\['\"\\]*" $str]} {
1332 return "\"$str\""
1334 if {![string match "*'*" $str]} {
1335 return "'$str'"
1337 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1340 proc shellarglist {l} {
1341 set str {}
1342 foreach a $l {
1343 if {$str ne {}} {
1344 append str " "
1346 append str [shellquote $a]
1348 return $str
1351 proc shelldequote {str} {
1352 set ret {}
1353 set used -1
1354 while {1} {
1355 incr used
1356 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1357 append ret [string range $str $used end]
1358 set used [string length $str]
1359 break
1361 set first [lindex $first 0]
1362 set ch [string index $str $first]
1363 if {$first > $used} {
1364 append ret [string range $str $used [expr {$first - 1}]]
1365 set used $first
1367 if {$ch eq " " || $ch eq "\t"} break
1368 incr used
1369 if {$ch eq "'"} {
1370 set first [string first "'" $str $used]
1371 if {$first < 0} {
1372 error "unmatched single-quote"
1374 append ret [string range $str $used [expr {$first - 1}]]
1375 set used $first
1376 continue
1378 if {$ch eq "\\"} {
1379 if {$used >= [string length $str]} {
1380 error "trailing backslash"
1382 append ret [string index $str $used]
1383 continue
1385 # here ch == "\""
1386 while {1} {
1387 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1388 error "unmatched double-quote"
1390 set first [lindex $first 0]
1391 set ch [string index $str $first]
1392 if {$first > $used} {
1393 append ret [string range $str $used [expr {$first - 1}]]
1394 set used $first
1396 if {$ch eq "\""} break
1397 incr used
1398 append ret [string index $str $used]
1399 incr used
1402 return [list $used $ret]
1405 proc shellsplit {str} {
1406 set l {}
1407 while {1} {
1408 set str [string trimleft $str]
1409 if {$str eq {}} break
1410 set dq [shelldequote $str]
1411 set n [lindex $dq 0]
1412 set word [lindex $dq 1]
1413 set str [string range $str $n end]
1414 lappend l $word
1416 return $l
1419 # Code to implement multiple views
1421 proc newview {ishighlight} {
1422 global nextviewnum newviewname newviewperm uifont newishighlight
1423 global newviewargs revtreeargs
1425 set newishighlight $ishighlight
1426 set top .gitkview
1427 if {[winfo exists $top]} {
1428 raise $top
1429 return
1431 set newviewname($nextviewnum) "View $nextviewnum"
1432 set newviewperm($nextviewnum) 0
1433 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1434 vieweditor $top $nextviewnum "Gitk view definition"
1437 proc editview {} {
1438 global curview
1439 global viewname viewperm newviewname newviewperm
1440 global viewargs newviewargs
1442 set top .gitkvedit-$curview
1443 if {[winfo exists $top]} {
1444 raise $top
1445 return
1447 set newviewname($curview) $viewname($curview)
1448 set newviewperm($curview) $viewperm($curview)
1449 set newviewargs($curview) [shellarglist $viewargs($curview)]
1450 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1453 proc vieweditor {top n title} {
1454 global newviewname newviewperm viewfiles
1455 global uifont
1457 toplevel $top
1458 wm title $top $title
1459 label $top.nl -text "Name" -font $uifont
1460 entry $top.name -width 20 -textvariable newviewname($n)
1461 grid $top.nl $top.name -sticky w -pady 5
1462 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n)
1463 grid $top.perm - -pady 5 -sticky w
1464 message $top.al -aspect 1000 -font $uifont \
1465 -text "Commits to include (arguments to git rev-list):"
1466 grid $top.al - -sticky w -pady 5
1467 entry $top.args -width 50 -textvariable newviewargs($n) \
1468 -background white
1469 grid $top.args - -sticky ew -padx 5
1470 message $top.l -aspect 1000 -font $uifont \
1471 -text "Enter files and directories to include, one per line:"
1472 grid $top.l - -sticky w
1473 text $top.t -width 40 -height 10 -background white
1474 if {[info exists viewfiles($n)]} {
1475 foreach f $viewfiles($n) {
1476 $top.t insert end $f
1477 $top.t insert end "\n"
1479 $top.t delete {end - 1c} end
1480 $top.t mark set insert 0.0
1482 grid $top.t - -sticky ew -padx 5
1483 frame $top.buts
1484 button $top.buts.ok -text "OK" -command [list newviewok $top $n]
1485 button $top.buts.can -text "Cancel" -command [list destroy $top]
1486 grid $top.buts.ok $top.buts.can
1487 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1488 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1489 grid $top.buts - -pady 10 -sticky ew
1490 focus $top.t
1493 proc doviewmenu {m first cmd op argv} {
1494 set nmenu [$m index end]
1495 for {set i $first} {$i <= $nmenu} {incr i} {
1496 if {[$m entrycget $i -command] eq $cmd} {
1497 eval $m $op $i $argv
1498 break
1503 proc allviewmenus {n op args} {
1504 global viewhlmenu
1506 doviewmenu .bar.view 5 [list showview $n] $op $args
1507 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1510 proc newviewok {top n} {
1511 global nextviewnum newviewperm newviewname newishighlight
1512 global viewname viewfiles viewperm selectedview curview
1513 global viewargs newviewargs viewhlmenu
1515 if {[catch {
1516 set newargs [shellsplit $newviewargs($n)]
1517 } err]} {
1518 error_popup "Error in commit selection arguments: $err"
1519 wm raise $top
1520 focus $top
1521 return
1523 set files {}
1524 foreach f [split [$top.t get 0.0 end] "\n"] {
1525 set ft [string trim $f]
1526 if {$ft ne {}} {
1527 lappend files $ft
1530 if {![info exists viewfiles($n)]} {
1531 # creating a new view
1532 incr nextviewnum
1533 set viewname($n) $newviewname($n)
1534 set viewperm($n) $newviewperm($n)
1535 set viewfiles($n) $files
1536 set viewargs($n) $newargs
1537 addviewmenu $n
1538 if {!$newishighlight} {
1539 after idle showview $n
1540 } else {
1541 after idle addvhighlight $n
1543 } else {
1544 # editing an existing view
1545 set viewperm($n) $newviewperm($n)
1546 if {$newviewname($n) ne $viewname($n)} {
1547 set viewname($n) $newviewname($n)
1548 doviewmenu .bar.view 5 [list showview $n] \
1549 entryconf [list -label $viewname($n)]
1550 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1551 entryconf [list -label $viewname($n) -value $viewname($n)]
1553 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1554 set viewfiles($n) $files
1555 set viewargs($n) $newargs
1556 if {$curview == $n} {
1557 after idle updatecommits
1561 catch {destroy $top}
1564 proc delview {} {
1565 global curview viewdata viewperm hlview selectedhlview
1567 if {$curview == 0} return
1568 if {[info exists hlview] && $hlview == $curview} {
1569 set selectedhlview None
1570 unset hlview
1572 allviewmenus $curview delete
1573 set viewdata($curview) {}
1574 set viewperm($curview) 0
1575 showview 0
1578 proc addviewmenu {n} {
1579 global viewname viewhlmenu
1581 .bar.view add radiobutton -label $viewname($n) \
1582 -command [list showview $n] -variable selectedview -value $n
1583 $viewhlmenu add radiobutton -label $viewname($n) \
1584 -command [list addvhighlight $n] -variable selectedhlview
1587 proc flatten {var} {
1588 global $var
1590 set ret {}
1591 foreach i [array names $var] {
1592 lappend ret $i [set $var\($i\)]
1594 return $ret
1597 proc unflatten {var l} {
1598 global $var
1600 catch {unset $var}
1601 foreach {i v} $l {
1602 set $var\($i\) $v
1606 proc showview {n} {
1607 global curview viewdata viewfiles
1608 global displayorder parentlist childlist rowidlist rowoffsets
1609 global colormap rowtextx commitrow nextcolor canvxmax
1610 global numcommits rowrangelist commitlisted idrowranges
1611 global selectedline currentid canv canvy0
1612 global matchinglines treediffs
1613 global pending_select phase
1614 global commitidx rowlaidout rowoptim linesegends
1615 global commfd nextupdate
1616 global selectedview
1617 global vparentlist vchildlist vdisporder vcmitlisted
1618 global hlview selectedhlview
1620 if {$n == $curview} return
1621 set selid {}
1622 if {[info exists selectedline]} {
1623 set selid $currentid
1624 set y [yc $selectedline]
1625 set ymax [lindex [$canv cget -scrollregion] 3]
1626 set span [$canv yview]
1627 set ytop [expr {[lindex $span 0] * $ymax}]
1628 set ybot [expr {[lindex $span 1] * $ymax}]
1629 if {$ytop < $y && $y < $ybot} {
1630 set yscreen [expr {$y - $ytop}]
1631 } else {
1632 set yscreen [expr {($ybot - $ytop) / 2}]
1635 unselectline
1636 normalline
1637 stopfindproc
1638 if {$curview >= 0} {
1639 set vparentlist($curview) $parentlist
1640 set vchildlist($curview) $childlist
1641 set vdisporder($curview) $displayorder
1642 set vcmitlisted($curview) $commitlisted
1643 if {$phase ne {}} {
1644 set viewdata($curview) \
1645 [list $phase $rowidlist $rowoffsets $rowrangelist \
1646 [flatten idrowranges] [flatten idinlist] \
1647 $rowlaidout $rowoptim $numcommits $linesegends]
1648 } elseif {![info exists viewdata($curview)]
1649 || [lindex $viewdata($curview) 0] ne {}} {
1650 set viewdata($curview) \
1651 [list {} $rowidlist $rowoffsets $rowrangelist]
1654 catch {unset matchinglines}
1655 catch {unset treediffs}
1656 clear_display
1657 if {[info exists hlview] && $hlview == $n} {
1658 unset hlview
1659 set selectedhlview None
1662 set curview $n
1663 set selectedview $n
1664 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1665 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1667 if {![info exists viewdata($n)]} {
1668 set pending_select $selid
1669 getcommits
1670 return
1673 set v $viewdata($n)
1674 set phase [lindex $v 0]
1675 set displayorder $vdisporder($n)
1676 set parentlist $vparentlist($n)
1677 set childlist $vchildlist($n)
1678 set commitlisted $vcmitlisted($n)
1679 set rowidlist [lindex $v 1]
1680 set rowoffsets [lindex $v 2]
1681 set rowrangelist [lindex $v 3]
1682 if {$phase eq {}} {
1683 set numcommits [llength $displayorder]
1684 catch {unset idrowranges}
1685 } else {
1686 unflatten idrowranges [lindex $v 4]
1687 unflatten idinlist [lindex $v 5]
1688 set rowlaidout [lindex $v 6]
1689 set rowoptim [lindex $v 7]
1690 set numcommits [lindex $v 8]
1691 set linesegends [lindex $v 9]
1694 catch {unset colormap}
1695 catch {unset rowtextx}
1696 set nextcolor 0
1697 set canvxmax [$canv cget -width]
1698 set curview $n
1699 set row 0
1700 setcanvscroll
1701 set yf 0
1702 set row 0
1703 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1704 set row $commitrow($n,$selid)
1705 # try to get the selected row in the same position on the screen
1706 set ymax [lindex [$canv cget -scrollregion] 3]
1707 set ytop [expr {[yc $row] - $yscreen}]
1708 if {$ytop < 0} {
1709 set ytop 0
1711 set yf [expr {$ytop * 1.0 / $ymax}]
1713 allcanvs yview moveto $yf
1714 drawvisible
1715 selectline $row 0
1716 if {$phase ne {}} {
1717 if {$phase eq "getcommits"} {
1718 show_status "Reading commits..."
1720 if {[info exists commfd($n)]} {
1721 layoutmore {}
1722 } else {
1723 finishcommits
1725 } elseif {$numcommits == 0} {
1726 show_status "No commits selected"
1730 # Stuff relating to the highlighting facility
1732 proc ishighlighted {row} {
1733 global vhighlights fhighlights nhighlights rhighlights
1735 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1736 return $nhighlights($row)
1738 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1739 return $vhighlights($row)
1741 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1742 return $fhighlights($row)
1744 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1745 return $rhighlights($row)
1747 return 0
1750 proc bolden {row font} {
1751 global canv linehtag selectedline boldrows
1753 lappend boldrows $row
1754 $canv itemconf $linehtag($row) -font $font
1755 if {[info exists selectedline] && $row == $selectedline} {
1756 $canv delete secsel
1757 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1758 -outline {{}} -tags secsel \
1759 -fill [$canv cget -selectbackground]]
1760 $canv lower $t
1764 proc bolden_name {row font} {
1765 global canv2 linentag selectedline boldnamerows
1767 lappend boldnamerows $row
1768 $canv2 itemconf $linentag($row) -font $font
1769 if {[info exists selectedline] && $row == $selectedline} {
1770 $canv2 delete secsel
1771 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1772 -outline {{}} -tags secsel \
1773 -fill [$canv2 cget -selectbackground]]
1774 $canv2 lower $t
1778 proc unbolden {} {
1779 global mainfont boldrows
1781 set stillbold {}
1782 foreach row $boldrows {
1783 if {![ishighlighted $row]} {
1784 bolden $row $mainfont
1785 } else {
1786 lappend stillbold $row
1789 set boldrows $stillbold
1792 proc addvhighlight {n} {
1793 global hlview curview viewdata vhl_done vhighlights commitidx
1795 if {[info exists hlview]} {
1796 delvhighlight
1798 set hlview $n
1799 if {$n != $curview && ![info exists viewdata($n)]} {
1800 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1801 set vparentlist($n) {}
1802 set vchildlist($n) {}
1803 set vdisporder($n) {}
1804 set vcmitlisted($n) {}
1805 start_rev_list $n
1807 set vhl_done $commitidx($hlview)
1808 if {$vhl_done > 0} {
1809 drawvisible
1813 proc delvhighlight {} {
1814 global hlview vhighlights
1816 if {![info exists hlview]} return
1817 unset hlview
1818 catch {unset vhighlights}
1819 unbolden
1822 proc vhighlightmore {} {
1823 global hlview vhl_done commitidx vhighlights
1824 global displayorder vdisporder curview mainfont
1826 set font [concat $mainfont bold]
1827 set max $commitidx($hlview)
1828 if {$hlview == $curview} {
1829 set disp $displayorder
1830 } else {
1831 set disp $vdisporder($hlview)
1833 set vr [visiblerows]
1834 set r0 [lindex $vr 0]
1835 set r1 [lindex $vr 1]
1836 for {set i $vhl_done} {$i < $max} {incr i} {
1837 set id [lindex $disp $i]
1838 if {[info exists commitrow($curview,$id)]} {
1839 set row $commitrow($curview,$id)
1840 if {$r0 <= $row && $row <= $r1} {
1841 if {![highlighted $row]} {
1842 bolden $row $font
1844 set vhighlights($row) 1
1848 set vhl_done $max
1851 proc askvhighlight {row id} {
1852 global hlview vhighlights commitrow iddrawn mainfont
1854 if {[info exists commitrow($hlview,$id)]} {
1855 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
1856 bolden $row [concat $mainfont bold]
1858 set vhighlights($row) 1
1859 } else {
1860 set vhighlights($row) 0
1864 proc hfiles_change {name ix op} {
1865 global highlight_files filehighlight fhighlights fh_serial
1866 global mainfont highlight_paths
1868 if {[info exists filehighlight]} {
1869 # delete previous highlights
1870 catch {close $filehighlight}
1871 unset filehighlight
1872 catch {unset fhighlights}
1873 unbolden
1874 unhighlight_filelist
1876 set highlight_paths {}
1877 after cancel do_file_hl $fh_serial
1878 incr fh_serial
1879 if {$highlight_files ne {}} {
1880 after 300 do_file_hl $fh_serial
1884 proc makepatterns {l} {
1885 set ret {}
1886 foreach e $l {
1887 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
1888 if {[string index $ee end] eq "/"} {
1889 lappend ret "$ee*"
1890 } else {
1891 lappend ret $ee
1892 lappend ret "$ee/*"
1895 return $ret
1898 proc do_file_hl {serial} {
1899 global highlight_files filehighlight highlight_paths gdttype fhl_list
1901 if {$gdttype eq "touching paths:"} {
1902 if {[catch {set paths [shellsplit $highlight_files]}]} return
1903 set highlight_paths [makepatterns $paths]
1904 highlight_filelist
1905 set gdtargs [concat -- $paths]
1906 } else {
1907 set gdtargs [list "-S$highlight_files"]
1909 set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
1910 set filehighlight [open $cmd r+]
1911 fconfigure $filehighlight -blocking 0
1912 fileevent $filehighlight readable readfhighlight
1913 set fhl_list {}
1914 drawvisible
1915 flushhighlights
1918 proc flushhighlights {} {
1919 global filehighlight fhl_list
1921 if {[info exists filehighlight]} {
1922 lappend fhl_list {}
1923 puts $filehighlight ""
1924 flush $filehighlight
1928 proc askfilehighlight {row id} {
1929 global filehighlight fhighlights fhl_list
1931 lappend fhl_list $id
1932 set fhighlights($row) -1
1933 puts $filehighlight $id
1936 proc readfhighlight {} {
1937 global filehighlight fhighlights commitrow curview mainfont iddrawn
1938 global fhl_list
1940 while {[gets $filehighlight line] >= 0} {
1941 set line [string trim $line]
1942 set i [lsearch -exact $fhl_list $line]
1943 if {$i < 0} continue
1944 for {set j 0} {$j < $i} {incr j} {
1945 set id [lindex $fhl_list $j]
1946 if {[info exists commitrow($curview,$id)]} {
1947 set fhighlights($commitrow($curview,$id)) 0
1950 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
1951 if {$line eq {}} continue
1952 if {![info exists commitrow($curview,$line)]} continue
1953 set row $commitrow($curview,$line)
1954 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
1955 bolden $row [concat $mainfont bold]
1957 set fhighlights($row) 1
1959 if {[eof $filehighlight]} {
1960 # strange...
1961 puts "oops, git diff-tree died"
1962 catch {close $filehighlight}
1963 unset filehighlight
1965 next_hlcont
1968 proc find_change {name ix op} {
1969 global nhighlights mainfont boldnamerows
1970 global findstring findpattern findtype
1972 # delete previous highlights, if any
1973 foreach row $boldnamerows {
1974 bolden_name $row $mainfont
1976 set boldnamerows {}
1977 catch {unset nhighlights}
1978 unbolden
1979 if {$findtype ne "Regexp"} {
1980 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
1981 $findstring]
1982 set findpattern "*$e*"
1984 drawvisible
1987 proc askfindhighlight {row id} {
1988 global nhighlights commitinfo iddrawn mainfont
1989 global findstring findtype findloc findpattern
1991 if {![info exists commitinfo($id)]} {
1992 getcommit $id
1994 set info $commitinfo($id)
1995 set isbold 0
1996 set fldtypes {Headline Author Date Committer CDate Comments}
1997 foreach f $info ty $fldtypes {
1998 if {$findloc ne "All fields" && $findloc ne $ty} {
1999 continue
2001 if {$findtype eq "Regexp"} {
2002 set doesmatch [regexp $findstring $f]
2003 } elseif {$findtype eq "IgnCase"} {
2004 set doesmatch [string match -nocase $findpattern $f]
2005 } else {
2006 set doesmatch [string match $findpattern $f]
2008 if {$doesmatch} {
2009 if {$ty eq "Author"} {
2010 set isbold 2
2011 } else {
2012 set isbold 1
2016 if {[info exists iddrawn($id)]} {
2017 if {$isbold && ![ishighlighted $row]} {
2018 bolden $row [concat $mainfont bold]
2020 if {$isbold >= 2} {
2021 bolden_name $row [concat $mainfont bold]
2024 set nhighlights($row) $isbold
2027 proc vrel_change {name ix op} {
2028 global highlight_related
2030 rhighlight_none
2031 if {$highlight_related ne "None"} {
2032 after idle drawvisible
2036 # prepare for testing whether commits are descendents or ancestors of a
2037 proc rhighlight_sel {a} {
2038 global descendent desc_todo ancestor anc_todo
2039 global highlight_related rhighlights
2041 catch {unset descendent}
2042 set desc_todo [list $a]
2043 catch {unset ancestor}
2044 set anc_todo [list $a]
2045 if {$highlight_related ne "None"} {
2046 rhighlight_none
2047 after idle drawvisible
2051 proc rhighlight_none {} {
2052 global rhighlights
2054 catch {unset rhighlights}
2055 unbolden
2058 proc is_descendent {a} {
2059 global curview children commitrow descendent desc_todo
2061 set v $curview
2062 set la $commitrow($v,$a)
2063 set todo $desc_todo
2064 set leftover {}
2065 set done 0
2066 for {set i 0} {$i < [llength $todo]} {incr i} {
2067 set do [lindex $todo $i]
2068 if {$commitrow($v,$do) < $la} {
2069 lappend leftover $do
2070 continue
2072 foreach nk $children($v,$do) {
2073 if {![info exists descendent($nk)]} {
2074 set descendent($nk) 1
2075 lappend todo $nk
2076 if {$nk eq $a} {
2077 set done 1
2081 if {$done} {
2082 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2083 return
2086 set descendent($a) 0
2087 set desc_todo $leftover
2090 proc is_ancestor {a} {
2091 global curview parentlist commitrow ancestor anc_todo
2093 set v $curview
2094 set la $commitrow($v,$a)
2095 set todo $anc_todo
2096 set leftover {}
2097 set done 0
2098 for {set i 0} {$i < [llength $todo]} {incr i} {
2099 set do [lindex $todo $i]
2100 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2101 lappend leftover $do
2102 continue
2104 foreach np [lindex $parentlist $commitrow($v,$do)] {
2105 if {![info exists ancestor($np)]} {
2106 set ancestor($np) 1
2107 lappend todo $np
2108 if {$np eq $a} {
2109 set done 1
2113 if {$done} {
2114 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2115 return
2118 set ancestor($a) 0
2119 set anc_todo $leftover
2122 proc askrelhighlight {row id} {
2123 global descendent highlight_related iddrawn mainfont rhighlights
2124 global selectedline ancestor
2126 if {![info exists selectedline]} return
2127 set isbold 0
2128 if {$highlight_related eq "Descendent" ||
2129 $highlight_related eq "Not descendent"} {
2130 if {![info exists descendent($id)]} {
2131 is_descendent $id
2133 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2134 set isbold 1
2136 } elseif {$highlight_related eq "Ancestor" ||
2137 $highlight_related eq "Not ancestor"} {
2138 if {![info exists ancestor($id)]} {
2139 is_ancestor $id
2141 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2142 set isbold 1
2145 if {[info exists iddrawn($id)]} {
2146 if {$isbold && ![ishighlighted $row]} {
2147 bolden $row [concat $mainfont bold]
2150 set rhighlights($row) $isbold
2153 proc next_hlcont {} {
2154 global fhl_row fhl_dirn displayorder numcommits
2155 global vhighlights fhighlights nhighlights rhighlights
2156 global hlview filehighlight findstring highlight_related
2158 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2159 set row $fhl_row
2160 while {1} {
2161 if {$row < 0 || $row >= $numcommits} {
2162 bell
2163 set fhl_dirn 0
2164 return
2166 set id [lindex $displayorder $row]
2167 if {[info exists hlview]} {
2168 if {![info exists vhighlights($row)]} {
2169 askvhighlight $row $id
2171 if {$vhighlights($row) > 0} break
2173 if {$findstring ne {}} {
2174 if {![info exists nhighlights($row)]} {
2175 askfindhighlight $row $id
2177 if {$nhighlights($row) > 0} break
2179 if {$highlight_related ne "None"} {
2180 if {![info exists rhighlights($row)]} {
2181 askrelhighlight $row $id
2183 if {$rhighlights($row) > 0} break
2185 if {[info exists filehighlight]} {
2186 if {![info exists fhighlights($row)]} {
2187 # ask for a few more while we're at it...
2188 set r $row
2189 for {set n 0} {$n < 100} {incr n} {
2190 if {![info exists fhighlights($r)]} {
2191 askfilehighlight $r [lindex $displayorder $r]
2193 incr r $fhl_dirn
2194 if {$r < 0 || $r >= $numcommits} break
2196 flushhighlights
2198 if {$fhighlights($row) < 0} {
2199 set fhl_row $row
2200 return
2202 if {$fhighlights($row) > 0} break
2204 incr row $fhl_dirn
2206 set fhl_dirn 0
2207 selectline $row 1
2210 proc next_highlight {dirn} {
2211 global selectedline fhl_row fhl_dirn
2212 global hlview filehighlight findstring highlight_related
2214 if {![info exists selectedline]} return
2215 if {!([info exists hlview] || $findstring ne {} ||
2216 $highlight_related ne "None" || [info exists filehighlight])} return
2217 set fhl_row [expr {$selectedline + $dirn}]
2218 set fhl_dirn $dirn
2219 next_hlcont
2222 proc cancel_next_highlight {} {
2223 global fhl_dirn
2225 set fhl_dirn 0
2228 # Graph layout functions
2230 proc shortids {ids} {
2231 set res {}
2232 foreach id $ids {
2233 if {[llength $id] > 1} {
2234 lappend res [shortids $id]
2235 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2236 lappend res [string range $id 0 7]
2237 } else {
2238 lappend res $id
2241 return $res
2244 proc incrange {l x o} {
2245 set n [llength $l]
2246 while {$x < $n} {
2247 set e [lindex $l $x]
2248 if {$e ne {}} {
2249 lset l $x [expr {$e + $o}]
2251 incr x
2253 return $l
2256 proc ntimes {n o} {
2257 set ret {}
2258 for {} {$n > 0} {incr n -1} {
2259 lappend ret $o
2261 return $ret
2264 proc usedinrange {id l1 l2} {
2265 global children commitrow childlist curview
2267 if {[info exists commitrow($curview,$id)]} {
2268 set r $commitrow($curview,$id)
2269 if {$l1 <= $r && $r <= $l2} {
2270 return [expr {$r - $l1 + 1}]
2272 set kids [lindex $childlist $r]
2273 } else {
2274 set kids $children($curview,$id)
2276 foreach c $kids {
2277 set r $commitrow($curview,$c)
2278 if {$l1 <= $r && $r <= $l2} {
2279 return [expr {$r - $l1 + 1}]
2282 return 0
2285 proc sanity {row {full 0}} {
2286 global rowidlist rowoffsets
2288 set col -1
2289 set ids [lindex $rowidlist $row]
2290 foreach id $ids {
2291 incr col
2292 if {$id eq {}} continue
2293 if {$col < [llength $ids] - 1 &&
2294 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2295 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2297 set o [lindex $rowoffsets $row $col]
2298 set y $row
2299 set x $col
2300 while {$o ne {}} {
2301 incr y -1
2302 incr x $o
2303 if {[lindex $rowidlist $y $x] != $id} {
2304 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2305 puts " id=[shortids $id] check started at row $row"
2306 for {set i $row} {$i >= $y} {incr i -1} {
2307 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2309 break
2311 if {!$full} break
2312 set o [lindex $rowoffsets $y $x]
2317 proc makeuparrow {oid x y z} {
2318 global rowidlist rowoffsets uparrowlen idrowranges
2320 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2321 incr y -1
2322 incr x $z
2323 set off0 [lindex $rowoffsets $y]
2324 for {set x0 $x} {1} {incr x0} {
2325 if {$x0 >= [llength $off0]} {
2326 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2327 break
2329 set z [lindex $off0 $x0]
2330 if {$z ne {}} {
2331 incr x0 $z
2332 break
2335 set z [expr {$x0 - $x}]
2336 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2337 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2339 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2340 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2341 lappend idrowranges($oid) $y
2344 proc initlayout {} {
2345 global rowidlist rowoffsets displayorder commitlisted
2346 global rowlaidout rowoptim
2347 global idinlist rowchk rowrangelist idrowranges
2348 global numcommits canvxmax canv
2349 global nextcolor
2350 global parentlist childlist children
2351 global colormap rowtextx
2352 global linesegends
2354 set numcommits 0
2355 set displayorder {}
2356 set commitlisted {}
2357 set parentlist {}
2358 set childlist {}
2359 set rowrangelist {}
2360 set nextcolor 0
2361 set rowidlist {{}}
2362 set rowoffsets {{}}
2363 catch {unset idinlist}
2364 catch {unset rowchk}
2365 set rowlaidout 0
2366 set rowoptim 0
2367 set canvxmax [$canv cget -width]
2368 catch {unset colormap}
2369 catch {unset rowtextx}
2370 catch {unset idrowranges}
2371 set linesegends {}
2374 proc setcanvscroll {} {
2375 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2377 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2378 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2379 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2380 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2383 proc visiblerows {} {
2384 global canv numcommits linespc
2386 set ymax [lindex [$canv cget -scrollregion] 3]
2387 if {$ymax eq {} || $ymax == 0} return
2388 set f [$canv yview]
2389 set y0 [expr {int([lindex $f 0] * $ymax)}]
2390 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2391 if {$r0 < 0} {
2392 set r0 0
2394 set y1 [expr {int([lindex $f 1] * $ymax)}]
2395 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2396 if {$r1 >= $numcommits} {
2397 set r1 [expr {$numcommits - 1}]
2399 return [list $r0 $r1]
2402 proc layoutmore {tmax} {
2403 global rowlaidout rowoptim commitidx numcommits optim_delay
2404 global uparrowlen curview
2406 while {1} {
2407 if {$rowoptim - $optim_delay > $numcommits} {
2408 showstuff [expr {$rowoptim - $optim_delay}]
2409 } elseif {$rowlaidout - $uparrowlen - 1 > $rowoptim} {
2410 set nr [expr {$rowlaidout - $uparrowlen - 1 - $rowoptim}]
2411 if {$nr > 100} {
2412 set nr 100
2414 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2415 incr rowoptim $nr
2416 } elseif {$commitidx($curview) > $rowlaidout} {
2417 set nr [expr {$commitidx($curview) - $rowlaidout}]
2418 # may need to increase this threshold if uparrowlen or
2419 # mingaplen are increased...
2420 if {$nr > 150} {
2421 set nr 150
2423 set row $rowlaidout
2424 set rowlaidout [layoutrows $row [expr {$row + $nr}] 0]
2425 if {$rowlaidout == $row} {
2426 return 0
2428 } else {
2429 return 0
2431 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2432 return 1
2437 proc showstuff {canshow} {
2438 global numcommits commitrow pending_select selectedline
2439 global linesegends idrowranges idrangedrawn curview
2441 if {$numcommits == 0} {
2442 global phase
2443 set phase "incrdraw"
2444 allcanvs delete all
2446 set row $numcommits
2447 set numcommits $canshow
2448 setcanvscroll
2449 set rows [visiblerows]
2450 set r0 [lindex $rows 0]
2451 set r1 [lindex $rows 1]
2452 set selrow -1
2453 for {set r $row} {$r < $canshow} {incr r} {
2454 foreach id [lindex $linesegends [expr {$r+1}]] {
2455 set i -1
2456 foreach {s e} [rowranges $id] {
2457 incr i
2458 if {$e ne {} && $e < $numcommits && $s <= $r1 && $e >= $r0
2459 && ![info exists idrangedrawn($id,$i)]} {
2460 drawlineseg $id $i
2461 set idrangedrawn($id,$i) 1
2466 if {$canshow > $r1} {
2467 set canshow $r1
2469 while {$row < $canshow} {
2470 drawcmitrow $row
2471 incr row
2473 if {[info exists pending_select] &&
2474 [info exists commitrow($curview,$pending_select)] &&
2475 $commitrow($curview,$pending_select) < $numcommits} {
2476 selectline $commitrow($curview,$pending_select) 1
2478 if {![info exists selectedline] && ![info exists pending_select]} {
2479 selectline 0 1
2483 proc layoutrows {row endrow last} {
2484 global rowidlist rowoffsets displayorder
2485 global uparrowlen downarrowlen maxwidth mingaplen
2486 global childlist parentlist
2487 global idrowranges linesegends
2488 global commitidx curview
2489 global idinlist rowchk rowrangelist
2491 set idlist [lindex $rowidlist $row]
2492 set offs [lindex $rowoffsets $row]
2493 while {$row < $endrow} {
2494 set id [lindex $displayorder $row]
2495 set oldolds {}
2496 set newolds {}
2497 foreach p [lindex $parentlist $row] {
2498 if {![info exists idinlist($p)]} {
2499 lappend newolds $p
2500 } elseif {!$idinlist($p)} {
2501 lappend oldolds $p
2504 set lse {}
2505 set nev [expr {[llength $idlist] + [llength $newolds]
2506 + [llength $oldolds] - $maxwidth + 1}]
2507 if {$nev > 0} {
2508 if {!$last &&
2509 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2510 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2511 set i [lindex $idlist $x]
2512 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2513 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2514 [expr {$row + $uparrowlen + $mingaplen}]]
2515 if {$r == 0} {
2516 set idlist [lreplace $idlist $x $x]
2517 set offs [lreplace $offs $x $x]
2518 set offs [incrange $offs $x 1]
2519 set idinlist($i) 0
2520 set rm1 [expr {$row - 1}]
2521 lappend lse $i
2522 lappend idrowranges($i) $rm1
2523 if {[incr nev -1] <= 0} break
2524 continue
2526 set rowchk($id) [expr {$row + $r}]
2529 lset rowidlist $row $idlist
2530 lset rowoffsets $row $offs
2532 lappend linesegends $lse
2533 set col [lsearch -exact $idlist $id]
2534 if {$col < 0} {
2535 set col [llength $idlist]
2536 lappend idlist $id
2537 lset rowidlist $row $idlist
2538 set z {}
2539 if {[lindex $childlist $row] ne {}} {
2540 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2541 unset idinlist($id)
2543 lappend offs $z
2544 lset rowoffsets $row $offs
2545 if {$z ne {}} {
2546 makeuparrow $id $col $row $z
2548 } else {
2549 unset idinlist($id)
2551 set ranges {}
2552 if {[info exists idrowranges($id)]} {
2553 set ranges $idrowranges($id)
2554 lappend ranges $row
2555 unset idrowranges($id)
2557 lappend rowrangelist $ranges
2558 incr row
2559 set offs [ntimes [llength $idlist] 0]
2560 set l [llength $newolds]
2561 set idlist [eval lreplace \$idlist $col $col $newolds]
2562 set o 0
2563 if {$l != 1} {
2564 set offs [lrange $offs 0 [expr {$col - 1}]]
2565 foreach x $newolds {
2566 lappend offs {}
2567 incr o -1
2569 incr o
2570 set tmp [expr {[llength $idlist] - [llength $offs]}]
2571 if {$tmp > 0} {
2572 set offs [concat $offs [ntimes $tmp $o]]
2574 } else {
2575 lset offs $col {}
2577 foreach i $newolds {
2578 set idinlist($i) 1
2579 set idrowranges($i) $row
2581 incr col $l
2582 foreach oid $oldolds {
2583 set idinlist($oid) 1
2584 set idlist [linsert $idlist $col $oid]
2585 set offs [linsert $offs $col $o]
2586 makeuparrow $oid $col $row $o
2587 incr col
2589 lappend rowidlist $idlist
2590 lappend rowoffsets $offs
2592 return $row
2595 proc addextraid {id row} {
2596 global displayorder commitrow commitinfo
2597 global commitidx commitlisted
2598 global parentlist childlist children curview
2600 incr commitidx($curview)
2601 lappend displayorder $id
2602 lappend commitlisted 0
2603 lappend parentlist {}
2604 set commitrow($curview,$id) $row
2605 readcommit $id
2606 if {![info exists commitinfo($id)]} {
2607 set commitinfo($id) {"No commit information available"}
2609 if {![info exists children($curview,$id)]} {
2610 set children($curview,$id) {}
2612 lappend childlist $children($curview,$id)
2615 proc layouttail {} {
2616 global rowidlist rowoffsets idinlist commitidx curview
2617 global idrowranges rowrangelist
2619 set row $commitidx($curview)
2620 set idlist [lindex $rowidlist $row]
2621 while {$idlist ne {}} {
2622 set col [expr {[llength $idlist] - 1}]
2623 set id [lindex $idlist $col]
2624 addextraid $id $row
2625 unset idinlist($id)
2626 lappend idrowranges($id) $row
2627 lappend rowrangelist $idrowranges($id)
2628 unset idrowranges($id)
2629 incr row
2630 set offs [ntimes $col 0]
2631 set idlist [lreplace $idlist $col $col]
2632 lappend rowidlist $idlist
2633 lappend rowoffsets $offs
2636 foreach id [array names idinlist] {
2637 addextraid $id $row
2638 lset rowidlist $row [list $id]
2639 lset rowoffsets $row 0
2640 makeuparrow $id 0 $row 0
2641 lappend idrowranges($id) $row
2642 lappend rowrangelist $idrowranges($id)
2643 unset idrowranges($id)
2644 incr row
2645 lappend rowidlist {}
2646 lappend rowoffsets {}
2650 proc insert_pad {row col npad} {
2651 global rowidlist rowoffsets
2653 set pad [ntimes $npad {}]
2654 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2655 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2656 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2659 proc optimize_rows {row col endrow} {
2660 global rowidlist rowoffsets idrowranges displayorder
2662 for {} {$row < $endrow} {incr row} {
2663 set idlist [lindex $rowidlist $row]
2664 set offs [lindex $rowoffsets $row]
2665 set haspad 0
2666 for {} {$col < [llength $offs]} {incr col} {
2667 if {[lindex $idlist $col] eq {}} {
2668 set haspad 1
2669 continue
2671 set z [lindex $offs $col]
2672 if {$z eq {}} continue
2673 set isarrow 0
2674 set x0 [expr {$col + $z}]
2675 set y0 [expr {$row - 1}]
2676 set z0 [lindex $rowoffsets $y0 $x0]
2677 if {$z0 eq {}} {
2678 set id [lindex $idlist $col]
2679 set ranges [rowranges $id]
2680 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2681 set isarrow 1
2684 if {$z < -1 || ($z < 0 && $isarrow)} {
2685 set npad [expr {-1 - $z + $isarrow}]
2686 set offs [incrange $offs $col $npad]
2687 insert_pad $y0 $x0 $npad
2688 if {$y0 > 0} {
2689 optimize_rows $y0 $x0 $row
2691 set z [lindex $offs $col]
2692 set x0 [expr {$col + $z}]
2693 set z0 [lindex $rowoffsets $y0 $x0]
2694 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2695 set npad [expr {$z - 1 + $isarrow}]
2696 set y1 [expr {$row + 1}]
2697 set offs2 [lindex $rowoffsets $y1]
2698 set x1 -1
2699 foreach z $offs2 {
2700 incr x1
2701 if {$z eq {} || $x1 + $z < $col} continue
2702 if {$x1 + $z > $col} {
2703 incr npad
2705 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2706 break
2708 set pad [ntimes $npad {}]
2709 set idlist [eval linsert \$idlist $col $pad]
2710 set tmp [eval linsert \$offs $col $pad]
2711 incr col $npad
2712 set offs [incrange $tmp $col [expr {-$npad}]]
2713 set z [lindex $offs $col]
2714 set haspad 1
2716 if {$z0 eq {} && !$isarrow} {
2717 # this line links to its first child on row $row-2
2718 set rm2 [expr {$row - 2}]
2719 set id [lindex $displayorder $rm2]
2720 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2721 if {$xc >= 0} {
2722 set z0 [expr {$xc - $x0}]
2725 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2726 insert_pad $y0 $x0 1
2727 set offs [incrange $offs $col 1]
2728 optimize_rows $y0 [expr {$x0 + 1}] $row
2731 if {!$haspad} {
2732 set o {}
2733 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
2734 set o [lindex $offs $col]
2735 if {$o eq {}} {
2736 # check if this is the link to the first child
2737 set id [lindex $idlist $col]
2738 set ranges [rowranges $id]
2739 if {$ranges ne {} && $row == [lindex $ranges 0]} {
2740 # it is, work out offset to child
2741 set y0 [expr {$row - 1}]
2742 set id [lindex $displayorder $y0]
2743 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
2744 if {$x0 >= 0} {
2745 set o [expr {$x0 - $col}]
2749 if {$o eq {} || $o <= 0} break
2751 if {$o ne {} && [incr col] < [llength $idlist]} {
2752 set y1 [expr {$row + 1}]
2753 set offs2 [lindex $rowoffsets $y1]
2754 set x1 -1
2755 foreach z $offs2 {
2756 incr x1
2757 if {$z eq {} || $x1 + $z < $col} continue
2758 lset rowoffsets $y1 [incrange $offs2 $x1 1]
2759 break
2761 set idlist [linsert $idlist $col {}]
2762 set tmp [linsert $offs $col {}]
2763 incr col
2764 set offs [incrange $tmp $col -1]
2767 lset rowidlist $row $idlist
2768 lset rowoffsets $row $offs
2769 set col 0
2773 proc xc {row col} {
2774 global canvx0 linespc
2775 return [expr {$canvx0 + $col * $linespc}]
2778 proc yc {row} {
2779 global canvy0 linespc
2780 return [expr {$canvy0 + $row * $linespc}]
2783 proc linewidth {id} {
2784 global thickerline lthickness
2786 set wid $lthickness
2787 if {[info exists thickerline] && $id eq $thickerline} {
2788 set wid [expr {2 * $lthickness}]
2790 return $wid
2793 proc rowranges {id} {
2794 global phase idrowranges commitrow rowlaidout rowrangelist curview
2796 set ranges {}
2797 if {$phase eq {} ||
2798 ([info exists commitrow($curview,$id)]
2799 && $commitrow($curview,$id) < $rowlaidout)} {
2800 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
2801 } elseif {[info exists idrowranges($id)]} {
2802 set ranges $idrowranges($id)
2804 return $ranges
2807 proc drawlineseg {id i} {
2808 global rowoffsets rowidlist
2809 global displayorder
2810 global canv colormap linespc
2811 global numcommits commitrow curview
2813 set ranges [rowranges $id]
2814 set downarrow 1
2815 if {[info exists commitrow($curview,$id)]
2816 && $commitrow($curview,$id) < $numcommits} {
2817 set downarrow [expr {$i < [llength $ranges] / 2 - 1}]
2818 } else {
2819 set downarrow 1
2821 set startrow [lindex $ranges [expr {2 * $i}]]
2822 set row [lindex $ranges [expr {2 * $i + 1}]]
2823 if {$startrow == $row} return
2824 assigncolor $id
2825 set coords {}
2826 set col [lsearch -exact [lindex $rowidlist $row] $id]
2827 if {$col < 0} {
2828 puts "oops: drawline: id $id not on row $row"
2829 return
2831 set lasto {}
2832 set ns 0
2833 while {1} {
2834 set o [lindex $rowoffsets $row $col]
2835 if {$o eq {}} break
2836 if {$o ne $lasto} {
2837 # changing direction
2838 set x [xc $row $col]
2839 set y [yc $row]
2840 lappend coords $x $y
2841 set lasto $o
2843 incr col $o
2844 incr row -1
2846 set x [xc $row $col]
2847 set y [yc $row]
2848 lappend coords $x $y
2849 if {$i == 0} {
2850 # draw the link to the first child as part of this line
2851 incr row -1
2852 set child [lindex $displayorder $row]
2853 set ccol [lsearch -exact [lindex $rowidlist $row] $child]
2854 if {$ccol >= 0} {
2855 set x [xc $row $ccol]
2856 set y [yc $row]
2857 if {$ccol < $col - 1} {
2858 lappend coords [xc $row [expr {$col - 1}]] [yc $row]
2859 } elseif {$ccol > $col + 1} {
2860 lappend coords [xc $row [expr {$col + 1}]] [yc $row]
2862 lappend coords $x $y
2865 if {[llength $coords] < 4} return
2866 if {$downarrow} {
2867 # This line has an arrow at the lower end: check if the arrow is
2868 # on a diagonal segment, and if so, work around the Tk 8.4
2869 # refusal to draw arrows on diagonal lines.
2870 set x0 [lindex $coords 0]
2871 set x1 [lindex $coords 2]
2872 if {$x0 != $x1} {
2873 set y0 [lindex $coords 1]
2874 set y1 [lindex $coords 3]
2875 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
2876 # we have a nearby vertical segment, just trim off the diag bit
2877 set coords [lrange $coords 2 end]
2878 } else {
2879 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
2880 set xi [expr {$x0 - $slope * $linespc / 2}]
2881 set yi [expr {$y0 - $linespc / 2}]
2882 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
2886 set arrow [expr {2 * ($i > 0) + $downarrow}]
2887 set arrow [lindex {none first last both} $arrow]
2888 set t [$canv create line $coords -width [linewidth $id] \
2889 -fill $colormap($id) -tags lines.$id -arrow $arrow]
2890 $canv lower $t
2891 bindline $t $id
2894 proc drawparentlinks {id row col olds} {
2895 global rowidlist canv colormap
2897 set row2 [expr {$row + 1}]
2898 set x [xc $row $col]
2899 set y [yc $row]
2900 set y2 [yc $row2]
2901 set ids [lindex $rowidlist $row2]
2902 # rmx = right-most X coord used
2903 set rmx 0
2904 foreach p $olds {
2905 set i [lsearch -exact $ids $p]
2906 if {$i < 0} {
2907 puts "oops, parent $p of $id not in list"
2908 continue
2910 set x2 [xc $row2 $i]
2911 if {$x2 > $rmx} {
2912 set rmx $x2
2914 set ranges [rowranges $p]
2915 if {$ranges ne {} && $row2 == [lindex $ranges 0]
2916 && $row2 < [lindex $ranges 1]} {
2917 # drawlineseg will do this one for us
2918 continue
2920 assigncolor $p
2921 # should handle duplicated parents here...
2922 set coords [list $x $y]
2923 if {$i < $col - 1} {
2924 lappend coords [xc $row [expr {$i + 1}]] $y
2925 } elseif {$i > $col + 1} {
2926 lappend coords [xc $row [expr {$i - 1}]] $y
2928 lappend coords $x2 $y2
2929 set t [$canv create line $coords -width [linewidth $p] \
2930 -fill $colormap($p) -tags lines.$p]
2931 $canv lower $t
2932 bindline $t $p
2934 return $rmx
2937 proc drawlines {id} {
2938 global colormap canv
2939 global idrangedrawn
2940 global children iddrawn commitrow rowidlist curview
2942 $canv delete lines.$id
2943 set nr [expr {[llength [rowranges $id]] / 2}]
2944 for {set i 0} {$i < $nr} {incr i} {
2945 if {[info exists idrangedrawn($id,$i)]} {
2946 drawlineseg $id $i
2949 foreach child $children($curview,$id) {
2950 if {[info exists iddrawn($child)]} {
2951 set row $commitrow($curview,$child)
2952 set col [lsearch -exact [lindex $rowidlist $row] $child]
2953 if {$col >= 0} {
2954 drawparentlinks $child $row $col [list $id]
2960 proc drawcmittext {id row col rmx} {
2961 global linespc canv canv2 canv3 canvy0 fgcolor
2962 global commitlisted commitinfo rowidlist
2963 global rowtextx idpos idtags idheads idotherrefs
2964 global linehtag linentag linedtag
2965 global mainfont canvxmax boldrows boldnamerows fgcolor
2967 set ofill [expr {[lindex $commitlisted $row]? "blue": "white"}]
2968 set x [xc $row $col]
2969 set y [yc $row]
2970 set orad [expr {$linespc / 3}]
2971 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
2972 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
2973 -fill $ofill -outline $fgcolor -width 1 -tags circle]
2974 $canv raise $t
2975 $canv bind $t <1> {selcanvline {} %x %y}
2976 set xt [xc $row [llength [lindex $rowidlist $row]]]
2977 if {$xt < $rmx} {
2978 set xt $rmx
2980 set rowtextx($row) $xt
2981 set idpos($id) [list $x $xt $y]
2982 if {[info exists idtags($id)] || [info exists idheads($id)]
2983 || [info exists idotherrefs($id)]} {
2984 set xt [drawtags $id $x $xt $y]
2986 set headline [lindex $commitinfo($id) 0]
2987 set name [lindex $commitinfo($id) 1]
2988 set date [lindex $commitinfo($id) 2]
2989 set date [formatdate $date]
2990 set font $mainfont
2991 set nfont $mainfont
2992 set isbold [ishighlighted $row]
2993 if {$isbold > 0} {
2994 lappend boldrows $row
2995 lappend font bold
2996 if {$isbold > 1} {
2997 lappend boldnamerows $row
2998 lappend nfont bold
3001 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3002 -text $headline -font $font -tags text]
3003 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3004 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3005 -text $name -font $nfont -tags text]
3006 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3007 -text $date -font $mainfont -tags text]
3008 set xr [expr {$xt + [font measure $mainfont $headline]}]
3009 if {$xr > $canvxmax} {
3010 set canvxmax $xr
3011 setcanvscroll
3015 proc drawcmitrow {row} {
3016 global displayorder rowidlist
3017 global idrangedrawn iddrawn
3018 global commitinfo parentlist numcommits
3019 global filehighlight fhighlights findstring nhighlights
3020 global hlview vhighlights
3021 global highlight_related rhighlights
3023 if {$row >= $numcommits} return
3024 foreach id [lindex $rowidlist $row] {
3025 if {$id eq {}} continue
3026 set i -1
3027 foreach {s e} [rowranges $id] {
3028 incr i
3029 if {$row < $s} continue
3030 if {$e eq {}} break
3031 if {$row <= $e} {
3032 if {$e < $numcommits && ![info exists idrangedrawn($id,$i)]} {
3033 drawlineseg $id $i
3034 set idrangedrawn($id,$i) 1
3036 break
3041 set id [lindex $displayorder $row]
3042 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3043 askvhighlight $row $id
3045 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3046 askfilehighlight $row $id
3048 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3049 askfindhighlight $row $id
3051 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3052 askrelhighlight $row $id
3054 if {[info exists iddrawn($id)]} return
3055 set col [lsearch -exact [lindex $rowidlist $row] $id]
3056 if {$col < 0} {
3057 puts "oops, row $row id $id not in list"
3058 return
3060 if {![info exists commitinfo($id)]} {
3061 getcommit $id
3063 assigncolor $id
3064 set olds [lindex $parentlist $row]
3065 if {$olds ne {}} {
3066 set rmx [drawparentlinks $id $row $col $olds]
3067 } else {
3068 set rmx 0
3070 drawcmittext $id $row $col $rmx
3071 set iddrawn($id) 1
3074 proc drawfrac {f0 f1} {
3075 global numcommits canv
3076 global linespc
3078 set ymax [lindex [$canv cget -scrollregion] 3]
3079 if {$ymax eq {} || $ymax == 0} return
3080 set y0 [expr {int($f0 * $ymax)}]
3081 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3082 if {$row < 0} {
3083 set row 0
3085 set y1 [expr {int($f1 * $ymax)}]
3086 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3087 if {$endrow >= $numcommits} {
3088 set endrow [expr {$numcommits - 1}]
3090 for {} {$row <= $endrow} {incr row} {
3091 drawcmitrow $row
3095 proc drawvisible {} {
3096 global canv
3097 eval drawfrac [$canv yview]
3100 proc clear_display {} {
3101 global iddrawn idrangedrawn
3102 global vhighlights fhighlights nhighlights rhighlights
3104 allcanvs delete all
3105 catch {unset iddrawn}
3106 catch {unset idrangedrawn}
3107 catch {unset vhighlights}
3108 catch {unset fhighlights}
3109 catch {unset nhighlights}
3110 catch {unset rhighlights}
3113 proc findcrossings {id} {
3114 global rowidlist parentlist numcommits rowoffsets displayorder
3116 set cross {}
3117 set ccross {}
3118 foreach {s e} [rowranges $id] {
3119 if {$e >= $numcommits} {
3120 set e [expr {$numcommits - 1}]
3122 if {$e <= $s} continue
3123 set x [lsearch -exact [lindex $rowidlist $e] $id]
3124 if {$x < 0} {
3125 puts "findcrossings: oops, no [shortids $id] in row $e"
3126 continue
3128 for {set row $e} {[incr row -1] >= $s} {} {
3129 set olds [lindex $parentlist $row]
3130 set kid [lindex $displayorder $row]
3131 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3132 if {$kidx < 0} continue
3133 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3134 foreach p $olds {
3135 set px [lsearch -exact $nextrow $p]
3136 if {$px < 0} continue
3137 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3138 if {[lsearch -exact $ccross $p] >= 0} continue
3139 if {$x == $px + ($kidx < $px? -1: 1)} {
3140 lappend ccross $p
3141 } elseif {[lsearch -exact $cross $p] < 0} {
3142 lappend cross $p
3146 set inc [lindex $rowoffsets $row $x]
3147 if {$inc eq {}} break
3148 incr x $inc
3151 return [concat $ccross {{}} $cross]
3154 proc assigncolor {id} {
3155 global colormap colors nextcolor
3156 global commitrow parentlist children children curview
3158 if {[info exists colormap($id)]} return
3159 set ncolors [llength $colors]
3160 if {[info exists children($curview,$id)]} {
3161 set kids $children($curview,$id)
3162 } else {
3163 set kids {}
3165 if {[llength $kids] == 1} {
3166 set child [lindex $kids 0]
3167 if {[info exists colormap($child)]
3168 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3169 set colormap($id) $colormap($child)
3170 return
3173 set badcolors {}
3174 set origbad {}
3175 foreach x [findcrossings $id] {
3176 if {$x eq {}} {
3177 # delimiter between corner crossings and other crossings
3178 if {[llength $badcolors] >= $ncolors - 1} break
3179 set origbad $badcolors
3181 if {[info exists colormap($x)]
3182 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3183 lappend badcolors $colormap($x)
3186 if {[llength $badcolors] >= $ncolors} {
3187 set badcolors $origbad
3189 set origbad $badcolors
3190 if {[llength $badcolors] < $ncolors - 1} {
3191 foreach child $kids {
3192 if {[info exists colormap($child)]
3193 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3194 lappend badcolors $colormap($child)
3196 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3197 if {[info exists colormap($p)]
3198 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3199 lappend badcolors $colormap($p)
3203 if {[llength $badcolors] >= $ncolors} {
3204 set badcolors $origbad
3207 for {set i 0} {$i <= $ncolors} {incr i} {
3208 set c [lindex $colors $nextcolor]
3209 if {[incr nextcolor] >= $ncolors} {
3210 set nextcolor 0
3212 if {[lsearch -exact $badcolors $c]} break
3214 set colormap($id) $c
3217 proc bindline {t id} {
3218 global canv
3220 $canv bind $t <Enter> "lineenter %x %y $id"
3221 $canv bind $t <Motion> "linemotion %x %y $id"
3222 $canv bind $t <Leave> "lineleave $id"
3223 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3226 proc drawtags {id x xt y1} {
3227 global idtags idheads idotherrefs mainhead
3228 global linespc lthickness
3229 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3231 set marks {}
3232 set ntags 0
3233 set nheads 0
3234 if {[info exists idtags($id)]} {
3235 set marks $idtags($id)
3236 set ntags [llength $marks]
3238 if {[info exists idheads($id)]} {
3239 set marks [concat $marks $idheads($id)]
3240 set nheads [llength $idheads($id)]
3242 if {[info exists idotherrefs($id)]} {
3243 set marks [concat $marks $idotherrefs($id)]
3245 if {$marks eq {}} {
3246 return $xt
3249 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3250 set yt [expr {$y1 - 0.5 * $linespc}]
3251 set yb [expr {$yt + $linespc - 1}]
3252 set xvals {}
3253 set wvals {}
3254 set i -1
3255 foreach tag $marks {
3256 incr i
3257 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3258 set wid [font measure [concat $mainfont bold] $tag]
3259 } else {
3260 set wid [font measure $mainfont $tag]
3262 lappend xvals $xt
3263 lappend wvals $wid
3264 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3266 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3267 -width $lthickness -fill black -tags tag.$id]
3268 $canv lower $t
3269 foreach tag $marks x $xvals wid $wvals {
3270 set xl [expr {$x + $delta}]
3271 set xr [expr {$x + $delta + $wid + $lthickness}]
3272 set font $mainfont
3273 if {[incr ntags -1] >= 0} {
3274 # draw a tag
3275 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3276 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3277 -width 1 -outline black -fill yellow -tags tag.$id]
3278 $canv bind $t <1> [list showtag $tag 1]
3279 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3280 } else {
3281 # draw a head or other ref
3282 if {[incr nheads -1] >= 0} {
3283 set col green
3284 if {$tag eq $mainhead} {
3285 lappend font bold
3287 } else {
3288 set col "#ddddff"
3290 set xl [expr {$xl - $delta/2}]
3291 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3292 -width 1 -outline black -fill $col -tags tag.$id
3293 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3294 set rwid [font measure $mainfont $remoteprefix]
3295 set xi [expr {$x + 1}]
3296 set yti [expr {$yt + 1}]
3297 set xri [expr {$x + $rwid}]
3298 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3299 -width 0 -fill "#ffddaa" -tags tag.$id
3302 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3303 -font $font -tags [list tag.$id text]]
3304 if {$ntags >= 0} {
3305 $canv bind $t <1> [list showtag $tag 1]
3306 } elseif {$nheads >= 0} {
3307 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3310 return $xt
3313 proc xcoord {i level ln} {
3314 global canvx0 xspc1 xspc2
3316 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3317 if {$i > 0 && $i == $level} {
3318 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3319 } elseif {$i > $level} {
3320 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3322 return $x
3325 proc show_status {msg} {
3326 global canv mainfont fgcolor
3328 clear_display
3329 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3330 -tags text -fill $fgcolor
3333 proc finishcommits {} {
3334 global commitidx phase curview
3335 global pending_select
3337 if {$commitidx($curview) > 0} {
3338 drawrest
3339 } else {
3340 show_status "No commits selected"
3342 set phase {}
3343 catch {unset pending_select}
3346 # Insert a new commit as the child of the commit on row $row.
3347 # The new commit will be displayed on row $row and the commits
3348 # on that row and below will move down one row.
3349 proc insertrow {row newcmit} {
3350 global displayorder parentlist childlist commitlisted
3351 global commitrow curview rowidlist rowoffsets numcommits
3352 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3353 global linesegends selectedline
3355 if {$row >= $numcommits} {
3356 puts "oops, inserting new row $row but only have $numcommits rows"
3357 return
3359 set p [lindex $displayorder $row]
3360 set displayorder [linsert $displayorder $row $newcmit]
3361 set parentlist [linsert $parentlist $row $p]
3362 set kids [lindex $childlist $row]
3363 lappend kids $newcmit
3364 lset childlist $row $kids
3365 set childlist [linsert $childlist $row {}]
3366 set commitlisted [linsert $commitlisted $row 1]
3367 set l [llength $displayorder]
3368 for {set r $row} {$r < $l} {incr r} {
3369 set id [lindex $displayorder $r]
3370 set commitrow($curview,$id) $r
3373 set idlist [lindex $rowidlist $row]
3374 set offs [lindex $rowoffsets $row]
3375 set newoffs {}
3376 foreach x $idlist {
3377 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3378 lappend newoffs {}
3379 } else {
3380 lappend newoffs 0
3383 if {[llength $kids] == 1} {
3384 set col [lsearch -exact $idlist $p]
3385 lset idlist $col $newcmit
3386 } else {
3387 set col [llength $idlist]
3388 lappend idlist $newcmit
3389 lappend offs {}
3390 lset rowoffsets $row $offs
3392 set rowidlist [linsert $rowidlist $row $idlist]
3393 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3395 set rowrangelist [linsert $rowrangelist $row {}]
3396 set l [llength $rowrangelist]
3397 for {set r 0} {$r < $l} {incr r} {
3398 set ranges [lindex $rowrangelist $r]
3399 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3400 set newranges {}
3401 foreach x $ranges {
3402 if {$x >= $row} {
3403 lappend newranges [expr {$x + 1}]
3404 } else {
3405 lappend newranges $x
3408 lset rowrangelist $r $newranges
3411 if {[llength $kids] > 1} {
3412 set rp1 [expr {$row + 1}]
3413 set ranges [lindex $rowrangelist $rp1]
3414 if {$ranges eq {}} {
3415 set ranges [list $row $rp1]
3416 } elseif {[lindex $ranges end-1] == $rp1} {
3417 lset ranges end-1 $row
3419 lset rowrangelist $rp1 $ranges
3421 foreach id [array names idrowranges] {
3422 set ranges $idrowranges($id)
3423 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3424 set newranges {}
3425 foreach x $ranges {
3426 if {$x >= $row} {
3427 lappend newranges [expr {$x + 1}]
3428 } else {
3429 lappend newranges $x
3432 set idrowranges($id) $newranges
3436 set linesegends [linsert $linesegends $row {}]
3438 incr rowlaidout
3439 incr rowoptim
3440 incr numcommits
3442 if {[info exists selectedline] && $selectedline >= $row} {
3443 incr selectedline
3445 redisplay
3448 # Don't change the text pane cursor if it is currently the hand cursor,
3449 # showing that we are over a sha1 ID link.
3450 proc settextcursor {c} {
3451 global ctext curtextcursor
3453 if {[$ctext cget -cursor] == $curtextcursor} {
3454 $ctext config -cursor $c
3456 set curtextcursor $c
3459 proc nowbusy {what} {
3460 global isbusy
3462 if {[array names isbusy] eq {}} {
3463 . config -cursor watch
3464 settextcursor watch
3466 set isbusy($what) 1
3469 proc notbusy {what} {
3470 global isbusy maincursor textcursor
3472 catch {unset isbusy($what)}
3473 if {[array names isbusy] eq {}} {
3474 . config -cursor $maincursor
3475 settextcursor $textcursor
3479 proc drawrest {} {
3480 global startmsecs
3481 global rowlaidout commitidx curview
3482 global pending_select
3484 set row $rowlaidout
3485 layoutrows $rowlaidout $commitidx($curview) 1
3486 layouttail
3487 optimize_rows $row 0 $commitidx($curview)
3488 showstuff $commitidx($curview)
3489 if {[info exists pending_select]} {
3490 selectline 0 1
3493 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
3494 #global numcommits
3495 #puts "overall $drawmsecs ms for $numcommits commits"
3498 proc findmatches {f} {
3499 global findtype foundstring foundstrlen
3500 if {$findtype == "Regexp"} {
3501 set matches [regexp -indices -all -inline $foundstring $f]
3502 } else {
3503 if {$findtype == "IgnCase"} {
3504 set str [string tolower $f]
3505 } else {
3506 set str $f
3508 set matches {}
3509 set i 0
3510 while {[set j [string first $foundstring $str $i]] >= 0} {
3511 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
3512 set i [expr {$j + $foundstrlen}]
3515 return $matches
3518 proc dofind {} {
3519 global findtype findloc findstring markedmatches commitinfo
3520 global numcommits displayorder linehtag linentag linedtag
3521 global mainfont canv canv2 canv3 selectedline
3522 global matchinglines foundstring foundstrlen matchstring
3523 global commitdata
3525 stopfindproc
3526 unmarkmatches
3527 cancel_next_highlight
3528 focus .
3529 set matchinglines {}
3530 if {$findtype == "IgnCase"} {
3531 set foundstring [string tolower $findstring]
3532 } else {
3533 set foundstring $findstring
3535 set foundstrlen [string length $findstring]
3536 if {$foundstrlen == 0} return
3537 regsub -all {[*?\[\\]} $foundstring {\\&} matchstring
3538 set matchstring "*$matchstring*"
3539 if {![info exists selectedline]} {
3540 set oldsel -1
3541 } else {
3542 set oldsel $selectedline
3544 set didsel 0
3545 set fldtypes {Headline Author Date Committer CDate Comments}
3546 set l -1
3547 foreach id $displayorder {
3548 set d $commitdata($id)
3549 incr l
3550 if {$findtype == "Regexp"} {
3551 set doesmatch [regexp $foundstring $d]
3552 } elseif {$findtype == "IgnCase"} {
3553 set doesmatch [string match -nocase $matchstring $d]
3554 } else {
3555 set doesmatch [string match $matchstring $d]
3557 if {!$doesmatch} continue
3558 if {![info exists commitinfo($id)]} {
3559 getcommit $id
3561 set info $commitinfo($id)
3562 set doesmatch 0
3563 foreach f $info ty $fldtypes {
3564 if {$findloc != "All fields" && $findloc != $ty} {
3565 continue
3567 set matches [findmatches $f]
3568 if {$matches == {}} continue
3569 set doesmatch 1
3570 if {$ty == "Headline"} {
3571 drawcmitrow $l
3572 markmatches $canv $l $f $linehtag($l) $matches $mainfont
3573 } elseif {$ty == "Author"} {
3574 drawcmitrow $l
3575 markmatches $canv2 $l $f $linentag($l) $matches $mainfont
3576 } elseif {$ty == "Date"} {
3577 drawcmitrow $l
3578 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
3581 if {$doesmatch} {
3582 lappend matchinglines $l
3583 if {!$didsel && $l > $oldsel} {
3584 findselectline $l
3585 set didsel 1
3589 if {$matchinglines == {}} {
3590 bell
3591 } elseif {!$didsel} {
3592 findselectline [lindex $matchinglines 0]
3596 proc findselectline {l} {
3597 global findloc commentend ctext
3598 selectline $l 1
3599 if {$findloc == "All fields" || $findloc == "Comments"} {
3600 # highlight the matches in the comments
3601 set f [$ctext get 1.0 $commentend]
3602 set matches [findmatches $f]
3603 foreach match $matches {
3604 set start [lindex $match 0]
3605 set end [expr {[lindex $match 1] + 1}]
3606 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
3611 proc findnext {restart} {
3612 global matchinglines selectedline
3613 if {![info exists matchinglines]} {
3614 if {$restart} {
3615 dofind
3617 return
3619 if {![info exists selectedline]} return
3620 foreach l $matchinglines {
3621 if {$l > $selectedline} {
3622 findselectline $l
3623 return
3626 bell
3629 proc findprev {} {
3630 global matchinglines selectedline
3631 if {![info exists matchinglines]} {
3632 dofind
3633 return
3635 if {![info exists selectedline]} return
3636 set prev {}
3637 foreach l $matchinglines {
3638 if {$l >= $selectedline} break
3639 set prev $l
3641 if {$prev != {}} {
3642 findselectline $prev
3643 } else {
3644 bell
3648 proc stopfindproc {{done 0}} {
3649 global findprocpid findprocfile findids
3650 global ctext findoldcursor phase maincursor textcursor
3651 global findinprogress
3653 catch {unset findids}
3654 if {[info exists findprocpid]} {
3655 if {!$done} {
3656 catch {exec kill $findprocpid}
3658 catch {close $findprocfile}
3659 unset findprocpid
3661 catch {unset findinprogress}
3662 notbusy find
3665 # mark a commit as matching by putting a yellow background
3666 # behind the headline
3667 proc markheadline {l id} {
3668 global canv mainfont linehtag
3670 drawcmitrow $l
3671 set bbox [$canv bbox $linehtag($l)]
3672 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
3673 $canv lower $t
3676 # mark the bits of a headline, author or date that match a find string
3677 proc markmatches {canv l str tag matches font} {
3678 set bbox [$canv bbox $tag]
3679 set x0 [lindex $bbox 0]
3680 set y0 [lindex $bbox 1]
3681 set y1 [lindex $bbox 3]
3682 foreach match $matches {
3683 set start [lindex $match 0]
3684 set end [lindex $match 1]
3685 if {$start > $end} continue
3686 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
3687 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
3688 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
3689 [expr {$x0+$xlen+2}] $y1 \
3690 -outline {} -tags matches -fill yellow]
3691 $canv lower $t
3695 proc unmarkmatches {} {
3696 global matchinglines findids
3697 allcanvs delete matches
3698 catch {unset matchinglines}
3699 catch {unset findids}
3702 proc selcanvline {w x y} {
3703 global canv canvy0 ctext linespc
3704 global rowtextx
3705 set ymax [lindex [$canv cget -scrollregion] 3]
3706 if {$ymax == {}} return
3707 set yfrac [lindex [$canv yview] 0]
3708 set y [expr {$y + $yfrac * $ymax}]
3709 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
3710 if {$l < 0} {
3711 set l 0
3713 if {$w eq $canv} {
3714 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
3716 unmarkmatches
3717 selectline $l 1
3720 proc commit_descriptor {p} {
3721 global commitinfo
3722 if {![info exists commitinfo($p)]} {
3723 getcommit $p
3725 set l "..."
3726 if {[llength $commitinfo($p)] > 1} {
3727 set l [lindex $commitinfo($p) 0]
3729 return "$p ($l)\n"
3732 # append some text to the ctext widget, and make any SHA1 ID
3733 # that we know about be a clickable link.
3734 proc appendwithlinks {text tags} {
3735 global ctext commitrow linknum curview
3737 set start [$ctext index "end - 1c"]
3738 $ctext insert end $text $tags
3739 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
3740 foreach l $links {
3741 set s [lindex $l 0]
3742 set e [lindex $l 1]
3743 set linkid [string range $text $s $e]
3744 if {![info exists commitrow($curview,$linkid)]} continue
3745 incr e
3746 $ctext tag add link "$start + $s c" "$start + $e c"
3747 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
3748 $ctext tag bind link$linknum <1> \
3749 [list selectline $commitrow($curview,$linkid) 1]
3750 incr linknum
3752 $ctext tag conf link -foreground blue -underline 1
3753 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3754 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3757 proc viewnextline {dir} {
3758 global canv linespc
3760 $canv delete hover
3761 set ymax [lindex [$canv cget -scrollregion] 3]
3762 set wnow [$canv yview]
3763 set wtop [expr {[lindex $wnow 0] * $ymax}]
3764 set newtop [expr {$wtop + $dir * $linespc}]
3765 if {$newtop < 0} {
3766 set newtop 0
3767 } elseif {$newtop > $ymax} {
3768 set newtop $ymax
3770 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3773 # add a list of tag or branch names at position pos
3774 # returns the number of names inserted
3775 proc appendrefs {pos tags var} {
3776 global ctext commitrow linknum curview $var
3778 if {[catch {$ctext index $pos}]} {
3779 return 0
3781 set tags [lsort $tags]
3782 set sep {}
3783 foreach tag $tags {
3784 set id [set $var\($tag\)]
3785 set lk link$linknum
3786 incr linknum
3787 $ctext insert $pos $sep
3788 $ctext insert $pos $tag $lk
3789 $ctext tag conf $lk -foreground blue
3790 if {[info exists commitrow($curview,$id)]} {
3791 $ctext tag bind $lk <1> \
3792 [list selectline $commitrow($curview,$id) 1]
3793 $ctext tag conf $lk -underline 1
3794 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
3795 $ctext tag bind $lk <Leave> { %W configure -cursor $curtextcursor }
3797 set sep ", "
3799 return [llength $tags]
3802 proc taglist {ids} {
3803 global idtags
3805 set tags {}
3806 foreach id $ids {
3807 foreach tag $idtags($id) {
3808 lappend tags $tag
3811 return $tags
3814 # called when we have finished computing the nearby tags
3815 proc dispneartags {} {
3816 global selectedline currentid ctext anc_tags desc_tags showneartags
3817 global desc_heads
3819 if {![info exists selectedline] || !$showneartags} return
3820 set id $currentid
3821 $ctext conf -state normal
3822 if {[info exists desc_heads($id)]} {
3823 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3824 $ctext insert "branch -2c" "es"
3827 if {[info exists anc_tags($id)]} {
3828 appendrefs follows [taglist $anc_tags($id)] tagids
3830 if {[info exists desc_tags($id)]} {
3831 appendrefs precedes [taglist $desc_tags($id)] tagids
3833 $ctext conf -state disabled
3836 proc selectline {l isnew} {
3837 global canv canv2 canv3 ctext commitinfo selectedline
3838 global displayorder linehtag linentag linedtag
3839 global canvy0 linespc parentlist childlist
3840 global currentid sha1entry
3841 global commentend idtags linknum
3842 global mergemax numcommits pending_select
3843 global cmitmode desc_tags anc_tags showneartags allcommits desc_heads
3845 catch {unset pending_select}
3846 $canv delete hover
3847 normalline
3848 cancel_next_highlight
3849 if {$l < 0 || $l >= $numcommits} return
3850 set y [expr {$canvy0 + $l * $linespc}]
3851 set ymax [lindex [$canv cget -scrollregion] 3]
3852 set ytop [expr {$y - $linespc - 1}]
3853 set ybot [expr {$y + $linespc + 1}]
3854 set wnow [$canv yview]
3855 set wtop [expr {[lindex $wnow 0] * $ymax}]
3856 set wbot [expr {[lindex $wnow 1] * $ymax}]
3857 set wh [expr {$wbot - $wtop}]
3858 set newtop $wtop
3859 if {$ytop < $wtop} {
3860 if {$ybot < $wtop} {
3861 set newtop [expr {$y - $wh / 2.0}]
3862 } else {
3863 set newtop $ytop
3864 if {$newtop > $wtop - $linespc} {
3865 set newtop [expr {$wtop - $linespc}]
3868 } elseif {$ybot > $wbot} {
3869 if {$ytop > $wbot} {
3870 set newtop [expr {$y - $wh / 2.0}]
3871 } else {
3872 set newtop [expr {$ybot - $wh}]
3873 if {$newtop < $wtop + $linespc} {
3874 set newtop [expr {$wtop + $linespc}]
3878 if {$newtop != $wtop} {
3879 if {$newtop < 0} {
3880 set newtop 0
3882 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3883 drawvisible
3886 if {![info exists linehtag($l)]} return
3887 $canv delete secsel
3888 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
3889 -tags secsel -fill [$canv cget -selectbackground]]
3890 $canv lower $t
3891 $canv2 delete secsel
3892 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
3893 -tags secsel -fill [$canv2 cget -selectbackground]]
3894 $canv2 lower $t
3895 $canv3 delete secsel
3896 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
3897 -tags secsel -fill [$canv3 cget -selectbackground]]
3898 $canv3 lower $t
3900 if {$isnew} {
3901 addtohistory [list selectline $l 0]
3904 set selectedline $l
3906 set id [lindex $displayorder $l]
3907 set currentid $id
3908 $sha1entry delete 0 end
3909 $sha1entry insert 0 $id
3910 $sha1entry selection from 0
3911 $sha1entry selection to end
3912 rhighlight_sel $id
3914 $ctext conf -state normal
3915 clear_ctext
3916 set linknum 0
3917 set info $commitinfo($id)
3918 set date [formatdate [lindex $info 2]]
3919 $ctext insert end "Author: [lindex $info 1] $date\n"
3920 set date [formatdate [lindex $info 4]]
3921 $ctext insert end "Committer: [lindex $info 3] $date\n"
3922 if {[info exists idtags($id)]} {
3923 $ctext insert end "Tags:"
3924 foreach tag $idtags($id) {
3925 $ctext insert end " $tag"
3927 $ctext insert end "\n"
3930 set headers {}
3931 set olds [lindex $parentlist $l]
3932 if {[llength $olds] > 1} {
3933 set np 0
3934 foreach p $olds {
3935 if {$np >= $mergemax} {
3936 set tag mmax
3937 } else {
3938 set tag m$np
3940 $ctext insert end "Parent: " $tag
3941 appendwithlinks [commit_descriptor $p] {}
3942 incr np
3944 } else {
3945 foreach p $olds {
3946 append headers "Parent: [commit_descriptor $p]"
3950 foreach c [lindex $childlist $l] {
3951 append headers "Child: [commit_descriptor $c]"
3954 # make anything that looks like a SHA1 ID be a clickable link
3955 appendwithlinks $headers {}
3956 if {$showneartags} {
3957 if {![info exists allcommits]} {
3958 getallcommits
3960 $ctext insert end "Branch: "
3961 $ctext mark set branch "end -1c"
3962 $ctext mark gravity branch left
3963 if {[info exists desc_heads($id)]} {
3964 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3965 # turn "Branch" into "Branches"
3966 $ctext insert "branch -2c" "es"
3969 $ctext insert end "\nFollows: "
3970 $ctext mark set follows "end -1c"
3971 $ctext mark gravity follows left
3972 if {[info exists anc_tags($id)]} {
3973 appendrefs follows [taglist $anc_tags($id)] tagids
3975 $ctext insert end "\nPrecedes: "
3976 $ctext mark set precedes "end -1c"
3977 $ctext mark gravity precedes left
3978 if {[info exists desc_tags($id)]} {
3979 appendrefs precedes [taglist $desc_tags($id)] tagids
3981 $ctext insert end "\n"
3983 $ctext insert end "\n"
3984 appendwithlinks [lindex $info 5] {comment}
3986 $ctext tag delete Comments
3987 $ctext tag remove found 1.0 end
3988 $ctext conf -state disabled
3989 set commentend [$ctext index "end - 1c"]
3991 init_flist "Comments"
3992 if {$cmitmode eq "tree"} {
3993 gettree $id
3994 } elseif {[llength $olds] <= 1} {
3995 startdiff $id
3996 } else {
3997 mergediff $id $l
4001 proc selfirstline {} {
4002 unmarkmatches
4003 selectline 0 1
4006 proc sellastline {} {
4007 global numcommits
4008 unmarkmatches
4009 set l [expr {$numcommits - 1}]
4010 selectline $l 1
4013 proc selnextline {dir} {
4014 global selectedline
4015 if {![info exists selectedline]} return
4016 set l [expr {$selectedline + $dir}]
4017 unmarkmatches
4018 selectline $l 1
4021 proc selnextpage {dir} {
4022 global canv linespc selectedline numcommits
4024 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4025 if {$lpp < 1} {
4026 set lpp 1
4028 allcanvs yview scroll [expr {$dir * $lpp}] units
4029 drawvisible
4030 if {![info exists selectedline]} return
4031 set l [expr {$selectedline + $dir * $lpp}]
4032 if {$l < 0} {
4033 set l 0
4034 } elseif {$l >= $numcommits} {
4035 set l [expr $numcommits - 1]
4037 unmarkmatches
4038 selectline $l 1
4041 proc unselectline {} {
4042 global selectedline currentid
4044 catch {unset selectedline}
4045 catch {unset currentid}
4046 allcanvs delete secsel
4047 rhighlight_none
4048 cancel_next_highlight
4051 proc reselectline {} {
4052 global selectedline
4054 if {[info exists selectedline]} {
4055 selectline $selectedline 0
4059 proc addtohistory {cmd} {
4060 global history historyindex curview
4062 set elt [list $curview $cmd]
4063 if {$historyindex > 0
4064 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4065 return
4068 if {$historyindex < [llength $history]} {
4069 set history [lreplace $history $historyindex end $elt]
4070 } else {
4071 lappend history $elt
4073 incr historyindex
4074 if {$historyindex > 1} {
4075 .tf.bar.leftbut conf -state normal
4076 } else {
4077 .tf.bar.leftbut conf -state disabled
4079 .tf.bar.rightbut conf -state disabled
4082 proc godo {elt} {
4083 global curview
4085 set view [lindex $elt 0]
4086 set cmd [lindex $elt 1]
4087 if {$curview != $view} {
4088 showview $view
4090 eval $cmd
4093 proc goback {} {
4094 global history historyindex
4096 if {$historyindex > 1} {
4097 incr historyindex -1
4098 godo [lindex $history [expr {$historyindex - 1}]]
4099 .tf.bar.rightbut conf -state normal
4101 if {$historyindex <= 1} {
4102 .tf.bar.leftbut conf -state disabled
4106 proc goforw {} {
4107 global history historyindex
4109 if {$historyindex < [llength $history]} {
4110 set cmd [lindex $history $historyindex]
4111 incr historyindex
4112 godo $cmd
4113 .tf.bar.leftbut conf -state normal
4115 if {$historyindex >= [llength $history]} {
4116 .tf.bar.rightbut conf -state disabled
4120 proc gettree {id} {
4121 global treefilelist treeidlist diffids diffmergeid treepending
4123 set diffids $id
4124 catch {unset diffmergeid}
4125 if {![info exists treefilelist($id)]} {
4126 if {![info exists treepending]} {
4127 if {[catch {set gtf [open [concat | git ls-tree -r $id] r]}]} {
4128 return
4130 set treepending $id
4131 set treefilelist($id) {}
4132 set treeidlist($id) {}
4133 fconfigure $gtf -blocking 0
4134 fileevent $gtf readable [list gettreeline $gtf $id]
4136 } else {
4137 setfilelist $id
4141 proc gettreeline {gtf id} {
4142 global treefilelist treeidlist treepending cmitmode diffids
4144 while {[gets $gtf line] >= 0} {
4145 if {[lindex $line 1] ne "blob"} continue
4146 set sha1 [lindex $line 2]
4147 set fname [lindex $line 3]
4148 lappend treefilelist($id) $fname
4149 lappend treeidlist($id) $sha1
4151 if {![eof $gtf]} return
4152 close $gtf
4153 unset treepending
4154 if {$cmitmode ne "tree"} {
4155 if {![info exists diffmergeid]} {
4156 gettreediffs $diffids
4158 } elseif {$id ne $diffids} {
4159 gettree $diffids
4160 } else {
4161 setfilelist $id
4165 proc showfile {f} {
4166 global treefilelist treeidlist diffids
4167 global ctext commentend
4169 set i [lsearch -exact $treefilelist($diffids) $f]
4170 if {$i < 0} {
4171 puts "oops, $f not in list for id $diffids"
4172 return
4174 set blob [lindex $treeidlist($diffids) $i]
4175 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4176 puts "oops, error reading blob $blob: $err"
4177 return
4179 fconfigure $bf -blocking 0
4180 fileevent $bf readable [list getblobline $bf $diffids]
4181 $ctext config -state normal
4182 clear_ctext $commentend
4183 $ctext insert end "\n"
4184 $ctext insert end "$f\n" filesep
4185 $ctext config -state disabled
4186 $ctext yview $commentend
4189 proc getblobline {bf id} {
4190 global diffids cmitmode ctext
4192 if {$id ne $diffids || $cmitmode ne "tree"} {
4193 catch {close $bf}
4194 return
4196 $ctext config -state normal
4197 while {[gets $bf line] >= 0} {
4198 $ctext insert end "$line\n"
4200 if {[eof $bf]} {
4201 # delete last newline
4202 $ctext delete "end - 2c" "end - 1c"
4203 close $bf
4205 $ctext config -state disabled
4208 proc mergediff {id l} {
4209 global diffmergeid diffopts mdifffd
4210 global diffids
4211 global parentlist
4213 set diffmergeid $id
4214 set diffids $id
4215 # this doesn't seem to actually affect anything...
4216 set env(GIT_DIFF_OPTS) $diffopts
4217 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4218 if {[catch {set mdf [open $cmd r]} err]} {
4219 error_popup "Error getting merge diffs: $err"
4220 return
4222 fconfigure $mdf -blocking 0
4223 set mdifffd($id) $mdf
4224 set np [llength [lindex $parentlist $l]]
4225 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4226 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4229 proc getmergediffline {mdf id np} {
4230 global diffmergeid ctext cflist nextupdate mergemax
4231 global difffilestart mdifffd
4233 set n [gets $mdf line]
4234 if {$n < 0} {
4235 if {[eof $mdf]} {
4236 close $mdf
4238 return
4240 if {![info exists diffmergeid] || $id != $diffmergeid
4241 || $mdf != $mdifffd($id)} {
4242 return
4244 $ctext conf -state normal
4245 if {[regexp {^diff --cc (.*)} $line match fname]} {
4246 # start of a new file
4247 $ctext insert end "\n"
4248 set here [$ctext index "end - 1c"]
4249 lappend difffilestart $here
4250 add_flist [list $fname]
4251 set l [expr {(78 - [string length $fname]) / 2}]
4252 set pad [string range "----------------------------------------" 1 $l]
4253 $ctext insert end "$pad $fname $pad\n" filesep
4254 } elseif {[regexp {^@@} $line]} {
4255 $ctext insert end "$line\n" hunksep
4256 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4257 # do nothing
4258 } else {
4259 # parse the prefix - one ' ', '-' or '+' for each parent
4260 set spaces {}
4261 set minuses {}
4262 set pluses {}
4263 set isbad 0
4264 for {set j 0} {$j < $np} {incr j} {
4265 set c [string range $line $j $j]
4266 if {$c == " "} {
4267 lappend spaces $j
4268 } elseif {$c == "-"} {
4269 lappend minuses $j
4270 } elseif {$c == "+"} {
4271 lappend pluses $j
4272 } else {
4273 set isbad 1
4274 break
4277 set tags {}
4278 set num {}
4279 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4280 # line doesn't appear in result, parents in $minuses have the line
4281 set num [lindex $minuses 0]
4282 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4283 # line appears in result, parents in $pluses don't have the line
4284 lappend tags mresult
4285 set num [lindex $spaces 0]
4287 if {$num ne {}} {
4288 if {$num >= $mergemax} {
4289 set num "max"
4291 lappend tags m$num
4293 $ctext insert end "$line\n" $tags
4295 $ctext conf -state disabled
4296 if {[clock clicks -milliseconds] >= $nextupdate} {
4297 incr nextupdate 100
4298 fileevent $mdf readable {}
4299 update
4300 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4304 proc startdiff {ids} {
4305 global treediffs diffids treepending diffmergeid
4307 set diffids $ids
4308 catch {unset diffmergeid}
4309 if {![info exists treediffs($ids)]} {
4310 if {![info exists treepending]} {
4311 gettreediffs $ids
4313 } else {
4314 addtocflist $ids
4318 proc addtocflist {ids} {
4319 global treediffs cflist
4320 add_flist $treediffs($ids)
4321 getblobdiffs $ids
4324 proc gettreediffs {ids} {
4325 global treediff treepending
4326 set treepending $ids
4327 set treediff {}
4328 if {[catch \
4329 {set gdtf [open [concat | git diff-tree --no-commit-id -r $ids] r]} \
4330 ]} return
4331 fconfigure $gdtf -blocking 0
4332 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
4335 proc gettreediffline {gdtf ids} {
4336 global treediff treediffs treepending diffids diffmergeid
4337 global cmitmode
4339 set n [gets $gdtf line]
4340 if {$n < 0} {
4341 if {![eof $gdtf]} return
4342 close $gdtf
4343 set treediffs($ids) $treediff
4344 unset treepending
4345 if {$cmitmode eq "tree"} {
4346 gettree $diffids
4347 } elseif {$ids != $diffids} {
4348 if {![info exists diffmergeid]} {
4349 gettreediffs $diffids
4351 } else {
4352 addtocflist $ids
4354 return
4356 set file [lindex $line 5]
4357 lappend treediff $file
4360 proc getblobdiffs {ids} {
4361 global diffopts blobdifffd diffids env curdifftag curtagstart
4362 global nextupdate diffinhdr treediffs
4364 set env(GIT_DIFF_OPTS) $diffopts
4365 set cmd [concat | git diff-tree --no-commit-id -r -p -C $ids]
4366 if {[catch {set bdf [open $cmd r]} err]} {
4367 puts "error getting diffs: $err"
4368 return
4370 set diffinhdr 0
4371 fconfigure $bdf -blocking 0
4372 set blobdifffd($ids) $bdf
4373 set curdifftag Comments
4374 set curtagstart 0.0
4375 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
4376 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4379 proc setinlist {var i val} {
4380 global $var
4382 while {[llength [set $var]] < $i} {
4383 lappend $var {}
4385 if {[llength [set $var]] == $i} {
4386 lappend $var $val
4387 } else {
4388 lset $var $i $val
4392 proc getblobdiffline {bdf ids} {
4393 global diffids blobdifffd ctext curdifftag curtagstart
4394 global diffnexthead diffnextnote difffilestart
4395 global nextupdate diffinhdr treediffs
4397 set n [gets $bdf line]
4398 if {$n < 0} {
4399 if {[eof $bdf]} {
4400 close $bdf
4401 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
4402 $ctext tag add $curdifftag $curtagstart end
4405 return
4407 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4408 return
4410 $ctext conf -state normal
4411 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
4412 # start of a new file
4413 $ctext insert end "\n"
4414 $ctext tag add $curdifftag $curtagstart end
4415 set here [$ctext index "end - 1c"]
4416 set curtagstart $here
4417 set header $newname
4418 set i [lsearch -exact $treediffs($ids) $fname]
4419 if {$i >= 0} {
4420 setinlist difffilestart $i $here
4422 if {$newname ne $fname} {
4423 set i [lsearch -exact $treediffs($ids) $newname]
4424 if {$i >= 0} {
4425 setinlist difffilestart $i $here
4428 set curdifftag "f:$fname"
4429 $ctext tag delete $curdifftag
4430 set l [expr {(78 - [string length $header]) / 2}]
4431 set pad [string range "----------------------------------------" 1 $l]
4432 $ctext insert end "$pad $header $pad\n" filesep
4433 set diffinhdr 1
4434 } elseif {$diffinhdr && [string compare -length 3 $line "---"] == 0} {
4435 # do nothing
4436 } elseif {$diffinhdr && [string compare -length 3 $line "+++"] == 0} {
4437 set diffinhdr 0
4438 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
4439 $line match f1l f1c f2l f2c rest]} {
4440 $ctext insert end "$line\n" hunksep
4441 set diffinhdr 0
4442 } else {
4443 set x [string range $line 0 0]
4444 if {$x == "-" || $x == "+"} {
4445 set tag [expr {$x == "+"}]
4446 $ctext insert end "$line\n" d$tag
4447 } elseif {$x == " "} {
4448 $ctext insert end "$line\n"
4449 } elseif {$diffinhdr || $x == "\\"} {
4450 # e.g. "\ No newline at end of file"
4451 $ctext insert end "$line\n" filesep
4452 } else {
4453 # Something else we don't recognize
4454 if {$curdifftag != "Comments"} {
4455 $ctext insert end "\n"
4456 $ctext tag add $curdifftag $curtagstart end
4457 set curtagstart [$ctext index "end - 1c"]
4458 set curdifftag Comments
4460 $ctext insert end "$line\n" filesep
4463 $ctext conf -state disabled
4464 if {[clock clicks -milliseconds] >= $nextupdate} {
4465 incr nextupdate 100
4466 fileevent $bdf readable {}
4467 update
4468 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
4472 proc prevfile {} {
4473 global difffilestart ctext
4474 set prev [lindex $difffilestart 0]
4475 set here [$ctext index @0,0]
4476 foreach loc $difffilestart {
4477 if {[$ctext compare $loc >= $here]} {
4478 $ctext yview $prev
4479 return
4481 set prev $loc
4483 $ctext yview $prev
4486 proc nextfile {} {
4487 global difffilestart ctext
4488 set here [$ctext index @0,0]
4489 foreach loc $difffilestart {
4490 if {[$ctext compare $loc > $here]} {
4491 $ctext yview $loc
4492 return
4497 proc clear_ctext {{first 1.0}} {
4498 global ctext smarktop smarkbot
4500 set l [lindex [split $first .] 0]
4501 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
4502 set smarktop $l
4504 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
4505 set smarkbot $l
4507 $ctext delete $first end
4510 proc incrsearch {name ix op} {
4511 global ctext searchstring searchdirn
4513 $ctext tag remove found 1.0 end
4514 if {[catch {$ctext index anchor}]} {
4515 # no anchor set, use start of selection, or of visible area
4516 set sel [$ctext tag ranges sel]
4517 if {$sel ne {}} {
4518 $ctext mark set anchor [lindex $sel 0]
4519 } elseif {$searchdirn eq "-forwards"} {
4520 $ctext mark set anchor @0,0
4521 } else {
4522 $ctext mark set anchor @0,[winfo height $ctext]
4525 if {$searchstring ne {}} {
4526 set here [$ctext search $searchdirn -- $searchstring anchor]
4527 if {$here ne {}} {
4528 $ctext see $here
4530 searchmarkvisible 1
4534 proc dosearch {} {
4535 global sstring ctext searchstring searchdirn
4537 focus $sstring
4538 $sstring icursor end
4539 set searchdirn -forwards
4540 if {$searchstring ne {}} {
4541 set sel [$ctext tag ranges sel]
4542 if {$sel ne {}} {
4543 set start "[lindex $sel 0] + 1c"
4544 } elseif {[catch {set start [$ctext index anchor]}]} {
4545 set start "@0,0"
4547 set match [$ctext search -count mlen -- $searchstring $start]
4548 $ctext tag remove sel 1.0 end
4549 if {$match eq {}} {
4550 bell
4551 return
4553 $ctext see $match
4554 set mend "$match + $mlen c"
4555 $ctext tag add sel $match $mend
4556 $ctext mark unset anchor
4560 proc dosearchback {} {
4561 global sstring ctext searchstring searchdirn
4563 focus $sstring
4564 $sstring icursor end
4565 set searchdirn -backwards
4566 if {$searchstring ne {}} {
4567 set sel [$ctext tag ranges sel]
4568 if {$sel ne {}} {
4569 set start [lindex $sel 0]
4570 } elseif {[catch {set start [$ctext index anchor]}]} {
4571 set start @0,[winfo height $ctext]
4573 set match [$ctext search -backwards -count ml -- $searchstring $start]
4574 $ctext tag remove sel 1.0 end
4575 if {$match eq {}} {
4576 bell
4577 return
4579 $ctext see $match
4580 set mend "$match + $ml c"
4581 $ctext tag add sel $match $mend
4582 $ctext mark unset anchor
4586 proc searchmark {first last} {
4587 global ctext searchstring
4589 set mend $first.0
4590 while {1} {
4591 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
4592 if {$match eq {}} break
4593 set mend "$match + $mlen c"
4594 $ctext tag add found $match $mend
4598 proc searchmarkvisible {doall} {
4599 global ctext smarktop smarkbot
4601 set topline [lindex [split [$ctext index @0,0] .] 0]
4602 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
4603 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
4604 # no overlap with previous
4605 searchmark $topline $botline
4606 set smarktop $topline
4607 set smarkbot $botline
4608 } else {
4609 if {$topline < $smarktop} {
4610 searchmark $topline [expr {$smarktop-1}]
4611 set smarktop $topline
4613 if {$botline > $smarkbot} {
4614 searchmark [expr {$smarkbot+1}] $botline
4615 set smarkbot $botline
4620 proc scrolltext {f0 f1} {
4621 global searchstring
4623 .bleft.sb set $f0 $f1
4624 if {$searchstring ne {}} {
4625 searchmarkvisible 0
4629 proc setcoords {} {
4630 global linespc charspc canvx0 canvy0 mainfont
4631 global xspc1 xspc2 lthickness
4633 set linespc [font metrics $mainfont -linespace]
4634 set charspc [font measure $mainfont "m"]
4635 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
4636 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
4637 set lthickness [expr {int($linespc / 9) + 1}]
4638 set xspc1(0) $linespc
4639 set xspc2 $linespc
4642 proc redisplay {} {
4643 global canv
4644 global selectedline
4646 set ymax [lindex [$canv cget -scrollregion] 3]
4647 if {$ymax eq {} || $ymax == 0} return
4648 set span [$canv yview]
4649 clear_display
4650 setcanvscroll
4651 allcanvs yview moveto [lindex $span 0]
4652 drawvisible
4653 if {[info exists selectedline]} {
4654 selectline $selectedline 0
4655 allcanvs yview moveto [lindex $span 0]
4659 proc incrfont {inc} {
4660 global mainfont textfont ctext canv phase
4661 global stopped entries
4662 unmarkmatches
4663 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
4664 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
4665 setcoords
4666 $ctext conf -font $textfont
4667 $ctext tag conf filesep -font [concat $textfont bold]
4668 foreach e $entries {
4669 $e conf -font $mainfont
4671 if {$phase eq "getcommits"} {
4672 $canv itemconf textitems -font $mainfont
4674 redisplay
4677 proc clearsha1 {} {
4678 global sha1entry sha1string
4679 if {[string length $sha1string] == 40} {
4680 $sha1entry delete 0 end
4684 proc sha1change {n1 n2 op} {
4685 global sha1string currentid sha1but
4686 if {$sha1string == {}
4687 || ([info exists currentid] && $sha1string == $currentid)} {
4688 set state disabled
4689 } else {
4690 set state normal
4692 if {[$sha1but cget -state] == $state} return
4693 if {$state == "normal"} {
4694 $sha1but conf -state normal -relief raised -text "Goto: "
4695 } else {
4696 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
4700 proc gotocommit {} {
4701 global sha1string currentid commitrow tagids headids
4702 global displayorder numcommits curview
4704 if {$sha1string == {}
4705 || ([info exists currentid] && $sha1string == $currentid)} return
4706 if {[info exists tagids($sha1string)]} {
4707 set id $tagids($sha1string)
4708 } elseif {[info exists headids($sha1string)]} {
4709 set id $headids($sha1string)
4710 } else {
4711 set id [string tolower $sha1string]
4712 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
4713 set matches {}
4714 foreach i $displayorder {
4715 if {[string match $id* $i]} {
4716 lappend matches $i
4719 if {$matches ne {}} {
4720 if {[llength $matches] > 1} {
4721 error_popup "Short SHA1 id $id is ambiguous"
4722 return
4724 set id [lindex $matches 0]
4728 if {[info exists commitrow($curview,$id)]} {
4729 selectline $commitrow($curview,$id) 1
4730 return
4732 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
4733 set type "SHA1 id"
4734 } else {
4735 set type "Tag/Head"
4737 error_popup "$type $sha1string is not known"
4740 proc lineenter {x y id} {
4741 global hoverx hovery hoverid hovertimer
4742 global commitinfo canv
4744 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4745 set hoverx $x
4746 set hovery $y
4747 set hoverid $id
4748 if {[info exists hovertimer]} {
4749 after cancel $hovertimer
4751 set hovertimer [after 500 linehover]
4752 $canv delete hover
4755 proc linemotion {x y id} {
4756 global hoverx hovery hoverid hovertimer
4758 if {[info exists hoverid] && $id == $hoverid} {
4759 set hoverx $x
4760 set hovery $y
4761 if {[info exists hovertimer]} {
4762 after cancel $hovertimer
4764 set hovertimer [after 500 linehover]
4768 proc lineleave {id} {
4769 global hoverid hovertimer canv
4771 if {[info exists hoverid] && $id == $hoverid} {
4772 $canv delete hover
4773 if {[info exists hovertimer]} {
4774 after cancel $hovertimer
4775 unset hovertimer
4777 unset hoverid
4781 proc linehover {} {
4782 global hoverx hovery hoverid hovertimer
4783 global canv linespc lthickness
4784 global commitinfo mainfont
4786 set text [lindex $commitinfo($hoverid) 0]
4787 set ymax [lindex [$canv cget -scrollregion] 3]
4788 if {$ymax == {}} return
4789 set yfrac [lindex [$canv yview] 0]
4790 set x [expr {$hoverx + 2 * $linespc}]
4791 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
4792 set x0 [expr {$x - 2 * $lthickness}]
4793 set y0 [expr {$y - 2 * $lthickness}]
4794 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
4795 set y1 [expr {$y + $linespc + 2 * $lthickness}]
4796 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
4797 -fill \#ffff80 -outline black -width 1 -tags hover]
4798 $canv raise $t
4799 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
4800 -font $mainfont]
4801 $canv raise $t
4804 proc clickisonarrow {id y} {
4805 global lthickness
4807 set ranges [rowranges $id]
4808 set thresh [expr {2 * $lthickness + 6}]
4809 set n [expr {[llength $ranges] - 1}]
4810 for {set i 1} {$i < $n} {incr i} {
4811 set row [lindex $ranges $i]
4812 if {abs([yc $row] - $y) < $thresh} {
4813 return $i
4816 return {}
4819 proc arrowjump {id n y} {
4820 global canv
4822 # 1 <-> 2, 3 <-> 4, etc...
4823 set n [expr {(($n - 1) ^ 1) + 1}]
4824 set row [lindex [rowranges $id] $n]
4825 set yt [yc $row]
4826 set ymax [lindex [$canv cget -scrollregion] 3]
4827 if {$ymax eq {} || $ymax <= 0} return
4828 set view [$canv yview]
4829 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
4830 set yfrac [expr {$yt / $ymax - $yspan / 2}]
4831 if {$yfrac < 0} {
4832 set yfrac 0
4834 allcanvs yview moveto $yfrac
4837 proc lineclick {x y id isnew} {
4838 global ctext commitinfo children canv thickerline curview
4840 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4841 unmarkmatches
4842 unselectline
4843 normalline
4844 $canv delete hover
4845 # draw this line thicker than normal
4846 set thickerline $id
4847 drawlines $id
4848 if {$isnew} {
4849 set ymax [lindex [$canv cget -scrollregion] 3]
4850 if {$ymax eq {}} return
4851 set yfrac [lindex [$canv yview] 0]
4852 set y [expr {$y + $yfrac * $ymax}]
4854 set dirn [clickisonarrow $id $y]
4855 if {$dirn ne {}} {
4856 arrowjump $id $dirn $y
4857 return
4860 if {$isnew} {
4861 addtohistory [list lineclick $x $y $id 0]
4863 # fill the details pane with info about this line
4864 $ctext conf -state normal
4865 clear_ctext
4866 $ctext tag conf link -foreground blue -underline 1
4867 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4868 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4869 $ctext insert end "Parent:\t"
4870 $ctext insert end $id [list link link0]
4871 $ctext tag bind link0 <1> [list selbyid $id]
4872 set info $commitinfo($id)
4873 $ctext insert end "\n\t[lindex $info 0]\n"
4874 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
4875 set date [formatdate [lindex $info 2]]
4876 $ctext insert end "\tDate:\t$date\n"
4877 set kids $children($curview,$id)
4878 if {$kids ne {}} {
4879 $ctext insert end "\nChildren:"
4880 set i 0
4881 foreach child $kids {
4882 incr i
4883 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
4884 set info $commitinfo($child)
4885 $ctext insert end "\n\t"
4886 $ctext insert end $child [list link link$i]
4887 $ctext tag bind link$i <1> [list selbyid $child]
4888 $ctext insert end "\n\t[lindex $info 0]"
4889 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
4890 set date [formatdate [lindex $info 2]]
4891 $ctext insert end "\n\tDate:\t$date\n"
4894 $ctext conf -state disabled
4895 init_flist {}
4898 proc normalline {} {
4899 global thickerline
4900 if {[info exists thickerline]} {
4901 set id $thickerline
4902 unset thickerline
4903 drawlines $id
4907 proc selbyid {id} {
4908 global commitrow curview
4909 if {[info exists commitrow($curview,$id)]} {
4910 selectline $commitrow($curview,$id) 1
4914 proc mstime {} {
4915 global startmstime
4916 if {![info exists startmstime]} {
4917 set startmstime [clock clicks -milliseconds]
4919 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
4922 proc rowmenu {x y id} {
4923 global rowctxmenu commitrow selectedline rowmenuid curview
4925 if {![info exists selectedline]
4926 || $commitrow($curview,$id) eq $selectedline} {
4927 set state disabled
4928 } else {
4929 set state normal
4931 $rowctxmenu entryconfigure "Diff this*" -state $state
4932 $rowctxmenu entryconfigure "Diff selected*" -state $state
4933 $rowctxmenu entryconfigure "Make patch" -state $state
4934 set rowmenuid $id
4935 tk_popup $rowctxmenu $x $y
4938 proc diffvssel {dirn} {
4939 global rowmenuid selectedline displayorder
4941 if {![info exists selectedline]} return
4942 if {$dirn} {
4943 set oldid [lindex $displayorder $selectedline]
4944 set newid $rowmenuid
4945 } else {
4946 set oldid $rowmenuid
4947 set newid [lindex $displayorder $selectedline]
4949 addtohistory [list doseldiff $oldid $newid]
4950 doseldiff $oldid $newid
4953 proc doseldiff {oldid newid} {
4954 global ctext
4955 global commitinfo
4957 $ctext conf -state normal
4958 clear_ctext
4959 init_flist "Top"
4960 $ctext insert end "From "
4961 $ctext tag conf link -foreground blue -underline 1
4962 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4963 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4964 $ctext tag bind link0 <1> [list selbyid $oldid]
4965 $ctext insert end $oldid [list link link0]
4966 $ctext insert end "\n "
4967 $ctext insert end [lindex $commitinfo($oldid) 0]
4968 $ctext insert end "\n\nTo "
4969 $ctext tag bind link1 <1> [list selbyid $newid]
4970 $ctext insert end $newid [list link link1]
4971 $ctext insert end "\n "
4972 $ctext insert end [lindex $commitinfo($newid) 0]
4973 $ctext insert end "\n"
4974 $ctext conf -state disabled
4975 $ctext tag delete Comments
4976 $ctext tag remove found 1.0 end
4977 startdiff [list $oldid $newid]
4980 proc mkpatch {} {
4981 global rowmenuid currentid commitinfo patchtop patchnum
4983 if {![info exists currentid]} return
4984 set oldid $currentid
4985 set oldhead [lindex $commitinfo($oldid) 0]
4986 set newid $rowmenuid
4987 set newhead [lindex $commitinfo($newid) 0]
4988 set top .patch
4989 set patchtop $top
4990 catch {destroy $top}
4991 toplevel $top
4992 label $top.title -text "Generate patch"
4993 grid $top.title - -pady 10
4994 label $top.from -text "From:"
4995 entry $top.fromsha1 -width 40 -relief flat
4996 $top.fromsha1 insert 0 $oldid
4997 $top.fromsha1 conf -state readonly
4998 grid $top.from $top.fromsha1 -sticky w
4999 entry $top.fromhead -width 60 -relief flat
5000 $top.fromhead insert 0 $oldhead
5001 $top.fromhead conf -state readonly
5002 grid x $top.fromhead -sticky w
5003 label $top.to -text "To:"
5004 entry $top.tosha1 -width 40 -relief flat
5005 $top.tosha1 insert 0 $newid
5006 $top.tosha1 conf -state readonly
5007 grid $top.to $top.tosha1 -sticky w
5008 entry $top.tohead -width 60 -relief flat
5009 $top.tohead insert 0 $newhead
5010 $top.tohead conf -state readonly
5011 grid x $top.tohead -sticky w
5012 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5013 grid $top.rev x -pady 10
5014 label $top.flab -text "Output file:"
5015 entry $top.fname -width 60
5016 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5017 incr patchnum
5018 grid $top.flab $top.fname -sticky w
5019 frame $top.buts
5020 button $top.buts.gen -text "Generate" -command mkpatchgo
5021 button $top.buts.can -text "Cancel" -command mkpatchcan
5022 grid $top.buts.gen $top.buts.can
5023 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5024 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5025 grid $top.buts - -pady 10 -sticky ew
5026 focus $top.fname
5029 proc mkpatchrev {} {
5030 global patchtop
5032 set oldid [$patchtop.fromsha1 get]
5033 set oldhead [$patchtop.fromhead get]
5034 set newid [$patchtop.tosha1 get]
5035 set newhead [$patchtop.tohead get]
5036 foreach e [list fromsha1 fromhead tosha1 tohead] \
5037 v [list $newid $newhead $oldid $oldhead] {
5038 $patchtop.$e conf -state normal
5039 $patchtop.$e delete 0 end
5040 $patchtop.$e insert 0 $v
5041 $patchtop.$e conf -state readonly
5045 proc mkpatchgo {} {
5046 global patchtop
5048 set oldid [$patchtop.fromsha1 get]
5049 set newid [$patchtop.tosha1 get]
5050 set fname [$patchtop.fname get]
5051 if {[catch {exec git diff-tree -p $oldid $newid >$fname &} err]} {
5052 error_popup "Error creating patch: $err"
5054 catch {destroy $patchtop}
5055 unset patchtop
5058 proc mkpatchcan {} {
5059 global patchtop
5061 catch {destroy $patchtop}
5062 unset patchtop
5065 proc mktag {} {
5066 global rowmenuid mktagtop commitinfo
5068 set top .maketag
5069 set mktagtop $top
5070 catch {destroy $top}
5071 toplevel $top
5072 label $top.title -text "Create tag"
5073 grid $top.title - -pady 10
5074 label $top.id -text "ID:"
5075 entry $top.sha1 -width 40 -relief flat
5076 $top.sha1 insert 0 $rowmenuid
5077 $top.sha1 conf -state readonly
5078 grid $top.id $top.sha1 -sticky w
5079 entry $top.head -width 60 -relief flat
5080 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5081 $top.head conf -state readonly
5082 grid x $top.head -sticky w
5083 label $top.tlab -text "Tag name:"
5084 entry $top.tag -width 60
5085 grid $top.tlab $top.tag -sticky w
5086 frame $top.buts
5087 button $top.buts.gen -text "Create" -command mktaggo
5088 button $top.buts.can -text "Cancel" -command mktagcan
5089 grid $top.buts.gen $top.buts.can
5090 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5091 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5092 grid $top.buts - -pady 10 -sticky ew
5093 focus $top.tag
5096 proc domktag {} {
5097 global mktagtop env tagids idtags
5099 set id [$mktagtop.sha1 get]
5100 set tag [$mktagtop.tag get]
5101 if {$tag == {}} {
5102 error_popup "No tag name specified"
5103 return
5105 if {[info exists tagids($tag)]} {
5106 error_popup "Tag \"$tag\" already exists"
5107 return
5109 if {[catch {
5110 set dir [gitdir]
5111 set fname [file join $dir "refs/tags" $tag]
5112 set f [open $fname w]
5113 puts $f $id
5114 close $f
5115 } err]} {
5116 error_popup "Error creating tag: $err"
5117 return
5120 set tagids($tag) $id
5121 lappend idtags($id) $tag
5122 redrawtags $id
5123 addedtag $id
5126 proc redrawtags {id} {
5127 global canv linehtag commitrow idpos selectedline curview
5128 global mainfont canvxmax
5130 if {![info exists commitrow($curview,$id)]} return
5131 drawcmitrow $commitrow($curview,$id)
5132 $canv delete tag.$id
5133 set xt [eval drawtags $id $idpos($id)]
5134 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5135 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5136 set xr [expr {$xt + [font measure $mainfont $text]}]
5137 if {$xr > $canvxmax} {
5138 set canvxmax $xr
5139 setcanvscroll
5141 if {[info exists selectedline]
5142 && $selectedline == $commitrow($curview,$id)} {
5143 selectline $selectedline 0
5147 proc mktagcan {} {
5148 global mktagtop
5150 catch {destroy $mktagtop}
5151 unset mktagtop
5154 proc mktaggo {} {
5155 domktag
5156 mktagcan
5159 proc writecommit {} {
5160 global rowmenuid wrcomtop commitinfo wrcomcmd
5162 set top .writecommit
5163 set wrcomtop $top
5164 catch {destroy $top}
5165 toplevel $top
5166 label $top.title -text "Write commit to file"
5167 grid $top.title - -pady 10
5168 label $top.id -text "ID:"
5169 entry $top.sha1 -width 40 -relief flat
5170 $top.sha1 insert 0 $rowmenuid
5171 $top.sha1 conf -state readonly
5172 grid $top.id $top.sha1 -sticky w
5173 entry $top.head -width 60 -relief flat
5174 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5175 $top.head conf -state readonly
5176 grid x $top.head -sticky w
5177 label $top.clab -text "Command:"
5178 entry $top.cmd -width 60 -textvariable wrcomcmd
5179 grid $top.clab $top.cmd -sticky w -pady 10
5180 label $top.flab -text "Output file:"
5181 entry $top.fname -width 60
5182 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5183 grid $top.flab $top.fname -sticky w
5184 frame $top.buts
5185 button $top.buts.gen -text "Write" -command wrcomgo
5186 button $top.buts.can -text "Cancel" -command wrcomcan
5187 grid $top.buts.gen $top.buts.can
5188 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5189 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5190 grid $top.buts - -pady 10 -sticky ew
5191 focus $top.fname
5194 proc wrcomgo {} {
5195 global wrcomtop
5197 set id [$wrcomtop.sha1 get]
5198 set cmd "echo $id | [$wrcomtop.cmd get]"
5199 set fname [$wrcomtop.fname get]
5200 if {[catch {exec sh -c $cmd >$fname &} err]} {
5201 error_popup "Error writing commit: $err"
5203 catch {destroy $wrcomtop}
5204 unset wrcomtop
5207 proc wrcomcan {} {
5208 global wrcomtop
5210 catch {destroy $wrcomtop}
5211 unset wrcomtop
5214 proc mkbranch {} {
5215 global rowmenuid mkbrtop
5217 set top .makebranch
5218 catch {destroy $top}
5219 toplevel $top
5220 label $top.title -text "Create new branch"
5221 grid $top.title - -pady 10
5222 label $top.id -text "ID:"
5223 entry $top.sha1 -width 40 -relief flat
5224 $top.sha1 insert 0 $rowmenuid
5225 $top.sha1 conf -state readonly
5226 grid $top.id $top.sha1 -sticky w
5227 label $top.nlab -text "Name:"
5228 entry $top.name -width 40
5229 grid $top.nlab $top.name -sticky w
5230 frame $top.buts
5231 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5232 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5233 grid $top.buts.go $top.buts.can
5234 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5235 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5236 grid $top.buts - -pady 10 -sticky ew
5237 focus $top.name
5240 proc mkbrgo {top} {
5241 global headids idheads
5243 set name [$top.name get]
5244 set id [$top.sha1 get]
5245 if {$name eq {}} {
5246 error_popup "Please specify a name for the new branch"
5247 return
5249 catch {destroy $top}
5250 nowbusy newbranch
5251 update
5252 if {[catch {
5253 exec git branch $name $id
5254 } err]} {
5255 notbusy newbranch
5256 error_popup $err
5257 } else {
5258 addedhead $id $name
5259 # XXX should update list of heads displayed for selected commit
5260 notbusy newbranch
5261 redrawtags $id
5265 proc cherrypick {} {
5266 global rowmenuid curview commitrow
5267 global mainhead desc_heads anc_tags desc_tags allparents allchildren
5269 if {[info exists desc_heads($rowmenuid)]
5270 && [lsearch -exact $desc_heads($rowmenuid) $mainhead] >= 0} {
5271 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5272 included in branch $mainhead -- really re-apply it?"]
5273 if {!$ok} return
5275 nowbusy cherrypick
5276 update
5277 set oldhead [exec git rev-parse HEAD]
5278 # Unfortunately git-cherry-pick writes stuff to stderr even when
5279 # no error occurs, and exec takes that as an indication of error...
5280 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5281 notbusy cherrypick
5282 error_popup $err
5283 return
5285 set newhead [exec git rev-parse HEAD]
5286 if {$newhead eq $oldhead} {
5287 notbusy cherrypick
5288 error_popup "No changes committed"
5289 return
5291 set allparents($newhead) $oldhead
5292 lappend allchildren($oldhead) $newhead
5293 set desc_heads($newhead) $mainhead
5294 if {[info exists anc_tags($oldhead)]} {
5295 set anc_tags($newhead) $anc_tags($oldhead)
5297 set desc_tags($newhead) {}
5298 if {[info exists commitrow($curview,$oldhead)]} {
5299 insertrow $commitrow($curview,$oldhead) $newhead
5300 if {$mainhead ne {}} {
5301 movedhead $newhead $mainhead
5303 redrawtags $oldhead
5304 redrawtags $newhead
5306 notbusy cherrypick
5309 # context menu for a head
5310 proc headmenu {x y id head} {
5311 global headmenuid headmenuhead headctxmenu
5313 set headmenuid $id
5314 set headmenuhead $head
5315 tk_popup $headctxmenu $x $y
5318 proc cobranch {} {
5319 global headmenuid headmenuhead mainhead headids
5321 # check the tree is clean first??
5322 set oldmainhead $mainhead
5323 nowbusy checkout
5324 update
5325 if {[catch {
5326 exec git checkout $headmenuhead
5327 } err]} {
5328 notbusy checkout
5329 error_popup $err
5330 } else {
5331 notbusy checkout
5332 set mainhead $headmenuhead
5333 if {[info exists headids($oldmainhead)]} {
5334 redrawtags $headids($oldmainhead)
5336 redrawtags $headmenuid
5340 proc rmbranch {} {
5341 global desc_heads headmenuid headmenuhead mainhead
5342 global headids idheads
5344 set head $headmenuhead
5345 set id $headmenuid
5346 if {$head eq $mainhead} {
5347 error_popup "Cannot delete the currently checked-out branch"
5348 return
5350 if {$desc_heads($id) eq $head} {
5351 # the stuff on this branch isn't on any other branch
5352 if {![confirm_popup "The commits on branch $head aren't on any other\
5353 branch.\nReally delete branch $head?"]} return
5355 nowbusy rmbranch
5356 update
5357 if {[catch {exec git branch -D $head} err]} {
5358 notbusy rmbranch
5359 error_popup $err
5360 return
5362 removedhead $id $head
5363 redrawtags $id
5364 notbusy rmbranch
5367 # Stuff for finding nearby tags
5368 proc getallcommits {} {
5369 global allcstart allcommits allcfd allids
5371 set allids {}
5372 set fd [open [concat | git rev-list --all --topo-order --parents] r]
5373 set allcfd $fd
5374 fconfigure $fd -blocking 0
5375 set allcommits "reading"
5376 nowbusy allcommits
5377 restartgetall $fd
5380 proc discardallcommits {} {
5381 global allparents allchildren allcommits allcfd
5382 global desc_tags anc_tags alldtags tagisdesc allids desc_heads
5384 if {![info exists allcommits]} return
5385 if {$allcommits eq "reading"} {
5386 catch {close $allcfd}
5388 foreach v {allcommits allchildren allparents allids desc_tags anc_tags
5389 alldtags tagisdesc desc_heads} {
5390 catch {unset $v}
5394 proc restartgetall {fd} {
5395 global allcstart
5397 fileevent $fd readable [list getallclines $fd]
5398 set allcstart [clock clicks -milliseconds]
5401 proc combine_dtags {l1 l2} {
5402 global tagisdesc notfirstd
5404 set res [lsort -unique [concat $l1 $l2]]
5405 for {set i 0} {$i < [llength $res]} {incr i} {
5406 set x [lindex $res $i]
5407 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5408 set y [lindex $res $j]
5409 if {[info exists tagisdesc($x,$y)]} {
5410 if {$tagisdesc($x,$y) > 0} {
5411 # x is a descendent of y, exclude x
5412 set res [lreplace $res $i $i]
5413 incr i -1
5414 break
5415 } else {
5416 # y is a descendent of x, exclude y
5417 set res [lreplace $res $j $j]
5419 } else {
5420 # no relation, keep going
5421 incr j
5425 return $res
5428 proc combine_atags {l1 l2} {
5429 global tagisdesc
5431 set res [lsort -unique [concat $l1 $l2]]
5432 for {set i 0} {$i < [llength $res]} {incr i} {
5433 set x [lindex $res $i]
5434 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5435 set y [lindex $res $j]
5436 if {[info exists tagisdesc($x,$y)]} {
5437 if {$tagisdesc($x,$y) < 0} {
5438 # x is an ancestor of y, exclude x
5439 set res [lreplace $res $i $i]
5440 incr i -1
5441 break
5442 } else {
5443 # y is an ancestor of x, exclude y
5444 set res [lreplace $res $j $j]
5446 } else {
5447 # no relation, keep going
5448 incr j
5452 return $res
5455 proc forward_pass {id children} {
5456 global idtags desc_tags idheads desc_heads alldtags tagisdesc
5458 set dtags {}
5459 set dheads {}
5460 foreach child $children {
5461 if {[info exists idtags($child)]} {
5462 set ctags [list $child]
5463 } else {
5464 set ctags $desc_tags($child)
5466 if {$dtags eq {}} {
5467 set dtags $ctags
5468 } elseif {$ctags ne $dtags} {
5469 set dtags [combine_dtags $dtags $ctags]
5471 set cheads $desc_heads($child)
5472 if {$dheads eq {}} {
5473 set dheads $cheads
5474 } elseif {$cheads ne $dheads} {
5475 set dheads [lsort -unique [concat $dheads $cheads]]
5478 set desc_tags($id) $dtags
5479 if {[info exists idtags($id)]} {
5480 set adt $dtags
5481 foreach tag $dtags {
5482 set adt [concat $adt $alldtags($tag)]
5484 set adt [lsort -unique $adt]
5485 set alldtags($id) $adt
5486 foreach tag $adt {
5487 set tagisdesc($id,$tag) -1
5488 set tagisdesc($tag,$id) 1
5491 if {[info exists idheads($id)]} {
5492 set dheads [concat $dheads $idheads($id)]
5494 set desc_heads($id) $dheads
5497 proc getallclines {fd} {
5498 global allparents allchildren allcommits allcstart
5499 global desc_tags anc_tags idtags tagisdesc allids
5500 global idheads travindex
5502 while {[gets $fd line] >= 0} {
5503 set id [lindex $line 0]
5504 lappend allids $id
5505 set olds [lrange $line 1 end]
5506 set allparents($id) $olds
5507 if {![info exists allchildren($id)]} {
5508 set allchildren($id) {}
5510 foreach p $olds {
5511 lappend allchildren($p) $id
5513 # compute nearest tagged descendents as we go
5514 # also compute descendent heads
5515 forward_pass $id $allchildren($id)
5516 if {[clock clicks -milliseconds] - $allcstart >= 50} {
5517 fileevent $fd readable {}
5518 after idle restartgetall $fd
5519 return
5522 if {[eof $fd]} {
5523 set travindex [llength $allids]
5524 set allcommits "traversing"
5525 after idle restartatags
5526 if {[catch {close $fd} err]} {
5527 error_popup "Error reading full commit graph: $err.\n\
5528 Results may be incomplete."
5533 # walk backward through the tree and compute nearest tagged ancestors
5534 proc restartatags {} {
5535 global allids allparents idtags anc_tags travindex
5537 set t0 [clock clicks -milliseconds]
5538 set i $travindex
5539 while {[incr i -1] >= 0} {
5540 set id [lindex $allids $i]
5541 set atags {}
5542 foreach p $allparents($id) {
5543 if {[info exists idtags($p)]} {
5544 set ptags [list $p]
5545 } else {
5546 set ptags $anc_tags($p)
5548 if {$atags eq {}} {
5549 set atags $ptags
5550 } elseif {$ptags ne $atags} {
5551 set atags [combine_atags $atags $ptags]
5554 set anc_tags($id) $atags
5555 if {[clock clicks -milliseconds] - $t0 >= 50} {
5556 set travindex $i
5557 after idle restartatags
5558 return
5561 set allcommits "done"
5562 set travindex 0
5563 notbusy allcommits
5564 dispneartags
5567 # update the desc_tags and anc_tags arrays for a new tag just added
5568 proc addedtag {id} {
5569 global desc_tags anc_tags allparents allchildren allcommits
5570 global idtags tagisdesc alldtags
5572 if {![info exists desc_tags($id)]} return
5573 set adt $desc_tags($id)
5574 foreach t $desc_tags($id) {
5575 set adt [concat $adt $alldtags($t)]
5577 set adt [lsort -unique $adt]
5578 set alldtags($id) $adt
5579 foreach t $adt {
5580 set tagisdesc($id,$t) -1
5581 set tagisdesc($t,$id) 1
5583 if {[info exists anc_tags($id)]} {
5584 set todo $anc_tags($id)
5585 while {$todo ne {}} {
5586 set do [lindex $todo 0]
5587 set todo [lrange $todo 1 end]
5588 if {[info exists tagisdesc($id,$do)]} continue
5589 set tagisdesc($do,$id) -1
5590 set tagisdesc($id,$do) 1
5591 if {[info exists anc_tags($do)]} {
5592 set todo [concat $todo $anc_tags($do)]
5597 set lastold $desc_tags($id)
5598 set lastnew [list $id]
5599 set nup 0
5600 set nch 0
5601 set todo $allparents($id)
5602 while {$todo ne {}} {
5603 set do [lindex $todo 0]
5604 set todo [lrange $todo 1 end]
5605 if {![info exists desc_tags($do)]} continue
5606 if {$desc_tags($do) ne $lastold} {
5607 set lastold $desc_tags($do)
5608 set lastnew [combine_dtags $lastold [list $id]]
5609 incr nch
5611 if {$lastold eq $lastnew} continue
5612 set desc_tags($do) $lastnew
5613 incr nup
5614 if {![info exists idtags($do)]} {
5615 set todo [concat $todo $allparents($do)]
5619 if {![info exists anc_tags($id)]} return
5620 set lastold $anc_tags($id)
5621 set lastnew [list $id]
5622 set nup 0
5623 set nch 0
5624 set todo $allchildren($id)
5625 while {$todo ne {}} {
5626 set do [lindex $todo 0]
5627 set todo [lrange $todo 1 end]
5628 if {![info exists anc_tags($do)]} continue
5629 if {$anc_tags($do) ne $lastold} {
5630 set lastold $anc_tags($do)
5631 set lastnew [combine_atags $lastold [list $id]]
5632 incr nch
5634 if {$lastold eq $lastnew} continue
5635 set anc_tags($do) $lastnew
5636 incr nup
5637 if {![info exists idtags($do)]} {
5638 set todo [concat $todo $allchildren($do)]
5643 # update the desc_heads array for a new head just added
5644 proc addedhead {hid head} {
5645 global desc_heads allparents headids idheads
5647 set headids($head) $hid
5648 lappend idheads($hid) $head
5650 set todo [list $hid]
5651 while {$todo ne {}} {
5652 set do [lindex $todo 0]
5653 set todo [lrange $todo 1 end]
5654 if {![info exists desc_heads($do)] ||
5655 [lsearch -exact $desc_heads($do) $head] >= 0} continue
5656 set oldheads $desc_heads($do)
5657 lappend desc_heads($do) $head
5658 set heads $desc_heads($do)
5659 while {1} {
5660 set p $allparents($do)
5661 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5662 $desc_heads($p) ne $oldheads} break
5663 set do $p
5664 set desc_heads($do) $heads
5666 set todo [concat $todo $p]
5670 # update the desc_heads array for a head just removed
5671 proc removedhead {hid head} {
5672 global desc_heads allparents headids idheads
5674 unset headids($head)
5675 if {$idheads($hid) eq $head} {
5676 unset idheads($hid)
5677 } else {
5678 set i [lsearch -exact $idheads($hid) $head]
5679 if {$i >= 0} {
5680 set idheads($hid) [lreplace $idheads($hid) $i $i]
5684 set todo [list $hid]
5685 while {$todo ne {}} {
5686 set do [lindex $todo 0]
5687 set todo [lrange $todo 1 end]
5688 if {![info exists desc_heads($do)]} continue
5689 set i [lsearch -exact $desc_heads($do) $head]
5690 if {$i < 0} continue
5691 set oldheads $desc_heads($do)
5692 set heads [lreplace $desc_heads($do) $i $i]
5693 while {1} {
5694 set desc_heads($do) $heads
5695 set p $allparents($do)
5696 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5697 $desc_heads($p) ne $oldheads} break
5698 set do $p
5700 set todo [concat $todo $p]
5704 # update things for a head moved to a child of its previous location
5705 proc movedhead {id name} {
5706 global headids idheads
5708 set oldid $headids($name)
5709 set headids($name) $id
5710 if {$idheads($oldid) eq $name} {
5711 unset idheads($oldid)
5712 } else {
5713 set i [lsearch -exact $idheads($oldid) $name]
5714 if {$i >= 0} {
5715 set idheads($oldid) [lreplace $idheads($oldid) $i $i]
5718 lappend idheads($id) $name
5721 proc changedrefs {} {
5722 global desc_heads desc_tags anc_tags allcommits allids
5723 global allchildren allparents idtags travindex
5725 if {![info exists allcommits]} return
5726 catch {unset desc_heads}
5727 catch {unset desc_tags}
5728 catch {unset anc_tags}
5729 catch {unset alldtags}
5730 catch {unset tagisdesc}
5731 foreach id $allids {
5732 forward_pass $id $allchildren($id)
5734 if {$allcommits ne "reading"} {
5735 set travindex [llength $allids]
5736 if {$allcommits ne "traversing"} {
5737 set allcommits "traversing"
5738 after idle restartatags
5743 proc rereadrefs {} {
5744 global idtags idheads idotherrefs mainhead
5746 set refids [concat [array names idtags] \
5747 [array names idheads] [array names idotherrefs]]
5748 foreach id $refids {
5749 if {![info exists ref($id)]} {
5750 set ref($id) [listrefs $id]
5753 set oldmainhead $mainhead
5754 readrefs
5755 changedrefs
5756 set refids [lsort -unique [concat $refids [array names idtags] \
5757 [array names idheads] [array names idotherrefs]]]
5758 foreach id $refids {
5759 set v [listrefs $id]
5760 if {![info exists ref($id)] || $ref($id) != $v ||
5761 ($id eq $oldmainhead && $id ne $mainhead) ||
5762 ($id eq $mainhead && $id ne $oldmainhead)} {
5763 redrawtags $id
5768 proc listrefs {id} {
5769 global idtags idheads idotherrefs
5771 set x {}
5772 if {[info exists idtags($id)]} {
5773 set x $idtags($id)
5775 set y {}
5776 if {[info exists idheads($id)]} {
5777 set y $idheads($id)
5779 set z {}
5780 if {[info exists idotherrefs($id)]} {
5781 set z $idotherrefs($id)
5783 return [list $x $y $z]
5786 proc showtag {tag isnew} {
5787 global ctext tagcontents tagids linknum
5789 if {$isnew} {
5790 addtohistory [list showtag $tag 0]
5792 $ctext conf -state normal
5793 clear_ctext
5794 set linknum 0
5795 if {[info exists tagcontents($tag)]} {
5796 set text $tagcontents($tag)
5797 } else {
5798 set text "Tag: $tag\nId: $tagids($tag)"
5800 appendwithlinks $text {}
5801 $ctext conf -state disabled
5802 init_flist {}
5805 proc doquit {} {
5806 global stopped
5807 set stopped 100
5808 savestuff .
5809 destroy .
5812 proc doprefs {} {
5813 global maxwidth maxgraphpct diffopts
5814 global oldprefs prefstop showneartags
5815 global bgcolor fgcolor ctext diffcolors
5817 set top .gitkprefs
5818 set prefstop $top
5819 if {[winfo exists $top]} {
5820 raise $top
5821 return
5823 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5824 set oldprefs($v) [set $v]
5826 toplevel $top
5827 wm title $top "Gitk preferences"
5828 label $top.ldisp -text "Commit list display options"
5829 grid $top.ldisp - -sticky w -pady 10
5830 label $top.spacer -text " "
5831 label $top.maxwidthl -text "Maximum graph width (lines)" \
5832 -font optionfont
5833 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
5834 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
5835 label $top.maxpctl -text "Maximum graph width (% of pane)" \
5836 -font optionfont
5837 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
5838 grid x $top.maxpctl $top.maxpct -sticky w
5840 label $top.ddisp -text "Diff display options"
5841 grid $top.ddisp - -sticky w -pady 10
5842 label $top.diffoptl -text "Options for diff program" \
5843 -font optionfont
5844 entry $top.diffopt -width 20 -textvariable diffopts
5845 grid x $top.diffoptl $top.diffopt -sticky w
5846 frame $top.ntag
5847 label $top.ntag.l -text "Display nearby tags" -font optionfont
5848 checkbutton $top.ntag.b -variable showneartags
5849 pack $top.ntag.b $top.ntag.l -side left
5850 grid x $top.ntag -sticky w
5852 label $top.cdisp -text "Colors: press to choose"
5853 grid $top.cdisp - -sticky w -pady 10
5854 label $top.bg -padx 40 -relief sunk -background $bgcolor
5855 button $top.bgbut -text "Background" -font optionfont \
5856 -command [list choosecolor bgcolor 0 $top.bg background setbg]
5857 grid x $top.bgbut $top.bg -sticky w
5858 label $top.fg -padx 40 -relief sunk -background $fgcolor
5859 button $top.fgbut -text "Foreground" -font optionfont \
5860 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
5861 grid x $top.fgbut $top.fg -sticky w
5862 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
5863 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
5864 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
5865 [list $ctext tag conf d0 -foreground]]
5866 grid x $top.diffoldbut $top.diffold -sticky w
5867 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
5868 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
5869 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
5870 [list $ctext tag conf d1 -foreground]]
5871 grid x $top.diffnewbut $top.diffnew -sticky w
5872 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
5873 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
5874 -command [list choosecolor diffcolors 2 $top.hunksep \
5875 "diff hunk header" \
5876 [list $ctext tag conf hunksep -foreground]]
5877 grid x $top.hunksepbut $top.hunksep -sticky w
5879 frame $top.buts
5880 button $top.buts.ok -text "OK" -command prefsok
5881 button $top.buts.can -text "Cancel" -command prefscan
5882 grid $top.buts.ok $top.buts.can
5883 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5884 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5885 grid $top.buts - - -pady 10 -sticky ew
5888 proc choosecolor {v vi w x cmd} {
5889 global $v
5891 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
5892 -title "Gitk: choose color for $x"]
5893 if {$c eq {}} return
5894 $w conf -background $c
5895 lset $v $vi $c
5896 eval $cmd $c
5899 proc setbg {c} {
5900 global bglist
5902 foreach w $bglist {
5903 $w conf -background $c
5907 proc setfg {c} {
5908 global fglist canv
5910 foreach w $fglist {
5911 $w conf -foreground $c
5913 allcanvs itemconf text -fill $c
5914 $canv itemconf circle -outline $c
5917 proc prefscan {} {
5918 global maxwidth maxgraphpct diffopts
5919 global oldprefs prefstop showneartags
5921 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5922 set $v $oldprefs($v)
5924 catch {destroy $prefstop}
5925 unset prefstop
5928 proc prefsok {} {
5929 global maxwidth maxgraphpct
5930 global oldprefs prefstop showneartags
5932 catch {destroy $prefstop}
5933 unset prefstop
5934 if {$maxwidth != $oldprefs(maxwidth)
5935 || $maxgraphpct != $oldprefs(maxgraphpct)} {
5936 redisplay
5937 } elseif {$showneartags != $oldprefs(showneartags)} {
5938 reselectline
5942 proc formatdate {d} {
5943 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
5946 # This list of encoding names and aliases is distilled from
5947 # http://www.iana.org/assignments/character-sets.
5948 # Not all of them are supported by Tcl.
5949 set encoding_aliases {
5950 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
5951 ISO646-US US-ASCII us IBM367 cp367 csASCII }
5952 { ISO-10646-UTF-1 csISO10646UTF1 }
5953 { ISO_646.basic:1983 ref csISO646basic1983 }
5954 { INVARIANT csINVARIANT }
5955 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
5956 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
5957 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
5958 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
5959 { NATS-DANO iso-ir-9-1 csNATSDANO }
5960 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
5961 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
5962 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
5963 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
5964 { ISO-2022-KR csISO2022KR }
5965 { EUC-KR csEUCKR }
5966 { ISO-2022-JP csISO2022JP }
5967 { ISO-2022-JP-2 csISO2022JP2 }
5968 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
5969 csISO13JISC6220jp }
5970 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
5971 { IT iso-ir-15 ISO646-IT csISO15Italian }
5972 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
5973 { ES iso-ir-17 ISO646-ES csISO17Spanish }
5974 { greek7-old iso-ir-18 csISO18Greek7Old }
5975 { latin-greek iso-ir-19 csISO19LatinGreek }
5976 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
5977 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
5978 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
5979 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
5980 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
5981 { BS_viewdata iso-ir-47 csISO47BSViewdata }
5982 { INIS iso-ir-49 csISO49INIS }
5983 { INIS-8 iso-ir-50 csISO50INIS8 }
5984 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
5985 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
5986 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
5987 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
5988 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
5989 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
5990 csISO60Norwegian1 }
5991 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
5992 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
5993 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
5994 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
5995 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
5996 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
5997 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
5998 { greek7 iso-ir-88 csISO88Greek7 }
5999 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
6000 { iso-ir-90 csISO90 }
6001 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
6002 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
6003 csISO92JISC62991984b }
6004 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
6005 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
6006 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
6007 csISO95JIS62291984handadd }
6008 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
6009 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
6010 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
6011 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
6012 CP819 csISOLatin1 }
6013 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
6014 { T.61-7bit iso-ir-102 csISO102T617bit }
6015 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
6016 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
6017 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
6018 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
6019 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
6020 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
6021 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
6022 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
6023 arabic csISOLatinArabic }
6024 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
6025 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
6026 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
6027 greek greek8 csISOLatinGreek }
6028 { T.101-G2 iso-ir-128 csISO128T101G2 }
6029 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
6030 csISOLatinHebrew }
6031 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
6032 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
6033 { CSN_369103 iso-ir-139 csISO139CSN369103 }
6034 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
6035 { ISO_6937-2-add iso-ir-142 csISOTextComm }
6036 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
6037 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
6038 csISOLatinCyrillic }
6039 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
6040 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
6041 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
6042 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
6043 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
6044 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
6045 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
6046 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
6047 { ISO_10367-box iso-ir-155 csISO10367Box }
6048 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
6049 { latin-lap lap iso-ir-158 csISO158Lap }
6050 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
6051 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
6052 { us-dk csUSDK }
6053 { dk-us csDKUS }
6054 { JIS_X0201 X0201 csHalfWidthKatakana }
6055 { KSC5636 ISO646-KR csKSC5636 }
6056 { ISO-10646-UCS-2 csUnicode }
6057 { ISO-10646-UCS-4 csUCS4 }
6058 { DEC-MCS dec csDECMCS }
6059 { hp-roman8 roman8 r8 csHPRoman8 }
6060 { macintosh mac csMacintosh }
6061 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
6062 csIBM037 }
6063 { IBM038 EBCDIC-INT cp038 csIBM038 }
6064 { IBM273 CP273 csIBM273 }
6065 { IBM274 EBCDIC-BE CP274 csIBM274 }
6066 { IBM275 EBCDIC-BR cp275 csIBM275 }
6067 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
6068 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
6069 { IBM280 CP280 ebcdic-cp-it csIBM280 }
6070 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
6071 { IBM284 CP284 ebcdic-cp-es csIBM284 }
6072 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
6073 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
6074 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
6075 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
6076 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
6077 { IBM424 cp424 ebcdic-cp-he csIBM424 }
6078 { IBM437 cp437 437 csPC8CodePage437 }
6079 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
6080 { IBM775 cp775 csPC775Baltic }
6081 { IBM850 cp850 850 csPC850Multilingual }
6082 { IBM851 cp851 851 csIBM851 }
6083 { IBM852 cp852 852 csPCp852 }
6084 { IBM855 cp855 855 csIBM855 }
6085 { IBM857 cp857 857 csIBM857 }
6086 { IBM860 cp860 860 csIBM860 }
6087 { IBM861 cp861 861 cp-is csIBM861 }
6088 { IBM862 cp862 862 csPC862LatinHebrew }
6089 { IBM863 cp863 863 csIBM863 }
6090 { IBM864 cp864 csIBM864 }
6091 { IBM865 cp865 865 csIBM865 }
6092 { IBM866 cp866 866 csIBM866 }
6093 { IBM868 CP868 cp-ar csIBM868 }
6094 { IBM869 cp869 869 cp-gr csIBM869 }
6095 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
6096 { IBM871 CP871 ebcdic-cp-is csIBM871 }
6097 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
6098 { IBM891 cp891 csIBM891 }
6099 { IBM903 cp903 csIBM903 }
6100 { IBM904 cp904 904 csIBBM904 }
6101 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
6102 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
6103 { IBM1026 CP1026 csIBM1026 }
6104 { EBCDIC-AT-DE csIBMEBCDICATDE }
6105 { EBCDIC-AT-DE-A csEBCDICATDEA }
6106 { EBCDIC-CA-FR csEBCDICCAFR }
6107 { EBCDIC-DK-NO csEBCDICDKNO }
6108 { EBCDIC-DK-NO-A csEBCDICDKNOA }
6109 { EBCDIC-FI-SE csEBCDICFISE }
6110 { EBCDIC-FI-SE-A csEBCDICFISEA }
6111 { EBCDIC-FR csEBCDICFR }
6112 { EBCDIC-IT csEBCDICIT }
6113 { EBCDIC-PT csEBCDICPT }
6114 { EBCDIC-ES csEBCDICES }
6115 { EBCDIC-ES-A csEBCDICESA }
6116 { EBCDIC-ES-S csEBCDICESS }
6117 { EBCDIC-UK csEBCDICUK }
6118 { EBCDIC-US csEBCDICUS }
6119 { UNKNOWN-8BIT csUnknown8BiT }
6120 { MNEMONIC csMnemonic }
6121 { MNEM csMnem }
6122 { VISCII csVISCII }
6123 { VIQR csVIQR }
6124 { KOI8-R csKOI8R }
6125 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
6126 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
6127 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
6128 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
6129 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
6130 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
6131 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
6132 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
6133 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
6134 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
6135 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
6136 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
6137 { IBM1047 IBM-1047 }
6138 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
6139 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
6140 { UNICODE-1-1 csUnicode11 }
6141 { CESU-8 csCESU-8 }
6142 { BOCU-1 csBOCU-1 }
6143 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
6144 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
6145 l8 }
6146 { ISO-8859-15 ISO_8859-15 Latin-9 }
6147 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
6148 { GBK CP936 MS936 windows-936 }
6149 { JIS_Encoding csJISEncoding }
6150 { Shift_JIS MS_Kanji csShiftJIS }
6151 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
6152 EUC-JP }
6153 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
6154 { ISO-10646-UCS-Basic csUnicodeASCII }
6155 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
6156 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
6157 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
6158 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
6159 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
6160 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
6161 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
6162 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
6163 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
6164 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
6165 { Adobe-Standard-Encoding csAdobeStandardEncoding }
6166 { Ventura-US csVenturaUS }
6167 { Ventura-International csVenturaInternational }
6168 { PC8-Danish-Norwegian csPC8DanishNorwegian }
6169 { PC8-Turkish csPC8Turkish }
6170 { IBM-Symbols csIBMSymbols }
6171 { IBM-Thai csIBMThai }
6172 { HP-Legal csHPLegal }
6173 { HP-Pi-font csHPPiFont }
6174 { HP-Math8 csHPMath8 }
6175 { Adobe-Symbol-Encoding csHPPSMath }
6176 { HP-DeskTop csHPDesktop }
6177 { Ventura-Math csVenturaMath }
6178 { Microsoft-Publishing csMicrosoftPublishing }
6179 { Windows-31J csWindows31J }
6180 { GB2312 csGB2312 }
6181 { Big5 csBig5 }
6184 proc tcl_encoding {enc} {
6185 global encoding_aliases
6186 set names [encoding names]
6187 set lcnames [string tolower $names]
6188 set enc [string tolower $enc]
6189 set i [lsearch -exact $lcnames $enc]
6190 if {$i < 0} {
6191 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
6192 if {[regsub {^iso[-_]} $enc iso encx]} {
6193 set i [lsearch -exact $lcnames $encx]
6196 if {$i < 0} {
6197 foreach l $encoding_aliases {
6198 set ll [string tolower $l]
6199 if {[lsearch -exact $ll $enc] < 0} continue
6200 # look through the aliases for one that tcl knows about
6201 foreach e $ll {
6202 set i [lsearch -exact $lcnames $e]
6203 if {$i < 0} {
6204 if {[regsub {^iso[-_]} $e iso ex]} {
6205 set i [lsearch -exact $lcnames $ex]
6208 if {$i >= 0} break
6210 break
6213 if {$i >= 0} {
6214 return [lindex $names $i]
6216 return {}
6219 # defaults...
6220 set datemode 0
6221 set diffopts "-U 5 -p"
6222 set wrcomcmd "git diff-tree --stdin -p --pretty"
6224 set gitencoding {}
6225 catch {
6226 set gitencoding [exec git config --get i18n.commitencoding]
6228 if {$gitencoding == ""} {
6229 set gitencoding "utf-8"
6231 set tclencoding [tcl_encoding $gitencoding]
6232 if {$tclencoding == {}} {
6233 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
6236 set mainfont {Helvetica 9}
6237 set textfont {Courier 9}
6238 set uifont {Helvetica 9 bold}
6239 set findmergefiles 0
6240 set maxgraphpct 50
6241 set maxwidth 16
6242 set revlistorder 0
6243 set fastdate 0
6244 set uparrowlen 7
6245 set downarrowlen 7
6246 set mingaplen 30
6247 set cmitmode "patch"
6248 set wrapcomment "none"
6249 set showneartags 1
6251 set colors {green red blue magenta darkgrey brown orange}
6252 set bgcolor white
6253 set fgcolor black
6254 set diffcolors {red "#00a000" blue}
6256 catch {source ~/.gitk}
6258 font create optionfont -family sans-serif -size -12
6260 set revtreeargs {}
6261 foreach arg $argv {
6262 switch -regexp -- $arg {
6263 "^$" { }
6264 "^-d" { set datemode 1 }
6265 default {
6266 lappend revtreeargs $arg
6271 # check that we can find a .git directory somewhere...
6272 set gitdir [gitdir]
6273 if {![file isdirectory $gitdir]} {
6274 show_error {} . "Cannot find the git directory \"$gitdir\"."
6275 exit 1
6278 set cmdline_files {}
6279 set i [lsearch -exact $revtreeargs "--"]
6280 if {$i >= 0} {
6281 set cmdline_files [lrange $revtreeargs [expr {$i + 1}] end]
6282 set revtreeargs [lrange $revtreeargs 0 [expr {$i - 1}]]
6283 } elseif {$revtreeargs ne {}} {
6284 if {[catch {
6285 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
6286 set cmdline_files [split $f "\n"]
6287 set n [llength $cmdline_files]
6288 set revtreeargs [lrange $revtreeargs 0 end-$n]
6289 } err]} {
6290 # unfortunately we get both stdout and stderr in $err,
6291 # so look for "fatal:".
6292 set i [string first "fatal:" $err]
6293 if {$i > 0} {
6294 set err [string range $err [expr {$i + 6}] end]
6296 show_error {} . "Bad arguments to gitk:\n$err"
6297 exit 1
6301 set history {}
6302 set historyindex 0
6303 set fh_serial 0
6304 set nhl_names {}
6305 set highlight_paths {}
6306 set searchdirn -forwards
6307 set boldrows {}
6308 set boldnamerows {}
6310 set optim_delay 16
6312 set nextviewnum 1
6313 set curview 0
6314 set selectedview 0
6315 set selectedhlview None
6316 set viewfiles(0) {}
6317 set viewperm(0) 0
6318 set viewargs(0) {}
6320 set cmdlineok 0
6321 set stopped 0
6322 set stuffsaved 0
6323 set patchnum 0
6324 setcoords
6325 makewindow
6326 wm title . "[file tail $argv0]: [file tail [pwd]]"
6327 readrefs
6329 if {$cmdline_files ne {} || $revtreeargs ne {}} {
6330 # create a view for the files/dirs specified on the command line
6331 set curview 1
6332 set selectedview 1
6333 set nextviewnum 2
6334 set viewname(1) "Command line"
6335 set viewfiles(1) $cmdline_files
6336 set viewargs(1) $revtreeargs
6337 set viewperm(1) 0
6338 addviewmenu 1
6339 .bar.view entryconf Edit* -state normal
6340 .bar.view entryconf Delete* -state normal
6343 if {[info exists permviews]} {
6344 foreach v $permviews {
6345 set n $nextviewnum
6346 incr nextviewnum
6347 set viewname($n) [lindex $v 0]
6348 set viewfiles($n) [lindex $v 1]
6349 set viewargs($n) [lindex $v 2]
6350 set viewperm($n) 1
6351 addviewmenu $n
6354 getcommits