glossary: Add definitions for dangling and unreachable objects
[git/mingw/4msysgit/kblees.git] / gitk
blob9ddff3e7f7b011564c56fb619f57bed66d875f7e
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 bind . <Control-q> doquit
724 bind . <Control-f> dofind
725 bind . <Control-g> {findnext 0}
726 bind . <Control-r> dosearchback
727 bind . <Control-s> dosearch
728 bind . <Control-equal> {incrfont 1}
729 bind . <Control-KP_Add> {incrfont 1}
730 bind . <Control-minus> {incrfont -1}
731 bind . <Control-KP_Subtract> {incrfont -1}
732 wm protocol . WM_DELETE_WINDOW doquit
733 bind . <Button-1> "click %W"
734 bind $fstring <Key-Return> dofind
735 bind $sha1entry <Key-Return> gotocommit
736 bind $sha1entry <<PasteSelection>> clearsha1
737 bind $cflist <1> {sel_flist %W %x %y; break}
738 bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
739 bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
741 set maincursor [. cget -cursor]
742 set textcursor [$ctext cget -cursor]
743 set curtextcursor $textcursor
745 set rowctxmenu .rowctxmenu
746 menu $rowctxmenu -tearoff 0
747 $rowctxmenu add command -label "Diff this -> selected" \
748 -command {diffvssel 0}
749 $rowctxmenu add command -label "Diff selected -> this" \
750 -command {diffvssel 1}
751 $rowctxmenu add command -label "Make patch" -command mkpatch
752 $rowctxmenu add command -label "Create tag" -command mktag
753 $rowctxmenu add command -label "Write commit to file" -command writecommit
754 $rowctxmenu add command -label "Create new branch" -command mkbranch
755 $rowctxmenu add command -label "Cherry-pick this commit" \
756 -command cherrypick
758 set headctxmenu .headctxmenu
759 menu $headctxmenu -tearoff 0
760 $headctxmenu add command -label "Check out this branch" \
761 -command cobranch
762 $headctxmenu add command -label "Remove this branch" \
763 -command rmbranch
766 # mouse-2 makes all windows scan vertically, but only the one
767 # the cursor is in scans horizontally
768 proc canvscan {op w x y} {
769 global canv canv2 canv3
770 foreach c [list $canv $canv2 $canv3] {
771 if {$c == $w} {
772 $c scan $op $x $y
773 } else {
774 $c scan $op 0 $y
779 proc scrollcanv {cscroll f0 f1} {
780 $cscroll set $f0 $f1
781 drawfrac $f0 $f1
782 flushhighlights
785 # when we make a key binding for the toplevel, make sure
786 # it doesn't get triggered when that key is pressed in the
787 # find string entry widget.
788 proc bindkey {ev script} {
789 global entries
790 bind . $ev $script
791 set escript [bind Entry $ev]
792 if {$escript == {}} {
793 set escript [bind Entry <Key>]
795 foreach e $entries {
796 bind $e $ev "$escript; break"
800 # set the focus back to the toplevel for any click outside
801 # the entry widgets
802 proc click {w} {
803 global entries
804 foreach e $entries {
805 if {$w == $e} return
807 focus .
810 proc savestuff {w} {
811 global canv canv2 canv3 ctext cflist mainfont textfont uifont
812 global stuffsaved findmergefiles maxgraphpct
813 global maxwidth showneartags
814 global viewname viewfiles viewargs viewperm nextviewnum
815 global cmitmode wrapcomment
816 global colors bgcolor fgcolor diffcolors
818 if {$stuffsaved} return
819 if {![winfo viewable .]} return
820 catch {
821 set f [open "~/.gitk-new" w]
822 puts $f [list set mainfont $mainfont]
823 puts $f [list set textfont $textfont]
824 puts $f [list set uifont $uifont]
825 puts $f [list set findmergefiles $findmergefiles]
826 puts $f [list set maxgraphpct $maxgraphpct]
827 puts $f [list set maxwidth $maxwidth]
828 puts $f [list set cmitmode $cmitmode]
829 puts $f [list set wrapcomment $wrapcomment]
830 puts $f [list set showneartags $showneartags]
831 puts $f [list set bgcolor $bgcolor]
832 puts $f [list set fgcolor $fgcolor]
833 puts $f [list set colors $colors]
834 puts $f [list set diffcolors $diffcolors]
836 puts $f "set geometry(main) [wm geometry .]"
837 puts $f "set geometry(topwidth) [winfo width .tf]"
838 puts $f "set geometry(topheight) [winfo height .tf]"
839 puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
840 puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
841 puts $f "set geometry(botwidth) [winfo width .bleft]"
842 puts $f "set geometry(botheight) [winfo height .bleft]"
844 puts -nonewline $f "set permviews {"
845 for {set v 0} {$v < $nextviewnum} {incr v} {
846 if {$viewperm($v)} {
847 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
850 puts $f "}"
851 close $f
852 file rename -force "~/.gitk-new" "~/.gitk"
854 set stuffsaved 1
857 proc resizeclistpanes {win w} {
858 global oldwidth
859 if {[info exists oldwidth($win)]} {
860 set s0 [$win sash coord 0]
861 set s1 [$win sash coord 1]
862 if {$w < 60} {
863 set sash0 [expr {int($w/2 - 2)}]
864 set sash1 [expr {int($w*5/6 - 2)}]
865 } else {
866 set factor [expr {1.0 * $w / $oldwidth($win)}]
867 set sash0 [expr {int($factor * [lindex $s0 0])}]
868 set sash1 [expr {int($factor * [lindex $s1 0])}]
869 if {$sash0 < 30} {
870 set sash0 30
872 if {$sash1 < $sash0 + 20} {
873 set sash1 [expr {$sash0 + 20}]
875 if {$sash1 > $w - 10} {
876 set sash1 [expr {$w - 10}]
877 if {$sash0 > $sash1 - 20} {
878 set sash0 [expr {$sash1 - 20}]
882 $win sash place 0 $sash0 [lindex $s0 1]
883 $win sash place 1 $sash1 [lindex $s1 1]
885 set oldwidth($win) $w
888 proc resizecdetpanes {win w} {
889 global oldwidth
890 if {[info exists oldwidth($win)]} {
891 set s0 [$win sash coord 0]
892 if {$w < 60} {
893 set sash0 [expr {int($w*3/4 - 2)}]
894 } else {
895 set factor [expr {1.0 * $w / $oldwidth($win)}]
896 set sash0 [expr {int($factor * [lindex $s0 0])}]
897 if {$sash0 < 45} {
898 set sash0 45
900 if {$sash0 > $w - 15} {
901 set sash0 [expr {$w - 15}]
904 $win sash place 0 $sash0 [lindex $s0 1]
906 set oldwidth($win) $w
909 proc allcanvs args {
910 global canv canv2 canv3
911 eval $canv $args
912 eval $canv2 $args
913 eval $canv3 $args
916 proc bindall {event action} {
917 global canv canv2 canv3
918 bind $canv $event $action
919 bind $canv2 $event $action
920 bind $canv3 $event $action
923 proc about {} {
924 set w .about
925 if {[winfo exists $w]} {
926 raise $w
927 return
929 toplevel $w
930 wm title $w "About gitk"
931 message $w.m -text {
932 Gitk - a commit viewer for git
934 Copyright © 2005-2006 Paul Mackerras
936 Use and redistribute under the terms of the GNU General Public License} \
937 -justify center -aspect 400
938 pack $w.m -side top -fill x -padx 20 -pady 20
939 button $w.ok -text Close -command "destroy $w"
940 pack $w.ok -side bottom
943 proc keys {} {
944 set w .keys
945 if {[winfo exists $w]} {
946 raise $w
947 return
949 toplevel $w
950 wm title $w "Gitk key bindings"
951 message $w.m -text {
952 Gitk key bindings:
954 <Ctrl-Q> Quit
955 <Home> Move to first commit
956 <End> Move to last commit
957 <Up>, p, i Move up one commit
958 <Down>, n, k Move down one commit
959 <Left>, z, j Go back in history list
960 <Right>, x, l Go forward in history list
961 <PageUp> Move up one page in commit list
962 <PageDown> Move down one page in commit list
963 <Ctrl-Home> Scroll to top of commit list
964 <Ctrl-End> Scroll to bottom of commit list
965 <Ctrl-Up> Scroll commit list up one line
966 <Ctrl-Down> Scroll commit list down one line
967 <Ctrl-PageUp> Scroll commit list up one page
968 <Ctrl-PageDown> Scroll commit list down one page
969 <Shift-Up> Move to previous highlighted line
970 <Shift-Down> Move to next highlighted line
971 <Delete>, b Scroll diff view up one page
972 <Backspace> Scroll diff view up one page
973 <Space> Scroll diff view down one page
974 u Scroll diff view up 18 lines
975 d Scroll diff view down 18 lines
976 <Ctrl-F> Find
977 <Ctrl-G> Move to next find hit
978 <Return> Move to next find hit
979 / Move to next find hit, or redo find
980 ? Move to previous find hit
981 f Scroll diff view to next file
982 <Ctrl-S> Search for next hit in diff view
983 <Ctrl-R> Search for previous hit in diff view
984 <Ctrl-KP+> Increase font size
985 <Ctrl-plus> Increase font size
986 <Ctrl-KP-> Decrease font size
987 <Ctrl-minus> Decrease font size
989 -justify left -bg white -border 2 -relief sunken
990 pack $w.m -side top -fill both
991 button $w.ok -text Close -command "destroy $w"
992 pack $w.ok -side bottom
995 # Procedures for manipulating the file list window at the
996 # bottom right of the overall window.
998 proc treeview {w l openlevs} {
999 global treecontents treediropen treeheight treeparent treeindex
1001 set ix 0
1002 set treeindex() 0
1003 set lev 0
1004 set prefix {}
1005 set prefixend -1
1006 set prefendstack {}
1007 set htstack {}
1008 set ht 0
1009 set treecontents() {}
1010 $w conf -state normal
1011 foreach f $l {
1012 while {[string range $f 0 $prefixend] ne $prefix} {
1013 if {$lev <= $openlevs} {
1014 $w mark set e:$treeindex($prefix) "end -1c"
1015 $w mark gravity e:$treeindex($prefix) left
1017 set treeheight($prefix) $ht
1018 incr ht [lindex $htstack end]
1019 set htstack [lreplace $htstack end end]
1020 set prefixend [lindex $prefendstack end]
1021 set prefendstack [lreplace $prefendstack end end]
1022 set prefix [string range $prefix 0 $prefixend]
1023 incr lev -1
1025 set tail [string range $f [expr {$prefixend+1}] end]
1026 while {[set slash [string first "/" $tail]] >= 0} {
1027 lappend htstack $ht
1028 set ht 0
1029 lappend prefendstack $prefixend
1030 incr prefixend [expr {$slash + 1}]
1031 set d [string range $tail 0 $slash]
1032 lappend treecontents($prefix) $d
1033 set oldprefix $prefix
1034 append prefix $d
1035 set treecontents($prefix) {}
1036 set treeindex($prefix) [incr ix]
1037 set treeparent($prefix) $oldprefix
1038 set tail [string range $tail [expr {$slash+1}] end]
1039 if {$lev <= $openlevs} {
1040 set ht 1
1041 set treediropen($prefix) [expr {$lev < $openlevs}]
1042 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1043 $w mark set d:$ix "end -1c"
1044 $w mark gravity d:$ix left
1045 set str "\n"
1046 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1047 $w insert end $str
1048 $w image create end -align center -image $bm -padx 1 \
1049 -name a:$ix
1050 $w insert end $d [highlight_tag $prefix]
1051 $w mark set s:$ix "end -1c"
1052 $w mark gravity s:$ix left
1054 incr lev
1056 if {$tail ne {}} {
1057 if {$lev <= $openlevs} {
1058 incr ht
1059 set str "\n"
1060 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1061 $w insert end $str
1062 $w insert end $tail [highlight_tag $f]
1064 lappend treecontents($prefix) $tail
1067 while {$htstack ne {}} {
1068 set treeheight($prefix) $ht
1069 incr ht [lindex $htstack end]
1070 set htstack [lreplace $htstack end end]
1072 $w conf -state disabled
1075 proc linetoelt {l} {
1076 global treeheight treecontents
1078 set y 2
1079 set prefix {}
1080 while {1} {
1081 foreach e $treecontents($prefix) {
1082 if {$y == $l} {
1083 return "$prefix$e"
1085 set n 1
1086 if {[string index $e end] eq "/"} {
1087 set n $treeheight($prefix$e)
1088 if {$y + $n > $l} {
1089 append prefix $e
1090 incr y
1091 break
1094 incr y $n
1099 proc highlight_tree {y prefix} {
1100 global treeheight treecontents cflist
1102 foreach e $treecontents($prefix) {
1103 set path $prefix$e
1104 if {[highlight_tag $path] ne {}} {
1105 $cflist tag add bold $y.0 "$y.0 lineend"
1107 incr y
1108 if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1109 set y [highlight_tree $y $path]
1112 return $y
1115 proc treeclosedir {w dir} {
1116 global treediropen treeheight treeparent treeindex
1118 set ix $treeindex($dir)
1119 $w conf -state normal
1120 $w delete s:$ix e:$ix
1121 set treediropen($dir) 0
1122 $w image configure a:$ix -image tri-rt
1123 $w conf -state disabled
1124 set n [expr {1 - $treeheight($dir)}]
1125 while {$dir ne {}} {
1126 incr treeheight($dir) $n
1127 set dir $treeparent($dir)
1131 proc treeopendir {w dir} {
1132 global treediropen treeheight treeparent treecontents treeindex
1134 set ix $treeindex($dir)
1135 $w conf -state normal
1136 $w image configure a:$ix -image tri-dn
1137 $w mark set e:$ix s:$ix
1138 $w mark gravity e:$ix right
1139 set lev 0
1140 set str "\n"
1141 set n [llength $treecontents($dir)]
1142 for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1143 incr lev
1144 append str "\t"
1145 incr treeheight($x) $n
1147 foreach e $treecontents($dir) {
1148 set de $dir$e
1149 if {[string index $e end] eq "/"} {
1150 set iy $treeindex($de)
1151 $w mark set d:$iy e:$ix
1152 $w mark gravity d:$iy left
1153 $w insert e:$ix $str
1154 set treediropen($de) 0
1155 $w image create e:$ix -align center -image tri-rt -padx 1 \
1156 -name a:$iy
1157 $w insert e:$ix $e [highlight_tag $de]
1158 $w mark set s:$iy e:$ix
1159 $w mark gravity s:$iy left
1160 set treeheight($de) 1
1161 } else {
1162 $w insert e:$ix $str
1163 $w insert e:$ix $e [highlight_tag $de]
1166 $w mark gravity e:$ix left
1167 $w conf -state disabled
1168 set treediropen($dir) 1
1169 set top [lindex [split [$w index @0,0] .] 0]
1170 set ht [$w cget -height]
1171 set l [lindex [split [$w index s:$ix] .] 0]
1172 if {$l < $top} {
1173 $w yview $l.0
1174 } elseif {$l + $n + 1 > $top + $ht} {
1175 set top [expr {$l + $n + 2 - $ht}]
1176 if {$l < $top} {
1177 set top $l
1179 $w yview $top.0
1183 proc treeclick {w x y} {
1184 global treediropen cmitmode ctext cflist cflist_top
1186 if {$cmitmode ne "tree"} return
1187 if {![info exists cflist_top]} return
1188 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1189 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1190 $cflist tag add highlight $l.0 "$l.0 lineend"
1191 set cflist_top $l
1192 if {$l == 1} {
1193 $ctext yview 1.0
1194 return
1196 set e [linetoelt $l]
1197 if {[string index $e end] ne "/"} {
1198 showfile $e
1199 } elseif {$treediropen($e)} {
1200 treeclosedir $w $e
1201 } else {
1202 treeopendir $w $e
1206 proc setfilelist {id} {
1207 global treefilelist cflist
1209 treeview $cflist $treefilelist($id) 0
1212 image create bitmap tri-rt -background black -foreground blue -data {
1213 #define tri-rt_width 13
1214 #define tri-rt_height 13
1215 static unsigned char tri-rt_bits[] = {
1216 0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1217 0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1218 0x00, 0x00};
1219 } -maskdata {
1220 #define tri-rt-mask_width 13
1221 #define tri-rt-mask_height 13
1222 static unsigned char tri-rt-mask_bits[] = {
1223 0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1224 0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1225 0x08, 0x00};
1227 image create bitmap tri-dn -background black -foreground blue -data {
1228 #define tri-dn_width 13
1229 #define tri-dn_height 13
1230 static unsigned char tri-dn_bits[] = {
1231 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1232 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1233 0x00, 0x00};
1234 } -maskdata {
1235 #define tri-dn-mask_width 13
1236 #define tri-dn-mask_height 13
1237 static unsigned char tri-dn-mask_bits[] = {
1238 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1239 0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1240 0x00, 0x00};
1243 proc init_flist {first} {
1244 global cflist cflist_top selectedline difffilestart
1246 $cflist conf -state normal
1247 $cflist delete 0.0 end
1248 if {$first ne {}} {
1249 $cflist insert end $first
1250 set cflist_top 1
1251 $cflist tag add highlight 1.0 "1.0 lineend"
1252 } else {
1253 catch {unset cflist_top}
1255 $cflist conf -state disabled
1256 set difffilestart {}
1259 proc highlight_tag {f} {
1260 global highlight_paths
1262 foreach p $highlight_paths {
1263 if {[string match $p $f]} {
1264 return "bold"
1267 return {}
1270 proc highlight_filelist {} {
1271 global cmitmode cflist
1273 $cflist conf -state normal
1274 if {$cmitmode ne "tree"} {
1275 set end [lindex [split [$cflist index end] .] 0]
1276 for {set l 2} {$l < $end} {incr l} {
1277 set line [$cflist get $l.0 "$l.0 lineend"]
1278 if {[highlight_tag $line] ne {}} {
1279 $cflist tag add bold $l.0 "$l.0 lineend"
1282 } else {
1283 highlight_tree 2 {}
1285 $cflist conf -state disabled
1288 proc unhighlight_filelist {} {
1289 global cflist
1291 $cflist conf -state normal
1292 $cflist tag remove bold 1.0 end
1293 $cflist conf -state disabled
1296 proc add_flist {fl} {
1297 global cflist
1299 $cflist conf -state normal
1300 foreach f $fl {
1301 $cflist insert end "\n"
1302 $cflist insert end $f [highlight_tag $f]
1304 $cflist conf -state disabled
1307 proc sel_flist {w x y} {
1308 global ctext difffilestart cflist cflist_top cmitmode
1310 if {$cmitmode eq "tree"} return
1311 if {![info exists cflist_top]} return
1312 set l [lindex [split [$w index "@$x,$y"] "."] 0]
1313 $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1314 $cflist tag add highlight $l.0 "$l.0 lineend"
1315 set cflist_top $l
1316 if {$l == 1} {
1317 $ctext yview 1.0
1318 } else {
1319 catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1323 # Functions for adding and removing shell-type quoting
1325 proc shellquote {str} {
1326 if {![string match "*\['\"\\ \t]*" $str]} {
1327 return $str
1329 if {![string match "*\['\"\\]*" $str]} {
1330 return "\"$str\""
1332 if {![string match "*'*" $str]} {
1333 return "'$str'"
1335 return "\"[string map {\" \\\" \\ \\\\} $str]\""
1338 proc shellarglist {l} {
1339 set str {}
1340 foreach a $l {
1341 if {$str ne {}} {
1342 append str " "
1344 append str [shellquote $a]
1346 return $str
1349 proc shelldequote {str} {
1350 set ret {}
1351 set used -1
1352 while {1} {
1353 incr used
1354 if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1355 append ret [string range $str $used end]
1356 set used [string length $str]
1357 break
1359 set first [lindex $first 0]
1360 set ch [string index $str $first]
1361 if {$first > $used} {
1362 append ret [string range $str $used [expr {$first - 1}]]
1363 set used $first
1365 if {$ch eq " " || $ch eq "\t"} break
1366 incr used
1367 if {$ch eq "'"} {
1368 set first [string first "'" $str $used]
1369 if {$first < 0} {
1370 error "unmatched single-quote"
1372 append ret [string range $str $used [expr {$first - 1}]]
1373 set used $first
1374 continue
1376 if {$ch eq "\\"} {
1377 if {$used >= [string length $str]} {
1378 error "trailing backslash"
1380 append ret [string index $str $used]
1381 continue
1383 # here ch == "\""
1384 while {1} {
1385 if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1386 error "unmatched double-quote"
1388 set first [lindex $first 0]
1389 set ch [string index $str $first]
1390 if {$first > $used} {
1391 append ret [string range $str $used [expr {$first - 1}]]
1392 set used $first
1394 if {$ch eq "\""} break
1395 incr used
1396 append ret [string index $str $used]
1397 incr used
1400 return [list $used $ret]
1403 proc shellsplit {str} {
1404 set l {}
1405 while {1} {
1406 set str [string trimleft $str]
1407 if {$str eq {}} break
1408 set dq [shelldequote $str]
1409 set n [lindex $dq 0]
1410 set word [lindex $dq 1]
1411 set str [string range $str $n end]
1412 lappend l $word
1414 return $l
1417 # Code to implement multiple views
1419 proc newview {ishighlight} {
1420 global nextviewnum newviewname newviewperm uifont newishighlight
1421 global newviewargs revtreeargs
1423 set newishighlight $ishighlight
1424 set top .gitkview
1425 if {[winfo exists $top]} {
1426 raise $top
1427 return
1429 set newviewname($nextviewnum) "View $nextviewnum"
1430 set newviewperm($nextviewnum) 0
1431 set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1432 vieweditor $top $nextviewnum "Gitk view definition"
1435 proc editview {} {
1436 global curview
1437 global viewname viewperm newviewname newviewperm
1438 global viewargs newviewargs
1440 set top .gitkvedit-$curview
1441 if {[winfo exists $top]} {
1442 raise $top
1443 return
1445 set newviewname($curview) $viewname($curview)
1446 set newviewperm($curview) $viewperm($curview)
1447 set newviewargs($curview) [shellarglist $viewargs($curview)]
1448 vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1451 proc vieweditor {top n title} {
1452 global newviewname newviewperm viewfiles
1453 global uifont
1455 toplevel $top
1456 wm title $top $title
1457 label $top.nl -text "Name" -font $uifont
1458 entry $top.name -width 20 -textvariable newviewname($n)
1459 grid $top.nl $top.name -sticky w -pady 5
1460 checkbutton $top.perm -text "Remember this view" -variable newviewperm($n)
1461 grid $top.perm - -pady 5 -sticky w
1462 message $top.al -aspect 1000 -font $uifont \
1463 -text "Commits to include (arguments to git rev-list):"
1464 grid $top.al - -sticky w -pady 5
1465 entry $top.args -width 50 -textvariable newviewargs($n) \
1466 -background white
1467 grid $top.args - -sticky ew -padx 5
1468 message $top.l -aspect 1000 -font $uifont \
1469 -text "Enter files and directories to include, one per line:"
1470 grid $top.l - -sticky w
1471 text $top.t -width 40 -height 10 -background white
1472 if {[info exists viewfiles($n)]} {
1473 foreach f $viewfiles($n) {
1474 $top.t insert end $f
1475 $top.t insert end "\n"
1477 $top.t delete {end - 1c} end
1478 $top.t mark set insert 0.0
1480 grid $top.t - -sticky ew -padx 5
1481 frame $top.buts
1482 button $top.buts.ok -text "OK" -command [list newviewok $top $n]
1483 button $top.buts.can -text "Cancel" -command [list destroy $top]
1484 grid $top.buts.ok $top.buts.can
1485 grid columnconfigure $top.buts 0 -weight 1 -uniform a
1486 grid columnconfigure $top.buts 1 -weight 1 -uniform a
1487 grid $top.buts - -pady 10 -sticky ew
1488 focus $top.t
1491 proc doviewmenu {m first cmd op argv} {
1492 set nmenu [$m index end]
1493 for {set i $first} {$i <= $nmenu} {incr i} {
1494 if {[$m entrycget $i -command] eq $cmd} {
1495 eval $m $op $i $argv
1496 break
1501 proc allviewmenus {n op args} {
1502 global viewhlmenu
1504 doviewmenu .bar.view 5 [list showview $n] $op $args
1505 doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1508 proc newviewok {top n} {
1509 global nextviewnum newviewperm newviewname newishighlight
1510 global viewname viewfiles viewperm selectedview curview
1511 global viewargs newviewargs viewhlmenu
1513 if {[catch {
1514 set newargs [shellsplit $newviewargs($n)]
1515 } err]} {
1516 error_popup "Error in commit selection arguments: $err"
1517 wm raise $top
1518 focus $top
1519 return
1521 set files {}
1522 foreach f [split [$top.t get 0.0 end] "\n"] {
1523 set ft [string trim $f]
1524 if {$ft ne {}} {
1525 lappend files $ft
1528 if {![info exists viewfiles($n)]} {
1529 # creating a new view
1530 incr nextviewnum
1531 set viewname($n) $newviewname($n)
1532 set viewperm($n) $newviewperm($n)
1533 set viewfiles($n) $files
1534 set viewargs($n) $newargs
1535 addviewmenu $n
1536 if {!$newishighlight} {
1537 after idle showview $n
1538 } else {
1539 after idle addvhighlight $n
1541 } else {
1542 # editing an existing view
1543 set viewperm($n) $newviewperm($n)
1544 if {$newviewname($n) ne $viewname($n)} {
1545 set viewname($n) $newviewname($n)
1546 doviewmenu .bar.view 5 [list showview $n] \
1547 entryconf [list -label $viewname($n)]
1548 doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1549 entryconf [list -label $viewname($n) -value $viewname($n)]
1551 if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1552 set viewfiles($n) $files
1553 set viewargs($n) $newargs
1554 if {$curview == $n} {
1555 after idle updatecommits
1559 catch {destroy $top}
1562 proc delview {} {
1563 global curview viewdata viewperm hlview selectedhlview
1565 if {$curview == 0} return
1566 if {[info exists hlview] && $hlview == $curview} {
1567 set selectedhlview None
1568 unset hlview
1570 allviewmenus $curview delete
1571 set viewdata($curview) {}
1572 set viewperm($curview) 0
1573 showview 0
1576 proc addviewmenu {n} {
1577 global viewname viewhlmenu
1579 .bar.view add radiobutton -label $viewname($n) \
1580 -command [list showview $n] -variable selectedview -value $n
1581 $viewhlmenu add radiobutton -label $viewname($n) \
1582 -command [list addvhighlight $n] -variable selectedhlview
1585 proc flatten {var} {
1586 global $var
1588 set ret {}
1589 foreach i [array names $var] {
1590 lappend ret $i [set $var\($i\)]
1592 return $ret
1595 proc unflatten {var l} {
1596 global $var
1598 catch {unset $var}
1599 foreach {i v} $l {
1600 set $var\($i\) $v
1604 proc showview {n} {
1605 global curview viewdata viewfiles
1606 global displayorder parentlist childlist rowidlist rowoffsets
1607 global colormap rowtextx commitrow nextcolor canvxmax
1608 global numcommits rowrangelist commitlisted idrowranges
1609 global selectedline currentid canv canvy0
1610 global matchinglines treediffs
1611 global pending_select phase
1612 global commitidx rowlaidout rowoptim linesegends
1613 global commfd nextupdate
1614 global selectedview
1615 global vparentlist vchildlist vdisporder vcmitlisted
1616 global hlview selectedhlview
1618 if {$n == $curview} return
1619 set selid {}
1620 if {[info exists selectedline]} {
1621 set selid $currentid
1622 set y [yc $selectedline]
1623 set ymax [lindex [$canv cget -scrollregion] 3]
1624 set span [$canv yview]
1625 set ytop [expr {[lindex $span 0] * $ymax}]
1626 set ybot [expr {[lindex $span 1] * $ymax}]
1627 if {$ytop < $y && $y < $ybot} {
1628 set yscreen [expr {$y - $ytop}]
1629 } else {
1630 set yscreen [expr {($ybot - $ytop) / 2}]
1633 unselectline
1634 normalline
1635 stopfindproc
1636 if {$curview >= 0} {
1637 set vparentlist($curview) $parentlist
1638 set vchildlist($curview) $childlist
1639 set vdisporder($curview) $displayorder
1640 set vcmitlisted($curview) $commitlisted
1641 if {$phase ne {}} {
1642 set viewdata($curview) \
1643 [list $phase $rowidlist $rowoffsets $rowrangelist \
1644 [flatten idrowranges] [flatten idinlist] \
1645 $rowlaidout $rowoptim $numcommits $linesegends]
1646 } elseif {![info exists viewdata($curview)]
1647 || [lindex $viewdata($curview) 0] ne {}} {
1648 set viewdata($curview) \
1649 [list {} $rowidlist $rowoffsets $rowrangelist]
1652 catch {unset matchinglines}
1653 catch {unset treediffs}
1654 clear_display
1655 if {[info exists hlview] && $hlview == $n} {
1656 unset hlview
1657 set selectedhlview None
1660 set curview $n
1661 set selectedview $n
1662 .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
1663 .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
1665 if {![info exists viewdata($n)]} {
1666 set pending_select $selid
1667 getcommits
1668 return
1671 set v $viewdata($n)
1672 set phase [lindex $v 0]
1673 set displayorder $vdisporder($n)
1674 set parentlist $vparentlist($n)
1675 set childlist $vchildlist($n)
1676 set commitlisted $vcmitlisted($n)
1677 set rowidlist [lindex $v 1]
1678 set rowoffsets [lindex $v 2]
1679 set rowrangelist [lindex $v 3]
1680 if {$phase eq {}} {
1681 set numcommits [llength $displayorder]
1682 catch {unset idrowranges}
1683 } else {
1684 unflatten idrowranges [lindex $v 4]
1685 unflatten idinlist [lindex $v 5]
1686 set rowlaidout [lindex $v 6]
1687 set rowoptim [lindex $v 7]
1688 set numcommits [lindex $v 8]
1689 set linesegends [lindex $v 9]
1692 catch {unset colormap}
1693 catch {unset rowtextx}
1694 set nextcolor 0
1695 set canvxmax [$canv cget -width]
1696 set curview $n
1697 set row 0
1698 setcanvscroll
1699 set yf 0
1700 set row 0
1701 if {$selid ne {} && [info exists commitrow($n,$selid)]} {
1702 set row $commitrow($n,$selid)
1703 # try to get the selected row in the same position on the screen
1704 set ymax [lindex [$canv cget -scrollregion] 3]
1705 set ytop [expr {[yc $row] - $yscreen}]
1706 if {$ytop < 0} {
1707 set ytop 0
1709 set yf [expr {$ytop * 1.0 / $ymax}]
1711 allcanvs yview moveto $yf
1712 drawvisible
1713 selectline $row 0
1714 if {$phase ne {}} {
1715 if {$phase eq "getcommits"} {
1716 show_status "Reading commits..."
1718 if {[info exists commfd($n)]} {
1719 layoutmore {}
1720 } else {
1721 finishcommits
1723 } elseif {$numcommits == 0} {
1724 show_status "No commits selected"
1728 # Stuff relating to the highlighting facility
1730 proc ishighlighted {row} {
1731 global vhighlights fhighlights nhighlights rhighlights
1733 if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
1734 return $nhighlights($row)
1736 if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
1737 return $vhighlights($row)
1739 if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
1740 return $fhighlights($row)
1742 if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
1743 return $rhighlights($row)
1745 return 0
1748 proc bolden {row font} {
1749 global canv linehtag selectedline boldrows
1751 lappend boldrows $row
1752 $canv itemconf $linehtag($row) -font $font
1753 if {[info exists selectedline] && $row == $selectedline} {
1754 $canv delete secsel
1755 set t [eval $canv create rect [$canv bbox $linehtag($row)] \
1756 -outline {{}} -tags secsel \
1757 -fill [$canv cget -selectbackground]]
1758 $canv lower $t
1762 proc bolden_name {row font} {
1763 global canv2 linentag selectedline boldnamerows
1765 lappend boldnamerows $row
1766 $canv2 itemconf $linentag($row) -font $font
1767 if {[info exists selectedline] && $row == $selectedline} {
1768 $canv2 delete secsel
1769 set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
1770 -outline {{}} -tags secsel \
1771 -fill [$canv2 cget -selectbackground]]
1772 $canv2 lower $t
1776 proc unbolden {} {
1777 global mainfont boldrows
1779 set stillbold {}
1780 foreach row $boldrows {
1781 if {![ishighlighted $row]} {
1782 bolden $row $mainfont
1783 } else {
1784 lappend stillbold $row
1787 set boldrows $stillbold
1790 proc addvhighlight {n} {
1791 global hlview curview viewdata vhl_done vhighlights commitidx
1793 if {[info exists hlview]} {
1794 delvhighlight
1796 set hlview $n
1797 if {$n != $curview && ![info exists viewdata($n)]} {
1798 set viewdata($n) [list getcommits {{}} {{}} {} {} {} 0 0 0 {}]
1799 set vparentlist($n) {}
1800 set vchildlist($n) {}
1801 set vdisporder($n) {}
1802 set vcmitlisted($n) {}
1803 start_rev_list $n
1805 set vhl_done $commitidx($hlview)
1806 if {$vhl_done > 0} {
1807 drawvisible
1811 proc delvhighlight {} {
1812 global hlview vhighlights
1814 if {![info exists hlview]} return
1815 unset hlview
1816 catch {unset vhighlights}
1817 unbolden
1820 proc vhighlightmore {} {
1821 global hlview vhl_done commitidx vhighlights
1822 global displayorder vdisporder curview mainfont
1824 set font [concat $mainfont bold]
1825 set max $commitidx($hlview)
1826 if {$hlview == $curview} {
1827 set disp $displayorder
1828 } else {
1829 set disp $vdisporder($hlview)
1831 set vr [visiblerows]
1832 set r0 [lindex $vr 0]
1833 set r1 [lindex $vr 1]
1834 for {set i $vhl_done} {$i < $max} {incr i} {
1835 set id [lindex $disp $i]
1836 if {[info exists commitrow($curview,$id)]} {
1837 set row $commitrow($curview,$id)
1838 if {$r0 <= $row && $row <= $r1} {
1839 if {![highlighted $row]} {
1840 bolden $row $font
1842 set vhighlights($row) 1
1846 set vhl_done $max
1849 proc askvhighlight {row id} {
1850 global hlview vhighlights commitrow iddrawn mainfont
1852 if {[info exists commitrow($hlview,$id)]} {
1853 if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
1854 bolden $row [concat $mainfont bold]
1856 set vhighlights($row) 1
1857 } else {
1858 set vhighlights($row) 0
1862 proc hfiles_change {name ix op} {
1863 global highlight_files filehighlight fhighlights fh_serial
1864 global mainfont highlight_paths
1866 if {[info exists filehighlight]} {
1867 # delete previous highlights
1868 catch {close $filehighlight}
1869 unset filehighlight
1870 catch {unset fhighlights}
1871 unbolden
1872 unhighlight_filelist
1874 set highlight_paths {}
1875 after cancel do_file_hl $fh_serial
1876 incr fh_serial
1877 if {$highlight_files ne {}} {
1878 after 300 do_file_hl $fh_serial
1882 proc makepatterns {l} {
1883 set ret {}
1884 foreach e $l {
1885 set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
1886 if {[string index $ee end] eq "/"} {
1887 lappend ret "$ee*"
1888 } else {
1889 lappend ret $ee
1890 lappend ret "$ee/*"
1893 return $ret
1896 proc do_file_hl {serial} {
1897 global highlight_files filehighlight highlight_paths gdttype fhl_list
1899 if {$gdttype eq "touching paths:"} {
1900 if {[catch {set paths [shellsplit $highlight_files]}]} return
1901 set highlight_paths [makepatterns $paths]
1902 highlight_filelist
1903 set gdtargs [concat -- $paths]
1904 } else {
1905 set gdtargs [list "-S$highlight_files"]
1907 set cmd [concat | git-diff-tree -r -s --stdin $gdtargs]
1908 set filehighlight [open $cmd r+]
1909 fconfigure $filehighlight -blocking 0
1910 fileevent $filehighlight readable readfhighlight
1911 set fhl_list {}
1912 drawvisible
1913 flushhighlights
1916 proc flushhighlights {} {
1917 global filehighlight fhl_list
1919 if {[info exists filehighlight]} {
1920 lappend fhl_list {}
1921 puts $filehighlight ""
1922 flush $filehighlight
1926 proc askfilehighlight {row id} {
1927 global filehighlight fhighlights fhl_list
1929 lappend fhl_list $id
1930 set fhighlights($row) -1
1931 puts $filehighlight $id
1934 proc readfhighlight {} {
1935 global filehighlight fhighlights commitrow curview mainfont iddrawn
1936 global fhl_list
1938 while {[gets $filehighlight line] >= 0} {
1939 set line [string trim $line]
1940 set i [lsearch -exact $fhl_list $line]
1941 if {$i < 0} continue
1942 for {set j 0} {$j < $i} {incr j} {
1943 set id [lindex $fhl_list $j]
1944 if {[info exists commitrow($curview,$id)]} {
1945 set fhighlights($commitrow($curview,$id)) 0
1948 set fhl_list [lrange $fhl_list [expr {$i+1}] end]
1949 if {$line eq {}} continue
1950 if {![info exists commitrow($curview,$line)]} continue
1951 set row $commitrow($curview,$line)
1952 if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
1953 bolden $row [concat $mainfont bold]
1955 set fhighlights($row) 1
1957 if {[eof $filehighlight]} {
1958 # strange...
1959 puts "oops, git-diff-tree died"
1960 catch {close $filehighlight}
1961 unset filehighlight
1963 next_hlcont
1966 proc find_change {name ix op} {
1967 global nhighlights mainfont boldnamerows
1968 global findstring findpattern findtype
1970 # delete previous highlights, if any
1971 foreach row $boldnamerows {
1972 bolden_name $row $mainfont
1974 set boldnamerows {}
1975 catch {unset nhighlights}
1976 unbolden
1977 if {$findtype ne "Regexp"} {
1978 set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
1979 $findstring]
1980 set findpattern "*$e*"
1982 drawvisible
1985 proc askfindhighlight {row id} {
1986 global nhighlights commitinfo iddrawn mainfont
1987 global findstring findtype findloc findpattern
1989 if {![info exists commitinfo($id)]} {
1990 getcommit $id
1992 set info $commitinfo($id)
1993 set isbold 0
1994 set fldtypes {Headline Author Date Committer CDate Comments}
1995 foreach f $info ty $fldtypes {
1996 if {$findloc ne "All fields" && $findloc ne $ty} {
1997 continue
1999 if {$findtype eq "Regexp"} {
2000 set doesmatch [regexp $findstring $f]
2001 } elseif {$findtype eq "IgnCase"} {
2002 set doesmatch [string match -nocase $findpattern $f]
2003 } else {
2004 set doesmatch [string match $findpattern $f]
2006 if {$doesmatch} {
2007 if {$ty eq "Author"} {
2008 set isbold 2
2009 } else {
2010 set isbold 1
2014 if {[info exists iddrawn($id)]} {
2015 if {$isbold && ![ishighlighted $row]} {
2016 bolden $row [concat $mainfont bold]
2018 if {$isbold >= 2} {
2019 bolden_name $row [concat $mainfont bold]
2022 set nhighlights($row) $isbold
2025 proc vrel_change {name ix op} {
2026 global highlight_related
2028 rhighlight_none
2029 if {$highlight_related ne "None"} {
2030 after idle drawvisible
2034 # prepare for testing whether commits are descendents or ancestors of a
2035 proc rhighlight_sel {a} {
2036 global descendent desc_todo ancestor anc_todo
2037 global highlight_related rhighlights
2039 catch {unset descendent}
2040 set desc_todo [list $a]
2041 catch {unset ancestor}
2042 set anc_todo [list $a]
2043 if {$highlight_related ne "None"} {
2044 rhighlight_none
2045 after idle drawvisible
2049 proc rhighlight_none {} {
2050 global rhighlights
2052 catch {unset rhighlights}
2053 unbolden
2056 proc is_descendent {a} {
2057 global curview children commitrow descendent desc_todo
2059 set v $curview
2060 set la $commitrow($v,$a)
2061 set todo $desc_todo
2062 set leftover {}
2063 set done 0
2064 for {set i 0} {$i < [llength $todo]} {incr i} {
2065 set do [lindex $todo $i]
2066 if {$commitrow($v,$do) < $la} {
2067 lappend leftover $do
2068 continue
2070 foreach nk $children($v,$do) {
2071 if {![info exists descendent($nk)]} {
2072 set descendent($nk) 1
2073 lappend todo $nk
2074 if {$nk eq $a} {
2075 set done 1
2079 if {$done} {
2080 set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2081 return
2084 set descendent($a) 0
2085 set desc_todo $leftover
2088 proc is_ancestor {a} {
2089 global curview parentlist commitrow ancestor anc_todo
2091 set v $curview
2092 set la $commitrow($v,$a)
2093 set todo $anc_todo
2094 set leftover {}
2095 set done 0
2096 for {set i 0} {$i < [llength $todo]} {incr i} {
2097 set do [lindex $todo $i]
2098 if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2099 lappend leftover $do
2100 continue
2102 foreach np [lindex $parentlist $commitrow($v,$do)] {
2103 if {![info exists ancestor($np)]} {
2104 set ancestor($np) 1
2105 lappend todo $np
2106 if {$np eq $a} {
2107 set done 1
2111 if {$done} {
2112 set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2113 return
2116 set ancestor($a) 0
2117 set anc_todo $leftover
2120 proc askrelhighlight {row id} {
2121 global descendent highlight_related iddrawn mainfont rhighlights
2122 global selectedline ancestor
2124 if {![info exists selectedline]} return
2125 set isbold 0
2126 if {$highlight_related eq "Descendent" ||
2127 $highlight_related eq "Not descendent"} {
2128 if {![info exists descendent($id)]} {
2129 is_descendent $id
2131 if {$descendent($id) == ($highlight_related eq "Descendent")} {
2132 set isbold 1
2134 } elseif {$highlight_related eq "Ancestor" ||
2135 $highlight_related eq "Not ancestor"} {
2136 if {![info exists ancestor($id)]} {
2137 is_ancestor $id
2139 if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2140 set isbold 1
2143 if {[info exists iddrawn($id)]} {
2144 if {$isbold && ![ishighlighted $row]} {
2145 bolden $row [concat $mainfont bold]
2148 set rhighlights($row) $isbold
2151 proc next_hlcont {} {
2152 global fhl_row fhl_dirn displayorder numcommits
2153 global vhighlights fhighlights nhighlights rhighlights
2154 global hlview filehighlight findstring highlight_related
2156 if {![info exists fhl_dirn] || $fhl_dirn == 0} return
2157 set row $fhl_row
2158 while {1} {
2159 if {$row < 0 || $row >= $numcommits} {
2160 bell
2161 set fhl_dirn 0
2162 return
2164 set id [lindex $displayorder $row]
2165 if {[info exists hlview]} {
2166 if {![info exists vhighlights($row)]} {
2167 askvhighlight $row $id
2169 if {$vhighlights($row) > 0} break
2171 if {$findstring ne {}} {
2172 if {![info exists nhighlights($row)]} {
2173 askfindhighlight $row $id
2175 if {$nhighlights($row) > 0} break
2177 if {$highlight_related ne "None"} {
2178 if {![info exists rhighlights($row)]} {
2179 askrelhighlight $row $id
2181 if {$rhighlights($row) > 0} break
2183 if {[info exists filehighlight]} {
2184 if {![info exists fhighlights($row)]} {
2185 # ask for a few more while we're at it...
2186 set r $row
2187 for {set n 0} {$n < 100} {incr n} {
2188 if {![info exists fhighlights($r)]} {
2189 askfilehighlight $r [lindex $displayorder $r]
2191 incr r $fhl_dirn
2192 if {$r < 0 || $r >= $numcommits} break
2194 flushhighlights
2196 if {$fhighlights($row) < 0} {
2197 set fhl_row $row
2198 return
2200 if {$fhighlights($row) > 0} break
2202 incr row $fhl_dirn
2204 set fhl_dirn 0
2205 selectline $row 1
2208 proc next_highlight {dirn} {
2209 global selectedline fhl_row fhl_dirn
2210 global hlview filehighlight findstring highlight_related
2212 if {![info exists selectedline]} return
2213 if {!([info exists hlview] || $findstring ne {} ||
2214 $highlight_related ne "None" || [info exists filehighlight])} return
2215 set fhl_row [expr {$selectedline + $dirn}]
2216 set fhl_dirn $dirn
2217 next_hlcont
2220 proc cancel_next_highlight {} {
2221 global fhl_dirn
2223 set fhl_dirn 0
2226 # Graph layout functions
2228 proc shortids {ids} {
2229 set res {}
2230 foreach id $ids {
2231 if {[llength $id] > 1} {
2232 lappend res [shortids $id]
2233 } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2234 lappend res [string range $id 0 7]
2235 } else {
2236 lappend res $id
2239 return $res
2242 proc incrange {l x o} {
2243 set n [llength $l]
2244 while {$x < $n} {
2245 set e [lindex $l $x]
2246 if {$e ne {}} {
2247 lset l $x [expr {$e + $o}]
2249 incr x
2251 return $l
2254 proc ntimes {n o} {
2255 set ret {}
2256 for {} {$n > 0} {incr n -1} {
2257 lappend ret $o
2259 return $ret
2262 proc usedinrange {id l1 l2} {
2263 global children commitrow childlist curview
2265 if {[info exists commitrow($curview,$id)]} {
2266 set r $commitrow($curview,$id)
2267 if {$l1 <= $r && $r <= $l2} {
2268 return [expr {$r - $l1 + 1}]
2270 set kids [lindex $childlist $r]
2271 } else {
2272 set kids $children($curview,$id)
2274 foreach c $kids {
2275 set r $commitrow($curview,$c)
2276 if {$l1 <= $r && $r <= $l2} {
2277 return [expr {$r - $l1 + 1}]
2280 return 0
2283 proc sanity {row {full 0}} {
2284 global rowidlist rowoffsets
2286 set col -1
2287 set ids [lindex $rowidlist $row]
2288 foreach id $ids {
2289 incr col
2290 if {$id eq {}} continue
2291 if {$col < [llength $ids] - 1 &&
2292 [lsearch -exact -start [expr {$col+1}] $ids $id] >= 0} {
2293 puts "oops: [shortids $id] repeated in row $row col $col: {[shortids [lindex $rowidlist $row]]}"
2295 set o [lindex $rowoffsets $row $col]
2296 set y $row
2297 set x $col
2298 while {$o ne {}} {
2299 incr y -1
2300 incr x $o
2301 if {[lindex $rowidlist $y $x] != $id} {
2302 puts "oops: rowoffsets wrong at row [expr {$y+1}] col [expr {$x-$o}]"
2303 puts " id=[shortids $id] check started at row $row"
2304 for {set i $row} {$i >= $y} {incr i -1} {
2305 puts " row $i ids={[shortids [lindex $rowidlist $i]]} offs={[lindex $rowoffsets $i]}"
2307 break
2309 if {!$full} break
2310 set o [lindex $rowoffsets $y $x]
2315 proc makeuparrow {oid x y z} {
2316 global rowidlist rowoffsets uparrowlen idrowranges
2318 for {set i 1} {$i < $uparrowlen && $y > 1} {incr i} {
2319 incr y -1
2320 incr x $z
2321 set off0 [lindex $rowoffsets $y]
2322 for {set x0 $x} {1} {incr x0} {
2323 if {$x0 >= [llength $off0]} {
2324 set x0 [llength [lindex $rowoffsets [expr {$y-1}]]]
2325 break
2327 set z [lindex $off0 $x0]
2328 if {$z ne {}} {
2329 incr x0 $z
2330 break
2333 set z [expr {$x0 - $x}]
2334 lset rowidlist $y [linsert [lindex $rowidlist $y] $x $oid]
2335 lset rowoffsets $y [linsert [lindex $rowoffsets $y] $x $z]
2337 set tmp [lreplace [lindex $rowoffsets $y] $x $x {}]
2338 lset rowoffsets $y [incrange $tmp [expr {$x+1}] -1]
2339 lappend idrowranges($oid) $y
2342 proc initlayout {} {
2343 global rowidlist rowoffsets displayorder commitlisted
2344 global rowlaidout rowoptim
2345 global idinlist rowchk rowrangelist idrowranges
2346 global numcommits canvxmax canv
2347 global nextcolor
2348 global parentlist childlist children
2349 global colormap rowtextx
2350 global linesegends
2352 set numcommits 0
2353 set displayorder {}
2354 set commitlisted {}
2355 set parentlist {}
2356 set childlist {}
2357 set rowrangelist {}
2358 set nextcolor 0
2359 set rowidlist {{}}
2360 set rowoffsets {{}}
2361 catch {unset idinlist}
2362 catch {unset rowchk}
2363 set rowlaidout 0
2364 set rowoptim 0
2365 set canvxmax [$canv cget -width]
2366 catch {unset colormap}
2367 catch {unset rowtextx}
2368 catch {unset idrowranges}
2369 set linesegends {}
2372 proc setcanvscroll {} {
2373 global canv canv2 canv3 numcommits linespc canvxmax canvy0
2375 set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2376 $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2377 $canv2 conf -scrollregion [list 0 0 0 $ymax]
2378 $canv3 conf -scrollregion [list 0 0 0 $ymax]
2381 proc visiblerows {} {
2382 global canv numcommits linespc
2384 set ymax [lindex [$canv cget -scrollregion] 3]
2385 if {$ymax eq {} || $ymax == 0} return
2386 set f [$canv yview]
2387 set y0 [expr {int([lindex $f 0] * $ymax)}]
2388 set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2389 if {$r0 < 0} {
2390 set r0 0
2392 set y1 [expr {int([lindex $f 1] * $ymax)}]
2393 set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2394 if {$r1 >= $numcommits} {
2395 set r1 [expr {$numcommits - 1}]
2397 return [list $r0 $r1]
2400 proc layoutmore {tmax} {
2401 global rowlaidout rowoptim commitidx numcommits optim_delay
2402 global uparrowlen curview
2404 while {1} {
2405 if {$rowoptim - $optim_delay > $numcommits} {
2406 showstuff [expr {$rowoptim - $optim_delay}]
2407 } elseif {$rowlaidout - $uparrowlen - 1 > $rowoptim} {
2408 set nr [expr {$rowlaidout - $uparrowlen - 1 - $rowoptim}]
2409 if {$nr > 100} {
2410 set nr 100
2412 optimize_rows $rowoptim 0 [expr {$rowoptim + $nr}]
2413 incr rowoptim $nr
2414 } elseif {$commitidx($curview) > $rowlaidout} {
2415 set nr [expr {$commitidx($curview) - $rowlaidout}]
2416 # may need to increase this threshold if uparrowlen or
2417 # mingaplen are increased...
2418 if {$nr > 150} {
2419 set nr 150
2421 set row $rowlaidout
2422 set rowlaidout [layoutrows $row [expr {$row + $nr}] 0]
2423 if {$rowlaidout == $row} {
2424 return 0
2426 } else {
2427 return 0
2429 if {$tmax ne {} && [clock clicks -milliseconds] >= $tmax} {
2430 return 1
2435 proc showstuff {canshow} {
2436 global numcommits commitrow pending_select selectedline
2437 global linesegends idrowranges idrangedrawn curview
2439 if {$numcommits == 0} {
2440 global phase
2441 set phase "incrdraw"
2442 allcanvs delete all
2444 set row $numcommits
2445 set numcommits $canshow
2446 setcanvscroll
2447 set rows [visiblerows]
2448 set r0 [lindex $rows 0]
2449 set r1 [lindex $rows 1]
2450 set selrow -1
2451 for {set r $row} {$r < $canshow} {incr r} {
2452 foreach id [lindex $linesegends [expr {$r+1}]] {
2453 set i -1
2454 foreach {s e} [rowranges $id] {
2455 incr i
2456 if {$e ne {} && $e < $numcommits && $s <= $r1 && $e >= $r0
2457 && ![info exists idrangedrawn($id,$i)]} {
2458 drawlineseg $id $i
2459 set idrangedrawn($id,$i) 1
2464 if {$canshow > $r1} {
2465 set canshow $r1
2467 while {$row < $canshow} {
2468 drawcmitrow $row
2469 incr row
2471 if {[info exists pending_select] &&
2472 [info exists commitrow($curview,$pending_select)] &&
2473 $commitrow($curview,$pending_select) < $numcommits} {
2474 selectline $commitrow($curview,$pending_select) 1
2476 if {![info exists selectedline] && ![info exists pending_select]} {
2477 selectline 0 1
2481 proc layoutrows {row endrow last} {
2482 global rowidlist rowoffsets displayorder
2483 global uparrowlen downarrowlen maxwidth mingaplen
2484 global childlist parentlist
2485 global idrowranges linesegends
2486 global commitidx curview
2487 global idinlist rowchk rowrangelist
2489 set idlist [lindex $rowidlist $row]
2490 set offs [lindex $rowoffsets $row]
2491 while {$row < $endrow} {
2492 set id [lindex $displayorder $row]
2493 set oldolds {}
2494 set newolds {}
2495 foreach p [lindex $parentlist $row] {
2496 if {![info exists idinlist($p)]} {
2497 lappend newolds $p
2498 } elseif {!$idinlist($p)} {
2499 lappend oldolds $p
2502 set lse {}
2503 set nev [expr {[llength $idlist] + [llength $newolds]
2504 + [llength $oldolds] - $maxwidth + 1}]
2505 if {$nev > 0} {
2506 if {!$last &&
2507 $row + $uparrowlen + $mingaplen >= $commitidx($curview)} break
2508 for {set x [llength $idlist]} {[incr x -1] >= 0} {} {
2509 set i [lindex $idlist $x]
2510 if {![info exists rowchk($i)] || $row >= $rowchk($i)} {
2511 set r [usedinrange $i [expr {$row - $downarrowlen}] \
2512 [expr {$row + $uparrowlen + $mingaplen}]]
2513 if {$r == 0} {
2514 set idlist [lreplace $idlist $x $x]
2515 set offs [lreplace $offs $x $x]
2516 set offs [incrange $offs $x 1]
2517 set idinlist($i) 0
2518 set rm1 [expr {$row - 1}]
2519 lappend lse $i
2520 lappend idrowranges($i) $rm1
2521 if {[incr nev -1] <= 0} break
2522 continue
2524 set rowchk($id) [expr {$row + $r}]
2527 lset rowidlist $row $idlist
2528 lset rowoffsets $row $offs
2530 lappend linesegends $lse
2531 set col [lsearch -exact $idlist $id]
2532 if {$col < 0} {
2533 set col [llength $idlist]
2534 lappend idlist $id
2535 lset rowidlist $row $idlist
2536 set z {}
2537 if {[lindex $childlist $row] ne {}} {
2538 set z [expr {[llength [lindex $rowidlist [expr {$row-1}]]] - $col}]
2539 unset idinlist($id)
2541 lappend offs $z
2542 lset rowoffsets $row $offs
2543 if {$z ne {}} {
2544 makeuparrow $id $col $row $z
2546 } else {
2547 unset idinlist($id)
2549 set ranges {}
2550 if {[info exists idrowranges($id)]} {
2551 set ranges $idrowranges($id)
2552 lappend ranges $row
2553 unset idrowranges($id)
2555 lappend rowrangelist $ranges
2556 incr row
2557 set offs [ntimes [llength $idlist] 0]
2558 set l [llength $newolds]
2559 set idlist [eval lreplace \$idlist $col $col $newolds]
2560 set o 0
2561 if {$l != 1} {
2562 set offs [lrange $offs 0 [expr {$col - 1}]]
2563 foreach x $newolds {
2564 lappend offs {}
2565 incr o -1
2567 incr o
2568 set tmp [expr {[llength $idlist] - [llength $offs]}]
2569 if {$tmp > 0} {
2570 set offs [concat $offs [ntimes $tmp $o]]
2572 } else {
2573 lset offs $col {}
2575 foreach i $newolds {
2576 set idinlist($i) 1
2577 set idrowranges($i) $row
2579 incr col $l
2580 foreach oid $oldolds {
2581 set idinlist($oid) 1
2582 set idlist [linsert $idlist $col $oid]
2583 set offs [linsert $offs $col $o]
2584 makeuparrow $oid $col $row $o
2585 incr col
2587 lappend rowidlist $idlist
2588 lappend rowoffsets $offs
2590 return $row
2593 proc addextraid {id row} {
2594 global displayorder commitrow commitinfo
2595 global commitidx commitlisted
2596 global parentlist childlist children curview
2598 incr commitidx($curview)
2599 lappend displayorder $id
2600 lappend commitlisted 0
2601 lappend parentlist {}
2602 set commitrow($curview,$id) $row
2603 readcommit $id
2604 if {![info exists commitinfo($id)]} {
2605 set commitinfo($id) {"No commit information available"}
2607 if {![info exists children($curview,$id)]} {
2608 set children($curview,$id) {}
2610 lappend childlist $children($curview,$id)
2613 proc layouttail {} {
2614 global rowidlist rowoffsets idinlist commitidx curview
2615 global idrowranges rowrangelist
2617 set row $commitidx($curview)
2618 set idlist [lindex $rowidlist $row]
2619 while {$idlist ne {}} {
2620 set col [expr {[llength $idlist] - 1}]
2621 set id [lindex $idlist $col]
2622 addextraid $id $row
2623 unset idinlist($id)
2624 lappend idrowranges($id) $row
2625 lappend rowrangelist $idrowranges($id)
2626 unset idrowranges($id)
2627 incr row
2628 set offs [ntimes $col 0]
2629 set idlist [lreplace $idlist $col $col]
2630 lappend rowidlist $idlist
2631 lappend rowoffsets $offs
2634 foreach id [array names idinlist] {
2635 addextraid $id $row
2636 lset rowidlist $row [list $id]
2637 lset rowoffsets $row 0
2638 makeuparrow $id 0 $row 0
2639 lappend idrowranges($id) $row
2640 lappend rowrangelist $idrowranges($id)
2641 unset idrowranges($id)
2642 incr row
2643 lappend rowidlist {}
2644 lappend rowoffsets {}
2648 proc insert_pad {row col npad} {
2649 global rowidlist rowoffsets
2651 set pad [ntimes $npad {}]
2652 lset rowidlist $row [eval linsert [list [lindex $rowidlist $row]] $col $pad]
2653 set tmp [eval linsert [list [lindex $rowoffsets $row]] $col $pad]
2654 lset rowoffsets $row [incrange $tmp [expr {$col + $npad}] [expr {-$npad}]]
2657 proc optimize_rows {row col endrow} {
2658 global rowidlist rowoffsets idrowranges displayorder
2660 for {} {$row < $endrow} {incr row} {
2661 set idlist [lindex $rowidlist $row]
2662 set offs [lindex $rowoffsets $row]
2663 set haspad 0
2664 for {} {$col < [llength $offs]} {incr col} {
2665 if {[lindex $idlist $col] eq {}} {
2666 set haspad 1
2667 continue
2669 set z [lindex $offs $col]
2670 if {$z eq {}} continue
2671 set isarrow 0
2672 set x0 [expr {$col + $z}]
2673 set y0 [expr {$row - 1}]
2674 set z0 [lindex $rowoffsets $y0 $x0]
2675 if {$z0 eq {}} {
2676 set id [lindex $idlist $col]
2677 set ranges [rowranges $id]
2678 if {$ranges ne {} && $y0 > [lindex $ranges 0]} {
2679 set isarrow 1
2682 if {$z < -1 || ($z < 0 && $isarrow)} {
2683 set npad [expr {-1 - $z + $isarrow}]
2684 set offs [incrange $offs $col $npad]
2685 insert_pad $y0 $x0 $npad
2686 if {$y0 > 0} {
2687 optimize_rows $y0 $x0 $row
2689 set z [lindex $offs $col]
2690 set x0 [expr {$col + $z}]
2691 set z0 [lindex $rowoffsets $y0 $x0]
2692 } elseif {$z > 1 || ($z > 0 && $isarrow)} {
2693 set npad [expr {$z - 1 + $isarrow}]
2694 set y1 [expr {$row + 1}]
2695 set offs2 [lindex $rowoffsets $y1]
2696 set x1 -1
2697 foreach z $offs2 {
2698 incr x1
2699 if {$z eq {} || $x1 + $z < $col} continue
2700 if {$x1 + $z > $col} {
2701 incr npad
2703 lset rowoffsets $y1 [incrange $offs2 $x1 $npad]
2704 break
2706 set pad [ntimes $npad {}]
2707 set idlist [eval linsert \$idlist $col $pad]
2708 set tmp [eval linsert \$offs $col $pad]
2709 incr col $npad
2710 set offs [incrange $tmp $col [expr {-$npad}]]
2711 set z [lindex $offs $col]
2712 set haspad 1
2714 if {$z0 eq {} && !$isarrow} {
2715 # this line links to its first child on row $row-2
2716 set rm2 [expr {$row - 2}]
2717 set id [lindex $displayorder $rm2]
2718 set xc [lsearch -exact [lindex $rowidlist $rm2] $id]
2719 if {$xc >= 0} {
2720 set z0 [expr {$xc - $x0}]
2723 if {$z0 ne {} && $z < 0 && $z0 > 0} {
2724 insert_pad $y0 $x0 1
2725 set offs [incrange $offs $col 1]
2726 optimize_rows $y0 [expr {$x0 + 1}] $row
2729 if {!$haspad} {
2730 set o {}
2731 for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
2732 set o [lindex $offs $col]
2733 if {$o eq {}} {
2734 # check if this is the link to the first child
2735 set id [lindex $idlist $col]
2736 set ranges [rowranges $id]
2737 if {$ranges ne {} && $row == [lindex $ranges 0]} {
2738 # it is, work out offset to child
2739 set y0 [expr {$row - 1}]
2740 set id [lindex $displayorder $y0]
2741 set x0 [lsearch -exact [lindex $rowidlist $y0] $id]
2742 if {$x0 >= 0} {
2743 set o [expr {$x0 - $col}]
2747 if {$o eq {} || $o <= 0} break
2749 if {$o ne {} && [incr col] < [llength $idlist]} {
2750 set y1 [expr {$row + 1}]
2751 set offs2 [lindex $rowoffsets $y1]
2752 set x1 -1
2753 foreach z $offs2 {
2754 incr x1
2755 if {$z eq {} || $x1 + $z < $col} continue
2756 lset rowoffsets $y1 [incrange $offs2 $x1 1]
2757 break
2759 set idlist [linsert $idlist $col {}]
2760 set tmp [linsert $offs $col {}]
2761 incr col
2762 set offs [incrange $tmp $col -1]
2765 lset rowidlist $row $idlist
2766 lset rowoffsets $row $offs
2767 set col 0
2771 proc xc {row col} {
2772 global canvx0 linespc
2773 return [expr {$canvx0 + $col * $linespc}]
2776 proc yc {row} {
2777 global canvy0 linespc
2778 return [expr {$canvy0 + $row * $linespc}]
2781 proc linewidth {id} {
2782 global thickerline lthickness
2784 set wid $lthickness
2785 if {[info exists thickerline] && $id eq $thickerline} {
2786 set wid [expr {2 * $lthickness}]
2788 return $wid
2791 proc rowranges {id} {
2792 global phase idrowranges commitrow rowlaidout rowrangelist curview
2794 set ranges {}
2795 if {$phase eq {} ||
2796 ([info exists commitrow($curview,$id)]
2797 && $commitrow($curview,$id) < $rowlaidout)} {
2798 set ranges [lindex $rowrangelist $commitrow($curview,$id)]
2799 } elseif {[info exists idrowranges($id)]} {
2800 set ranges $idrowranges($id)
2802 return $ranges
2805 proc drawlineseg {id i} {
2806 global rowoffsets rowidlist
2807 global displayorder
2808 global canv colormap linespc
2809 global numcommits commitrow curview
2811 set ranges [rowranges $id]
2812 set downarrow 1
2813 if {[info exists commitrow($curview,$id)]
2814 && $commitrow($curview,$id) < $numcommits} {
2815 set downarrow [expr {$i < [llength $ranges] / 2 - 1}]
2816 } else {
2817 set downarrow 1
2819 set startrow [lindex $ranges [expr {2 * $i}]]
2820 set row [lindex $ranges [expr {2 * $i + 1}]]
2821 if {$startrow == $row} return
2822 assigncolor $id
2823 set coords {}
2824 set col [lsearch -exact [lindex $rowidlist $row] $id]
2825 if {$col < 0} {
2826 puts "oops: drawline: id $id not on row $row"
2827 return
2829 set lasto {}
2830 set ns 0
2831 while {1} {
2832 set o [lindex $rowoffsets $row $col]
2833 if {$o eq {}} break
2834 if {$o ne $lasto} {
2835 # changing direction
2836 set x [xc $row $col]
2837 set y [yc $row]
2838 lappend coords $x $y
2839 set lasto $o
2841 incr col $o
2842 incr row -1
2844 set x [xc $row $col]
2845 set y [yc $row]
2846 lappend coords $x $y
2847 if {$i == 0} {
2848 # draw the link to the first child as part of this line
2849 incr row -1
2850 set child [lindex $displayorder $row]
2851 set ccol [lsearch -exact [lindex $rowidlist $row] $child]
2852 if {$ccol >= 0} {
2853 set x [xc $row $ccol]
2854 set y [yc $row]
2855 if {$ccol < $col - 1} {
2856 lappend coords [xc $row [expr {$col - 1}]] [yc $row]
2857 } elseif {$ccol > $col + 1} {
2858 lappend coords [xc $row [expr {$col + 1}]] [yc $row]
2860 lappend coords $x $y
2863 if {[llength $coords] < 4} return
2864 if {$downarrow} {
2865 # This line has an arrow at the lower end: check if the arrow is
2866 # on a diagonal segment, and if so, work around the Tk 8.4
2867 # refusal to draw arrows on diagonal lines.
2868 set x0 [lindex $coords 0]
2869 set x1 [lindex $coords 2]
2870 if {$x0 != $x1} {
2871 set y0 [lindex $coords 1]
2872 set y1 [lindex $coords 3]
2873 if {$y0 - $y1 <= 2 * $linespc && $x1 == [lindex $coords 4]} {
2874 # we have a nearby vertical segment, just trim off the diag bit
2875 set coords [lrange $coords 2 end]
2876 } else {
2877 set slope [expr {($x0 - $x1) / ($y0 - $y1)}]
2878 set xi [expr {$x0 - $slope * $linespc / 2}]
2879 set yi [expr {$y0 - $linespc / 2}]
2880 set coords [lreplace $coords 0 1 $xi $y0 $xi $yi]
2884 set arrow [expr {2 * ($i > 0) + $downarrow}]
2885 set arrow [lindex {none first last both} $arrow]
2886 set t [$canv create line $coords -width [linewidth $id] \
2887 -fill $colormap($id) -tags lines.$id -arrow $arrow]
2888 $canv lower $t
2889 bindline $t $id
2892 proc drawparentlinks {id row col olds} {
2893 global rowidlist canv colormap
2895 set row2 [expr {$row + 1}]
2896 set x [xc $row $col]
2897 set y [yc $row]
2898 set y2 [yc $row2]
2899 set ids [lindex $rowidlist $row2]
2900 # rmx = right-most X coord used
2901 set rmx 0
2902 foreach p $olds {
2903 set i [lsearch -exact $ids $p]
2904 if {$i < 0} {
2905 puts "oops, parent $p of $id not in list"
2906 continue
2908 set x2 [xc $row2 $i]
2909 if {$x2 > $rmx} {
2910 set rmx $x2
2912 set ranges [rowranges $p]
2913 if {$ranges ne {} && $row2 == [lindex $ranges 0]
2914 && $row2 < [lindex $ranges 1]} {
2915 # drawlineseg will do this one for us
2916 continue
2918 assigncolor $p
2919 # should handle duplicated parents here...
2920 set coords [list $x $y]
2921 if {$i < $col - 1} {
2922 lappend coords [xc $row [expr {$i + 1}]] $y
2923 } elseif {$i > $col + 1} {
2924 lappend coords [xc $row [expr {$i - 1}]] $y
2926 lappend coords $x2 $y2
2927 set t [$canv create line $coords -width [linewidth $p] \
2928 -fill $colormap($p) -tags lines.$p]
2929 $canv lower $t
2930 bindline $t $p
2932 return $rmx
2935 proc drawlines {id} {
2936 global colormap canv
2937 global idrangedrawn
2938 global children iddrawn commitrow rowidlist curview
2940 $canv delete lines.$id
2941 set nr [expr {[llength [rowranges $id]] / 2}]
2942 for {set i 0} {$i < $nr} {incr i} {
2943 if {[info exists idrangedrawn($id,$i)]} {
2944 drawlineseg $id $i
2947 foreach child $children($curview,$id) {
2948 if {[info exists iddrawn($child)]} {
2949 set row $commitrow($curview,$child)
2950 set col [lsearch -exact [lindex $rowidlist $row] $child]
2951 if {$col >= 0} {
2952 drawparentlinks $child $row $col [list $id]
2958 proc drawcmittext {id row col rmx} {
2959 global linespc canv canv2 canv3 canvy0 fgcolor
2960 global commitlisted commitinfo rowidlist
2961 global rowtextx idpos idtags idheads idotherrefs
2962 global linehtag linentag linedtag
2963 global mainfont canvxmax boldrows boldnamerows fgcolor
2965 set ofill [expr {[lindex $commitlisted $row]? "blue": "white"}]
2966 set x [xc $row $col]
2967 set y [yc $row]
2968 set orad [expr {$linespc / 3}]
2969 set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
2970 [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
2971 -fill $ofill -outline $fgcolor -width 1 -tags circle]
2972 $canv raise $t
2973 $canv bind $t <1> {selcanvline {} %x %y}
2974 set xt [xc $row [llength [lindex $rowidlist $row]]]
2975 if {$xt < $rmx} {
2976 set xt $rmx
2978 set rowtextx($row) $xt
2979 set idpos($id) [list $x $xt $y]
2980 if {[info exists idtags($id)] || [info exists idheads($id)]
2981 || [info exists idotherrefs($id)]} {
2982 set xt [drawtags $id $x $xt $y]
2984 set headline [lindex $commitinfo($id) 0]
2985 set name [lindex $commitinfo($id) 1]
2986 set date [lindex $commitinfo($id) 2]
2987 set date [formatdate $date]
2988 set font $mainfont
2989 set nfont $mainfont
2990 set isbold [ishighlighted $row]
2991 if {$isbold > 0} {
2992 lappend boldrows $row
2993 lappend font bold
2994 if {$isbold > 1} {
2995 lappend boldnamerows $row
2996 lappend nfont bold
2999 set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3000 -text $headline -font $font -tags text]
3001 $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3002 set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3003 -text $name -font $nfont -tags text]
3004 set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3005 -text $date -font $mainfont -tags text]
3006 set xr [expr {$xt + [font measure $mainfont $headline]}]
3007 if {$xr > $canvxmax} {
3008 set canvxmax $xr
3009 setcanvscroll
3013 proc drawcmitrow {row} {
3014 global displayorder rowidlist
3015 global idrangedrawn iddrawn
3016 global commitinfo parentlist numcommits
3017 global filehighlight fhighlights findstring nhighlights
3018 global hlview vhighlights
3019 global highlight_related rhighlights
3021 if {$row >= $numcommits} return
3022 foreach id [lindex $rowidlist $row] {
3023 if {$id eq {}} continue
3024 set i -1
3025 foreach {s e} [rowranges $id] {
3026 incr i
3027 if {$row < $s} continue
3028 if {$e eq {}} break
3029 if {$row <= $e} {
3030 if {$e < $numcommits && ![info exists idrangedrawn($id,$i)]} {
3031 drawlineseg $id $i
3032 set idrangedrawn($id,$i) 1
3034 break
3039 set id [lindex $displayorder $row]
3040 if {[info exists hlview] && ![info exists vhighlights($row)]} {
3041 askvhighlight $row $id
3043 if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3044 askfilehighlight $row $id
3046 if {$findstring ne {} && ![info exists nhighlights($row)]} {
3047 askfindhighlight $row $id
3049 if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3050 askrelhighlight $row $id
3052 if {[info exists iddrawn($id)]} return
3053 set col [lsearch -exact [lindex $rowidlist $row] $id]
3054 if {$col < 0} {
3055 puts "oops, row $row id $id not in list"
3056 return
3058 if {![info exists commitinfo($id)]} {
3059 getcommit $id
3061 assigncolor $id
3062 set olds [lindex $parentlist $row]
3063 if {$olds ne {}} {
3064 set rmx [drawparentlinks $id $row $col $olds]
3065 } else {
3066 set rmx 0
3068 drawcmittext $id $row $col $rmx
3069 set iddrawn($id) 1
3072 proc drawfrac {f0 f1} {
3073 global numcommits canv
3074 global linespc
3076 set ymax [lindex [$canv cget -scrollregion] 3]
3077 if {$ymax eq {} || $ymax == 0} return
3078 set y0 [expr {int($f0 * $ymax)}]
3079 set row [expr {int(($y0 - 3) / $linespc) - 1}]
3080 if {$row < 0} {
3081 set row 0
3083 set y1 [expr {int($f1 * $ymax)}]
3084 set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3085 if {$endrow >= $numcommits} {
3086 set endrow [expr {$numcommits - 1}]
3088 for {} {$row <= $endrow} {incr row} {
3089 drawcmitrow $row
3093 proc drawvisible {} {
3094 global canv
3095 eval drawfrac [$canv yview]
3098 proc clear_display {} {
3099 global iddrawn idrangedrawn
3100 global vhighlights fhighlights nhighlights rhighlights
3102 allcanvs delete all
3103 catch {unset iddrawn}
3104 catch {unset idrangedrawn}
3105 catch {unset vhighlights}
3106 catch {unset fhighlights}
3107 catch {unset nhighlights}
3108 catch {unset rhighlights}
3111 proc findcrossings {id} {
3112 global rowidlist parentlist numcommits rowoffsets displayorder
3114 set cross {}
3115 set ccross {}
3116 foreach {s e} [rowranges $id] {
3117 if {$e >= $numcommits} {
3118 set e [expr {$numcommits - 1}]
3120 if {$e <= $s} continue
3121 set x [lsearch -exact [lindex $rowidlist $e] $id]
3122 if {$x < 0} {
3123 puts "findcrossings: oops, no [shortids $id] in row $e"
3124 continue
3126 for {set row $e} {[incr row -1] >= $s} {} {
3127 set olds [lindex $parentlist $row]
3128 set kid [lindex $displayorder $row]
3129 set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3130 if {$kidx < 0} continue
3131 set nextrow [lindex $rowidlist [expr {$row + 1}]]
3132 foreach p $olds {
3133 set px [lsearch -exact $nextrow $p]
3134 if {$px < 0} continue
3135 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3136 if {[lsearch -exact $ccross $p] >= 0} continue
3137 if {$x == $px + ($kidx < $px? -1: 1)} {
3138 lappend ccross $p
3139 } elseif {[lsearch -exact $cross $p] < 0} {
3140 lappend cross $p
3144 set inc [lindex $rowoffsets $row $x]
3145 if {$inc eq {}} break
3146 incr x $inc
3149 return [concat $ccross {{}} $cross]
3152 proc assigncolor {id} {
3153 global colormap colors nextcolor
3154 global commitrow parentlist children children curview
3156 if {[info exists colormap($id)]} return
3157 set ncolors [llength $colors]
3158 if {[info exists children($curview,$id)]} {
3159 set kids $children($curview,$id)
3160 } else {
3161 set kids {}
3163 if {[llength $kids] == 1} {
3164 set child [lindex $kids 0]
3165 if {[info exists colormap($child)]
3166 && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3167 set colormap($id) $colormap($child)
3168 return
3171 set badcolors {}
3172 set origbad {}
3173 foreach x [findcrossings $id] {
3174 if {$x eq {}} {
3175 # delimiter between corner crossings and other crossings
3176 if {[llength $badcolors] >= $ncolors - 1} break
3177 set origbad $badcolors
3179 if {[info exists colormap($x)]
3180 && [lsearch -exact $badcolors $colormap($x)] < 0} {
3181 lappend badcolors $colormap($x)
3184 if {[llength $badcolors] >= $ncolors} {
3185 set badcolors $origbad
3187 set origbad $badcolors
3188 if {[llength $badcolors] < $ncolors - 1} {
3189 foreach child $kids {
3190 if {[info exists colormap($child)]
3191 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3192 lappend badcolors $colormap($child)
3194 foreach p [lindex $parentlist $commitrow($curview,$child)] {
3195 if {[info exists colormap($p)]
3196 && [lsearch -exact $badcolors $colormap($p)] < 0} {
3197 lappend badcolors $colormap($p)
3201 if {[llength $badcolors] >= $ncolors} {
3202 set badcolors $origbad
3205 for {set i 0} {$i <= $ncolors} {incr i} {
3206 set c [lindex $colors $nextcolor]
3207 if {[incr nextcolor] >= $ncolors} {
3208 set nextcolor 0
3210 if {[lsearch -exact $badcolors $c]} break
3212 set colormap($id) $c
3215 proc bindline {t id} {
3216 global canv
3218 $canv bind $t <Enter> "lineenter %x %y $id"
3219 $canv bind $t <Motion> "linemotion %x %y $id"
3220 $canv bind $t <Leave> "lineleave $id"
3221 $canv bind $t <Button-1> "lineclick %x %y $id 1"
3224 proc drawtags {id x xt y1} {
3225 global idtags idheads idotherrefs mainhead
3226 global linespc lthickness
3227 global canv mainfont commitrow rowtextx curview fgcolor bgcolor
3229 set marks {}
3230 set ntags 0
3231 set nheads 0
3232 if {[info exists idtags($id)]} {
3233 set marks $idtags($id)
3234 set ntags [llength $marks]
3236 if {[info exists idheads($id)]} {
3237 set marks [concat $marks $idheads($id)]
3238 set nheads [llength $idheads($id)]
3240 if {[info exists idotherrefs($id)]} {
3241 set marks [concat $marks $idotherrefs($id)]
3243 if {$marks eq {}} {
3244 return $xt
3247 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
3248 set yt [expr {$y1 - 0.5 * $linespc}]
3249 set yb [expr {$yt + $linespc - 1}]
3250 set xvals {}
3251 set wvals {}
3252 set i -1
3253 foreach tag $marks {
3254 incr i
3255 if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
3256 set wid [font measure [concat $mainfont bold] $tag]
3257 } else {
3258 set wid [font measure $mainfont $tag]
3260 lappend xvals $xt
3261 lappend wvals $wid
3262 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
3264 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
3265 -width $lthickness -fill black -tags tag.$id]
3266 $canv lower $t
3267 foreach tag $marks x $xvals wid $wvals {
3268 set xl [expr {$x + $delta}]
3269 set xr [expr {$x + $delta + $wid + $lthickness}]
3270 set font $mainfont
3271 if {[incr ntags -1] >= 0} {
3272 # draw a tag
3273 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
3274 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
3275 -width 1 -outline black -fill yellow -tags tag.$id]
3276 $canv bind $t <1> [list showtag $tag 1]
3277 set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
3278 } else {
3279 # draw a head or other ref
3280 if {[incr nheads -1] >= 0} {
3281 set col green
3282 if {$tag eq $mainhead} {
3283 lappend font bold
3285 } else {
3286 set col "#ddddff"
3288 set xl [expr {$xl - $delta/2}]
3289 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
3290 -width 1 -outline black -fill $col -tags tag.$id
3291 if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
3292 set rwid [font measure $mainfont $remoteprefix]
3293 set xi [expr {$x + 1}]
3294 set yti [expr {$yt + 1}]
3295 set xri [expr {$x + $rwid}]
3296 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
3297 -width 0 -fill "#ffddaa" -tags tag.$id
3300 set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
3301 -font $font -tags [list tag.$id text]]
3302 if {$ntags >= 0} {
3303 $canv bind $t <1> [list showtag $tag 1]
3304 } elseif {$nheads >= 0} {
3305 $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
3308 return $xt
3311 proc xcoord {i level ln} {
3312 global canvx0 xspc1 xspc2
3314 set x [expr {$canvx0 + $i * $xspc1($ln)}]
3315 if {$i > 0 && $i == $level} {
3316 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
3317 } elseif {$i > $level} {
3318 set x [expr {$x + $xspc2 - $xspc1($ln)}]
3320 return $x
3323 proc show_status {msg} {
3324 global canv mainfont fgcolor
3326 clear_display
3327 $canv create text 3 3 -anchor nw -text $msg -font $mainfont \
3328 -tags text -fill $fgcolor
3331 proc finishcommits {} {
3332 global commitidx phase curview
3333 global pending_select
3335 if {$commitidx($curview) > 0} {
3336 drawrest
3337 } else {
3338 show_status "No commits selected"
3340 set phase {}
3341 catch {unset pending_select}
3344 # Insert a new commit as the child of the commit on row $row.
3345 # The new commit will be displayed on row $row and the commits
3346 # on that row and below will move down one row.
3347 proc insertrow {row newcmit} {
3348 global displayorder parentlist childlist commitlisted
3349 global commitrow curview rowidlist rowoffsets numcommits
3350 global rowrangelist idrowranges rowlaidout rowoptim numcommits
3351 global linesegends selectedline
3353 if {$row >= $numcommits} {
3354 puts "oops, inserting new row $row but only have $numcommits rows"
3355 return
3357 set p [lindex $displayorder $row]
3358 set displayorder [linsert $displayorder $row $newcmit]
3359 set parentlist [linsert $parentlist $row $p]
3360 set kids [lindex $childlist $row]
3361 lappend kids $newcmit
3362 lset childlist $row $kids
3363 set childlist [linsert $childlist $row {}]
3364 set commitlisted [linsert $commitlisted $row 1]
3365 set l [llength $displayorder]
3366 for {set r $row} {$r < $l} {incr r} {
3367 set id [lindex $displayorder $r]
3368 set commitrow($curview,$id) $r
3371 set idlist [lindex $rowidlist $row]
3372 set offs [lindex $rowoffsets $row]
3373 set newoffs {}
3374 foreach x $idlist {
3375 if {$x eq {} || ($x eq $p && [llength $kids] == 1)} {
3376 lappend newoffs {}
3377 } else {
3378 lappend newoffs 0
3381 if {[llength $kids] == 1} {
3382 set col [lsearch -exact $idlist $p]
3383 lset idlist $col $newcmit
3384 } else {
3385 set col [llength $idlist]
3386 lappend idlist $newcmit
3387 lappend offs {}
3388 lset rowoffsets $row $offs
3390 set rowidlist [linsert $rowidlist $row $idlist]
3391 set rowoffsets [linsert $rowoffsets [expr {$row+1}] $newoffs]
3393 set rowrangelist [linsert $rowrangelist $row {}]
3394 set l [llength $rowrangelist]
3395 for {set r 0} {$r < $l} {incr r} {
3396 set ranges [lindex $rowrangelist $r]
3397 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3398 set newranges {}
3399 foreach x $ranges {
3400 if {$x >= $row} {
3401 lappend newranges [expr {$x + 1}]
3402 } else {
3403 lappend newranges $x
3406 lset rowrangelist $r $newranges
3409 if {[llength $kids] > 1} {
3410 set rp1 [expr {$row + 1}]
3411 set ranges [lindex $rowrangelist $rp1]
3412 if {$ranges eq {}} {
3413 set ranges [list $row $rp1]
3414 } elseif {[lindex $ranges end-1] == $rp1} {
3415 lset ranges end-1 $row
3417 lset rowrangelist $rp1 $ranges
3419 foreach id [array names idrowranges] {
3420 set ranges $idrowranges($id)
3421 if {$ranges ne {} && [lindex $ranges end] >= $row} {
3422 set newranges {}
3423 foreach x $ranges {
3424 if {$x >= $row} {
3425 lappend newranges [expr {$x + 1}]
3426 } else {
3427 lappend newranges $x
3430 set idrowranges($id) $newranges
3434 set linesegends [linsert $linesegends $row {}]
3436 incr rowlaidout
3437 incr rowoptim
3438 incr numcommits
3440 if {[info exists selectedline] && $selectedline >= $row} {
3441 incr selectedline
3443 redisplay
3446 # Don't change the text pane cursor if it is currently the hand cursor,
3447 # showing that we are over a sha1 ID link.
3448 proc settextcursor {c} {
3449 global ctext curtextcursor
3451 if {[$ctext cget -cursor] == $curtextcursor} {
3452 $ctext config -cursor $c
3454 set curtextcursor $c
3457 proc nowbusy {what} {
3458 global isbusy
3460 if {[array names isbusy] eq {}} {
3461 . config -cursor watch
3462 settextcursor watch
3464 set isbusy($what) 1
3467 proc notbusy {what} {
3468 global isbusy maincursor textcursor
3470 catch {unset isbusy($what)}
3471 if {[array names isbusy] eq {}} {
3472 . config -cursor $maincursor
3473 settextcursor $textcursor
3477 proc drawrest {} {
3478 global startmsecs
3479 global rowlaidout commitidx curview
3480 global pending_select
3482 set row $rowlaidout
3483 layoutrows $rowlaidout $commitidx($curview) 1
3484 layouttail
3485 optimize_rows $row 0 $commitidx($curview)
3486 showstuff $commitidx($curview)
3487 if {[info exists pending_select]} {
3488 selectline 0 1
3491 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
3492 #global numcommits
3493 #puts "overall $drawmsecs ms for $numcommits commits"
3496 proc findmatches {f} {
3497 global findtype foundstring foundstrlen
3498 if {$findtype == "Regexp"} {
3499 set matches [regexp -indices -all -inline $foundstring $f]
3500 } else {
3501 if {$findtype == "IgnCase"} {
3502 set str [string tolower $f]
3503 } else {
3504 set str $f
3506 set matches {}
3507 set i 0
3508 while {[set j [string first $foundstring $str $i]] >= 0} {
3509 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
3510 set i [expr {$j + $foundstrlen}]
3513 return $matches
3516 proc dofind {} {
3517 global findtype findloc findstring markedmatches commitinfo
3518 global numcommits displayorder linehtag linentag linedtag
3519 global mainfont canv canv2 canv3 selectedline
3520 global matchinglines foundstring foundstrlen matchstring
3521 global commitdata
3523 stopfindproc
3524 unmarkmatches
3525 cancel_next_highlight
3526 focus .
3527 set matchinglines {}
3528 if {$findtype == "IgnCase"} {
3529 set foundstring [string tolower $findstring]
3530 } else {
3531 set foundstring $findstring
3533 set foundstrlen [string length $findstring]
3534 if {$foundstrlen == 0} return
3535 regsub -all {[*?\[\\]} $foundstring {\\&} matchstring
3536 set matchstring "*$matchstring*"
3537 if {![info exists selectedline]} {
3538 set oldsel -1
3539 } else {
3540 set oldsel $selectedline
3542 set didsel 0
3543 set fldtypes {Headline Author Date Committer CDate Comments}
3544 set l -1
3545 foreach id $displayorder {
3546 set d $commitdata($id)
3547 incr l
3548 if {$findtype == "Regexp"} {
3549 set doesmatch [regexp $foundstring $d]
3550 } elseif {$findtype == "IgnCase"} {
3551 set doesmatch [string match -nocase $matchstring $d]
3552 } else {
3553 set doesmatch [string match $matchstring $d]
3555 if {!$doesmatch} continue
3556 if {![info exists commitinfo($id)]} {
3557 getcommit $id
3559 set info $commitinfo($id)
3560 set doesmatch 0
3561 foreach f $info ty $fldtypes {
3562 if {$findloc != "All fields" && $findloc != $ty} {
3563 continue
3565 set matches [findmatches $f]
3566 if {$matches == {}} continue
3567 set doesmatch 1
3568 if {$ty == "Headline"} {
3569 drawcmitrow $l
3570 markmatches $canv $l $f $linehtag($l) $matches $mainfont
3571 } elseif {$ty == "Author"} {
3572 drawcmitrow $l
3573 markmatches $canv2 $l $f $linentag($l) $matches $mainfont
3574 } elseif {$ty == "Date"} {
3575 drawcmitrow $l
3576 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
3579 if {$doesmatch} {
3580 lappend matchinglines $l
3581 if {!$didsel && $l > $oldsel} {
3582 findselectline $l
3583 set didsel 1
3587 if {$matchinglines == {}} {
3588 bell
3589 } elseif {!$didsel} {
3590 findselectline [lindex $matchinglines 0]
3594 proc findselectline {l} {
3595 global findloc commentend ctext
3596 selectline $l 1
3597 if {$findloc == "All fields" || $findloc == "Comments"} {
3598 # highlight the matches in the comments
3599 set f [$ctext get 1.0 $commentend]
3600 set matches [findmatches $f]
3601 foreach match $matches {
3602 set start [lindex $match 0]
3603 set end [expr {[lindex $match 1] + 1}]
3604 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
3609 proc findnext {restart} {
3610 global matchinglines selectedline
3611 if {![info exists matchinglines]} {
3612 if {$restart} {
3613 dofind
3615 return
3617 if {![info exists selectedline]} return
3618 foreach l $matchinglines {
3619 if {$l > $selectedline} {
3620 findselectline $l
3621 return
3624 bell
3627 proc findprev {} {
3628 global matchinglines selectedline
3629 if {![info exists matchinglines]} {
3630 dofind
3631 return
3633 if {![info exists selectedline]} return
3634 set prev {}
3635 foreach l $matchinglines {
3636 if {$l >= $selectedline} break
3637 set prev $l
3639 if {$prev != {}} {
3640 findselectline $prev
3641 } else {
3642 bell
3646 proc stopfindproc {{done 0}} {
3647 global findprocpid findprocfile findids
3648 global ctext findoldcursor phase maincursor textcursor
3649 global findinprogress
3651 catch {unset findids}
3652 if {[info exists findprocpid]} {
3653 if {!$done} {
3654 catch {exec kill $findprocpid}
3656 catch {close $findprocfile}
3657 unset findprocpid
3659 catch {unset findinprogress}
3660 notbusy find
3663 # mark a commit as matching by putting a yellow background
3664 # behind the headline
3665 proc markheadline {l id} {
3666 global canv mainfont linehtag
3668 drawcmitrow $l
3669 set bbox [$canv bbox $linehtag($l)]
3670 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
3671 $canv lower $t
3674 # mark the bits of a headline, author or date that match a find string
3675 proc markmatches {canv l str tag matches font} {
3676 set bbox [$canv bbox $tag]
3677 set x0 [lindex $bbox 0]
3678 set y0 [lindex $bbox 1]
3679 set y1 [lindex $bbox 3]
3680 foreach match $matches {
3681 set start [lindex $match 0]
3682 set end [lindex $match 1]
3683 if {$start > $end} continue
3684 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
3685 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
3686 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
3687 [expr {$x0+$xlen+2}] $y1 \
3688 -outline {} -tags matches -fill yellow]
3689 $canv lower $t
3693 proc unmarkmatches {} {
3694 global matchinglines findids
3695 allcanvs delete matches
3696 catch {unset matchinglines}
3697 catch {unset findids}
3700 proc selcanvline {w x y} {
3701 global canv canvy0 ctext linespc
3702 global rowtextx
3703 set ymax [lindex [$canv cget -scrollregion] 3]
3704 if {$ymax == {}} return
3705 set yfrac [lindex [$canv yview] 0]
3706 set y [expr {$y + $yfrac * $ymax}]
3707 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
3708 if {$l < 0} {
3709 set l 0
3711 if {$w eq $canv} {
3712 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
3714 unmarkmatches
3715 selectline $l 1
3718 proc commit_descriptor {p} {
3719 global commitinfo
3720 if {![info exists commitinfo($p)]} {
3721 getcommit $p
3723 set l "..."
3724 if {[llength $commitinfo($p)] > 1} {
3725 set l [lindex $commitinfo($p) 0]
3727 return "$p ($l)\n"
3730 # append some text to the ctext widget, and make any SHA1 ID
3731 # that we know about be a clickable link.
3732 proc appendwithlinks {text tags} {
3733 global ctext commitrow linknum curview
3735 set start [$ctext index "end - 1c"]
3736 $ctext insert end $text $tags
3737 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
3738 foreach l $links {
3739 set s [lindex $l 0]
3740 set e [lindex $l 1]
3741 set linkid [string range $text $s $e]
3742 if {![info exists commitrow($curview,$linkid)]} continue
3743 incr e
3744 $ctext tag add link "$start + $s c" "$start + $e c"
3745 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
3746 $ctext tag bind link$linknum <1> \
3747 [list selectline $commitrow($curview,$linkid) 1]
3748 incr linknum
3750 $ctext tag conf link -foreground blue -underline 1
3751 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3752 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3755 proc viewnextline {dir} {
3756 global canv linespc
3758 $canv delete hover
3759 set ymax [lindex [$canv cget -scrollregion] 3]
3760 set wnow [$canv yview]
3761 set wtop [expr {[lindex $wnow 0] * $ymax}]
3762 set newtop [expr {$wtop + $dir * $linespc}]
3763 if {$newtop < 0} {
3764 set newtop 0
3765 } elseif {$newtop > $ymax} {
3766 set newtop $ymax
3768 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3771 # add a list of tag or branch names at position pos
3772 # returns the number of names inserted
3773 proc appendrefs {pos tags var} {
3774 global ctext commitrow linknum curview $var
3776 if {[catch {$ctext index $pos}]} {
3777 return 0
3779 set tags [lsort $tags]
3780 set sep {}
3781 foreach tag $tags {
3782 set id [set $var\($tag\)]
3783 set lk link$linknum
3784 incr linknum
3785 $ctext insert $pos $sep
3786 $ctext insert $pos $tag $lk
3787 $ctext tag conf $lk -foreground blue
3788 if {[info exists commitrow($curview,$id)]} {
3789 $ctext tag bind $lk <1> \
3790 [list selectline $commitrow($curview,$id) 1]
3791 $ctext tag conf $lk -underline 1
3792 $ctext tag bind $lk <Enter> { %W configure -cursor hand2 }
3793 $ctext tag bind $lk <Leave> { %W configure -cursor $curtextcursor }
3795 set sep ", "
3797 return [llength $tags]
3800 proc taglist {ids} {
3801 global idtags
3803 set tags {}
3804 foreach id $ids {
3805 foreach tag $idtags($id) {
3806 lappend tags $tag
3809 return $tags
3812 # called when we have finished computing the nearby tags
3813 proc dispneartags {} {
3814 global selectedline currentid ctext anc_tags desc_tags showneartags
3815 global desc_heads
3817 if {![info exists selectedline] || !$showneartags} return
3818 set id $currentid
3819 $ctext conf -state normal
3820 if {[info exists desc_heads($id)]} {
3821 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3822 $ctext insert "branch -2c" "es"
3825 if {[info exists anc_tags($id)]} {
3826 appendrefs follows [taglist $anc_tags($id)] tagids
3828 if {[info exists desc_tags($id)]} {
3829 appendrefs precedes [taglist $desc_tags($id)] tagids
3831 $ctext conf -state disabled
3834 proc selectline {l isnew} {
3835 global canv canv2 canv3 ctext commitinfo selectedline
3836 global displayorder linehtag linentag linedtag
3837 global canvy0 linespc parentlist childlist
3838 global currentid sha1entry
3839 global commentend idtags linknum
3840 global mergemax numcommits pending_select
3841 global cmitmode desc_tags anc_tags showneartags allcommits desc_heads
3843 catch {unset pending_select}
3844 $canv delete hover
3845 normalline
3846 cancel_next_highlight
3847 if {$l < 0 || $l >= $numcommits} return
3848 set y [expr {$canvy0 + $l * $linespc}]
3849 set ymax [lindex [$canv cget -scrollregion] 3]
3850 set ytop [expr {$y - $linespc - 1}]
3851 set ybot [expr {$y + $linespc + 1}]
3852 set wnow [$canv yview]
3853 set wtop [expr {[lindex $wnow 0] * $ymax}]
3854 set wbot [expr {[lindex $wnow 1] * $ymax}]
3855 set wh [expr {$wbot - $wtop}]
3856 set newtop $wtop
3857 if {$ytop < $wtop} {
3858 if {$ybot < $wtop} {
3859 set newtop [expr {$y - $wh / 2.0}]
3860 } else {
3861 set newtop $ytop
3862 if {$newtop > $wtop - $linespc} {
3863 set newtop [expr {$wtop - $linespc}]
3866 } elseif {$ybot > $wbot} {
3867 if {$ytop > $wbot} {
3868 set newtop [expr {$y - $wh / 2.0}]
3869 } else {
3870 set newtop [expr {$ybot - $wh}]
3871 if {$newtop < $wtop + $linespc} {
3872 set newtop [expr {$wtop + $linespc}]
3876 if {$newtop != $wtop} {
3877 if {$newtop < 0} {
3878 set newtop 0
3880 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
3881 drawvisible
3884 if {![info exists linehtag($l)]} return
3885 $canv delete secsel
3886 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
3887 -tags secsel -fill [$canv cget -selectbackground]]
3888 $canv lower $t
3889 $canv2 delete secsel
3890 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
3891 -tags secsel -fill [$canv2 cget -selectbackground]]
3892 $canv2 lower $t
3893 $canv3 delete secsel
3894 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
3895 -tags secsel -fill [$canv3 cget -selectbackground]]
3896 $canv3 lower $t
3898 if {$isnew} {
3899 addtohistory [list selectline $l 0]
3902 set selectedline $l
3904 set id [lindex $displayorder $l]
3905 set currentid $id
3906 $sha1entry delete 0 end
3907 $sha1entry insert 0 $id
3908 $sha1entry selection from 0
3909 $sha1entry selection to end
3910 rhighlight_sel $id
3912 $ctext conf -state normal
3913 clear_ctext
3914 set linknum 0
3915 set info $commitinfo($id)
3916 set date [formatdate [lindex $info 2]]
3917 $ctext insert end "Author: [lindex $info 1] $date\n"
3918 set date [formatdate [lindex $info 4]]
3919 $ctext insert end "Committer: [lindex $info 3] $date\n"
3920 if {[info exists idtags($id)]} {
3921 $ctext insert end "Tags:"
3922 foreach tag $idtags($id) {
3923 $ctext insert end " $tag"
3925 $ctext insert end "\n"
3928 set headers {}
3929 set olds [lindex $parentlist $l]
3930 if {[llength $olds] > 1} {
3931 set np 0
3932 foreach p $olds {
3933 if {$np >= $mergemax} {
3934 set tag mmax
3935 } else {
3936 set tag m$np
3938 $ctext insert end "Parent: " $tag
3939 appendwithlinks [commit_descriptor $p] {}
3940 incr np
3942 } else {
3943 foreach p $olds {
3944 append headers "Parent: [commit_descriptor $p]"
3948 foreach c [lindex $childlist $l] {
3949 append headers "Child: [commit_descriptor $c]"
3952 # make anything that looks like a SHA1 ID be a clickable link
3953 appendwithlinks $headers {}
3954 if {$showneartags} {
3955 if {![info exists allcommits]} {
3956 getallcommits
3958 $ctext insert end "Branch: "
3959 $ctext mark set branch "end -1c"
3960 $ctext mark gravity branch left
3961 if {[info exists desc_heads($id)]} {
3962 if {[appendrefs branch $desc_heads($id) headids] > 1} {
3963 # turn "Branch" into "Branches"
3964 $ctext insert "branch -2c" "es"
3967 $ctext insert end "\nFollows: "
3968 $ctext mark set follows "end -1c"
3969 $ctext mark gravity follows left
3970 if {[info exists anc_tags($id)]} {
3971 appendrefs follows [taglist $anc_tags($id)] tagids
3973 $ctext insert end "\nPrecedes: "
3974 $ctext mark set precedes "end -1c"
3975 $ctext mark gravity precedes left
3976 if {[info exists desc_tags($id)]} {
3977 appendrefs precedes [taglist $desc_tags($id)] tagids
3979 $ctext insert end "\n"
3981 $ctext insert end "\n"
3982 appendwithlinks [lindex $info 5] {comment}
3984 $ctext tag delete Comments
3985 $ctext tag remove found 1.0 end
3986 $ctext conf -state disabled
3987 set commentend [$ctext index "end - 1c"]
3989 init_flist "Comments"
3990 if {$cmitmode eq "tree"} {
3991 gettree $id
3992 } elseif {[llength $olds] <= 1} {
3993 startdiff $id
3994 } else {
3995 mergediff $id $l
3999 proc selfirstline {} {
4000 unmarkmatches
4001 selectline 0 1
4004 proc sellastline {} {
4005 global numcommits
4006 unmarkmatches
4007 set l [expr {$numcommits - 1}]
4008 selectline $l 1
4011 proc selnextline {dir} {
4012 global selectedline
4013 if {![info exists selectedline]} return
4014 set l [expr {$selectedline + $dir}]
4015 unmarkmatches
4016 selectline $l 1
4019 proc selnextpage {dir} {
4020 global canv linespc selectedline numcommits
4022 set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4023 if {$lpp < 1} {
4024 set lpp 1
4026 allcanvs yview scroll [expr {$dir * $lpp}] units
4027 drawvisible
4028 if {![info exists selectedline]} return
4029 set l [expr {$selectedline + $dir * $lpp}]
4030 if {$l < 0} {
4031 set l 0
4032 } elseif {$l >= $numcommits} {
4033 set l [expr $numcommits - 1]
4035 unmarkmatches
4036 selectline $l 1
4039 proc unselectline {} {
4040 global selectedline currentid
4042 catch {unset selectedline}
4043 catch {unset currentid}
4044 allcanvs delete secsel
4045 rhighlight_none
4046 cancel_next_highlight
4049 proc reselectline {} {
4050 global selectedline
4052 if {[info exists selectedline]} {
4053 selectline $selectedline 0
4057 proc addtohistory {cmd} {
4058 global history historyindex curview
4060 set elt [list $curview $cmd]
4061 if {$historyindex > 0
4062 && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4063 return
4066 if {$historyindex < [llength $history]} {
4067 set history [lreplace $history $historyindex end $elt]
4068 } else {
4069 lappend history $elt
4071 incr historyindex
4072 if {$historyindex > 1} {
4073 .tf.bar.leftbut conf -state normal
4074 } else {
4075 .tf.bar.leftbut conf -state disabled
4077 .tf.bar.rightbut conf -state disabled
4080 proc godo {elt} {
4081 global curview
4083 set view [lindex $elt 0]
4084 set cmd [lindex $elt 1]
4085 if {$curview != $view} {
4086 showview $view
4088 eval $cmd
4091 proc goback {} {
4092 global history historyindex
4094 if {$historyindex > 1} {
4095 incr historyindex -1
4096 godo [lindex $history [expr {$historyindex - 1}]]
4097 .tf.bar.rightbut conf -state normal
4099 if {$historyindex <= 1} {
4100 .tf.bar.leftbut conf -state disabled
4104 proc goforw {} {
4105 global history historyindex
4107 if {$historyindex < [llength $history]} {
4108 set cmd [lindex $history $historyindex]
4109 incr historyindex
4110 godo $cmd
4111 .tf.bar.leftbut conf -state normal
4113 if {$historyindex >= [llength $history]} {
4114 .tf.bar.rightbut conf -state disabled
4118 proc gettree {id} {
4119 global treefilelist treeidlist diffids diffmergeid treepending
4121 set diffids $id
4122 catch {unset diffmergeid}
4123 if {![info exists treefilelist($id)]} {
4124 if {![info exists treepending]} {
4125 if {[catch {set gtf [open [concat | git ls-tree -r $id] r]}]} {
4126 return
4128 set treepending $id
4129 set treefilelist($id) {}
4130 set treeidlist($id) {}
4131 fconfigure $gtf -blocking 0
4132 fileevent $gtf readable [list gettreeline $gtf $id]
4134 } else {
4135 setfilelist $id
4139 proc gettreeline {gtf id} {
4140 global treefilelist treeidlist treepending cmitmode diffids
4142 while {[gets $gtf line] >= 0} {
4143 if {[lindex $line 1] ne "blob"} continue
4144 set sha1 [lindex $line 2]
4145 set fname [lindex $line 3]
4146 lappend treefilelist($id) $fname
4147 lappend treeidlist($id) $sha1
4149 if {![eof $gtf]} return
4150 close $gtf
4151 unset treepending
4152 if {$cmitmode ne "tree"} {
4153 if {![info exists diffmergeid]} {
4154 gettreediffs $diffids
4156 } elseif {$id ne $diffids} {
4157 gettree $diffids
4158 } else {
4159 setfilelist $id
4163 proc showfile {f} {
4164 global treefilelist treeidlist diffids
4165 global ctext commentend
4167 set i [lsearch -exact $treefilelist($diffids) $f]
4168 if {$i < 0} {
4169 puts "oops, $f not in list for id $diffids"
4170 return
4172 set blob [lindex $treeidlist($diffids) $i]
4173 if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4174 puts "oops, error reading blob $blob: $err"
4175 return
4177 fconfigure $bf -blocking 0
4178 fileevent $bf readable [list getblobline $bf $diffids]
4179 $ctext config -state normal
4180 clear_ctext $commentend
4181 $ctext insert end "\n"
4182 $ctext insert end "$f\n" filesep
4183 $ctext config -state disabled
4184 $ctext yview $commentend
4187 proc getblobline {bf id} {
4188 global diffids cmitmode ctext
4190 if {$id ne $diffids || $cmitmode ne "tree"} {
4191 catch {close $bf}
4192 return
4194 $ctext config -state normal
4195 while {[gets $bf line] >= 0} {
4196 $ctext insert end "$line\n"
4198 if {[eof $bf]} {
4199 # delete last newline
4200 $ctext delete "end - 2c" "end - 1c"
4201 close $bf
4203 $ctext config -state disabled
4206 proc mergediff {id l} {
4207 global diffmergeid diffopts mdifffd
4208 global diffids
4209 global parentlist
4211 set diffmergeid $id
4212 set diffids $id
4213 # this doesn't seem to actually affect anything...
4214 set env(GIT_DIFF_OPTS) $diffopts
4215 set cmd [concat | git diff-tree --no-commit-id --cc $id]
4216 if {[catch {set mdf [open $cmd r]} err]} {
4217 error_popup "Error getting merge diffs: $err"
4218 return
4220 fconfigure $mdf -blocking 0
4221 set mdifffd($id) $mdf
4222 set np [llength [lindex $parentlist $l]]
4223 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4224 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4227 proc getmergediffline {mdf id np} {
4228 global diffmergeid ctext cflist nextupdate mergemax
4229 global difffilestart mdifffd
4231 set n [gets $mdf line]
4232 if {$n < 0} {
4233 if {[eof $mdf]} {
4234 close $mdf
4236 return
4238 if {![info exists diffmergeid] || $id != $diffmergeid
4239 || $mdf != $mdifffd($id)} {
4240 return
4242 $ctext conf -state normal
4243 if {[regexp {^diff --cc (.*)} $line match fname]} {
4244 # start of a new file
4245 $ctext insert end "\n"
4246 set here [$ctext index "end - 1c"]
4247 lappend difffilestart $here
4248 add_flist [list $fname]
4249 set l [expr {(78 - [string length $fname]) / 2}]
4250 set pad [string range "----------------------------------------" 1 $l]
4251 $ctext insert end "$pad $fname $pad\n" filesep
4252 } elseif {[regexp {^@@} $line]} {
4253 $ctext insert end "$line\n" hunksep
4254 } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
4255 # do nothing
4256 } else {
4257 # parse the prefix - one ' ', '-' or '+' for each parent
4258 set spaces {}
4259 set minuses {}
4260 set pluses {}
4261 set isbad 0
4262 for {set j 0} {$j < $np} {incr j} {
4263 set c [string range $line $j $j]
4264 if {$c == " "} {
4265 lappend spaces $j
4266 } elseif {$c == "-"} {
4267 lappend minuses $j
4268 } elseif {$c == "+"} {
4269 lappend pluses $j
4270 } else {
4271 set isbad 1
4272 break
4275 set tags {}
4276 set num {}
4277 if {!$isbad && $minuses ne {} && $pluses eq {}} {
4278 # line doesn't appear in result, parents in $minuses have the line
4279 set num [lindex $minuses 0]
4280 } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
4281 # line appears in result, parents in $pluses don't have the line
4282 lappend tags mresult
4283 set num [lindex $spaces 0]
4285 if {$num ne {}} {
4286 if {$num >= $mergemax} {
4287 set num "max"
4289 lappend tags m$num
4291 $ctext insert end "$line\n" $tags
4293 $ctext conf -state disabled
4294 if {[clock clicks -milliseconds] >= $nextupdate} {
4295 incr nextupdate 100
4296 fileevent $mdf readable {}
4297 update
4298 fileevent $mdf readable [list getmergediffline $mdf $id $np]
4302 proc startdiff {ids} {
4303 global treediffs diffids treepending diffmergeid
4305 set diffids $ids
4306 catch {unset diffmergeid}
4307 if {![info exists treediffs($ids)]} {
4308 if {![info exists treepending]} {
4309 gettreediffs $ids
4311 } else {
4312 addtocflist $ids
4316 proc addtocflist {ids} {
4317 global treediffs cflist
4318 add_flist $treediffs($ids)
4319 getblobdiffs $ids
4322 proc gettreediffs {ids} {
4323 global treediff treepending
4324 set treepending $ids
4325 set treediff {}
4326 if {[catch \
4327 {set gdtf [open [concat | git diff-tree --no-commit-id -r $ids] r]} \
4328 ]} return
4329 fconfigure $gdtf -blocking 0
4330 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
4333 proc gettreediffline {gdtf ids} {
4334 global treediff treediffs treepending diffids diffmergeid
4335 global cmitmode
4337 set n [gets $gdtf line]
4338 if {$n < 0} {
4339 if {![eof $gdtf]} return
4340 close $gdtf
4341 set treediffs($ids) $treediff
4342 unset treepending
4343 if {$cmitmode eq "tree"} {
4344 gettree $diffids
4345 } elseif {$ids != $diffids} {
4346 if {![info exists diffmergeid]} {
4347 gettreediffs $diffids
4349 } else {
4350 addtocflist $ids
4352 return
4354 set file [lindex $line 5]
4355 lappend treediff $file
4358 proc getblobdiffs {ids} {
4359 global diffopts blobdifffd diffids env curdifftag curtagstart
4360 global nextupdate diffinhdr treediffs
4362 set env(GIT_DIFF_OPTS) $diffopts
4363 set cmd [concat | git diff-tree --no-commit-id -r -p -C $ids]
4364 if {[catch {set bdf [open $cmd r]} err]} {
4365 puts "error getting diffs: $err"
4366 return
4368 set diffinhdr 0
4369 fconfigure $bdf -blocking 0
4370 set blobdifffd($ids) $bdf
4371 set curdifftag Comments
4372 set curtagstart 0.0
4373 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
4374 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
4377 proc setinlist {var i val} {
4378 global $var
4380 while {[llength [set $var]] < $i} {
4381 lappend $var {}
4383 if {[llength [set $var]] == $i} {
4384 lappend $var $val
4385 } else {
4386 lset $var $i $val
4390 proc getblobdiffline {bdf ids} {
4391 global diffids blobdifffd ctext curdifftag curtagstart
4392 global diffnexthead diffnextnote difffilestart
4393 global nextupdate diffinhdr treediffs
4395 set n [gets $bdf line]
4396 if {$n < 0} {
4397 if {[eof $bdf]} {
4398 close $bdf
4399 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
4400 $ctext tag add $curdifftag $curtagstart end
4403 return
4405 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
4406 return
4408 $ctext conf -state normal
4409 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
4410 # start of a new file
4411 $ctext insert end "\n"
4412 $ctext tag add $curdifftag $curtagstart end
4413 set here [$ctext index "end - 1c"]
4414 set curtagstart $here
4415 set header $newname
4416 set i [lsearch -exact $treediffs($ids) $fname]
4417 if {$i >= 0} {
4418 setinlist difffilestart $i $here
4420 if {$newname ne $fname} {
4421 set i [lsearch -exact $treediffs($ids) $newname]
4422 if {$i >= 0} {
4423 setinlist difffilestart $i $here
4426 set curdifftag "f:$fname"
4427 $ctext tag delete $curdifftag
4428 set l [expr {(78 - [string length $header]) / 2}]
4429 set pad [string range "----------------------------------------" 1 $l]
4430 $ctext insert end "$pad $header $pad\n" filesep
4431 set diffinhdr 1
4432 } elseif {$diffinhdr && [string compare -length 3 $line "---"] == 0} {
4433 # do nothing
4434 } elseif {$diffinhdr && [string compare -length 3 $line "+++"] == 0} {
4435 set diffinhdr 0
4436 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
4437 $line match f1l f1c f2l f2c rest]} {
4438 $ctext insert end "$line\n" hunksep
4439 set diffinhdr 0
4440 } else {
4441 set x [string range $line 0 0]
4442 if {$x == "-" || $x == "+"} {
4443 set tag [expr {$x == "+"}]
4444 $ctext insert end "$line\n" d$tag
4445 } elseif {$x == " "} {
4446 $ctext insert end "$line\n"
4447 } elseif {$diffinhdr || $x == "\\"} {
4448 # e.g. "\ No newline at end of file"
4449 $ctext insert end "$line\n" filesep
4450 } else {
4451 # Something else we don't recognize
4452 if {$curdifftag != "Comments"} {
4453 $ctext insert end "\n"
4454 $ctext tag add $curdifftag $curtagstart end
4455 set curtagstart [$ctext index "end - 1c"]
4456 set curdifftag Comments
4458 $ctext insert end "$line\n" filesep
4461 $ctext conf -state disabled
4462 if {[clock clicks -milliseconds] >= $nextupdate} {
4463 incr nextupdate 100
4464 fileevent $bdf readable {}
4465 update
4466 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
4470 proc prevfile {} {
4471 global difffilestart ctext
4472 set prev [lindex $difffilestart 0]
4473 set here [$ctext index @0,0]
4474 foreach loc $difffilestart {
4475 if {[$ctext compare $loc >= $here]} {
4476 $ctext yview $prev
4477 return
4479 set prev $loc
4481 $ctext yview $prev
4484 proc nextfile {} {
4485 global difffilestart ctext
4486 set here [$ctext index @0,0]
4487 foreach loc $difffilestart {
4488 if {[$ctext compare $loc > $here]} {
4489 $ctext yview $loc
4490 return
4495 proc clear_ctext {{first 1.0}} {
4496 global ctext smarktop smarkbot
4498 set l [lindex [split $first .] 0]
4499 if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
4500 set smarktop $l
4502 if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
4503 set smarkbot $l
4505 $ctext delete $first end
4508 proc incrsearch {name ix op} {
4509 global ctext searchstring searchdirn
4511 $ctext tag remove found 1.0 end
4512 if {[catch {$ctext index anchor}]} {
4513 # no anchor set, use start of selection, or of visible area
4514 set sel [$ctext tag ranges sel]
4515 if {$sel ne {}} {
4516 $ctext mark set anchor [lindex $sel 0]
4517 } elseif {$searchdirn eq "-forwards"} {
4518 $ctext mark set anchor @0,0
4519 } else {
4520 $ctext mark set anchor @0,[winfo height $ctext]
4523 if {$searchstring ne {}} {
4524 set here [$ctext search $searchdirn -- $searchstring anchor]
4525 if {$here ne {}} {
4526 $ctext see $here
4528 searchmarkvisible 1
4532 proc dosearch {} {
4533 global sstring ctext searchstring searchdirn
4535 focus $sstring
4536 $sstring icursor end
4537 set searchdirn -forwards
4538 if {$searchstring ne {}} {
4539 set sel [$ctext tag ranges sel]
4540 if {$sel ne {}} {
4541 set start "[lindex $sel 0] + 1c"
4542 } elseif {[catch {set start [$ctext index anchor]}]} {
4543 set start "@0,0"
4545 set match [$ctext search -count mlen -- $searchstring $start]
4546 $ctext tag remove sel 1.0 end
4547 if {$match eq {}} {
4548 bell
4549 return
4551 $ctext see $match
4552 set mend "$match + $mlen c"
4553 $ctext tag add sel $match $mend
4554 $ctext mark unset anchor
4558 proc dosearchback {} {
4559 global sstring ctext searchstring searchdirn
4561 focus $sstring
4562 $sstring icursor end
4563 set searchdirn -backwards
4564 if {$searchstring ne {}} {
4565 set sel [$ctext tag ranges sel]
4566 if {$sel ne {}} {
4567 set start [lindex $sel 0]
4568 } elseif {[catch {set start [$ctext index anchor]}]} {
4569 set start @0,[winfo height $ctext]
4571 set match [$ctext search -backwards -count ml -- $searchstring $start]
4572 $ctext tag remove sel 1.0 end
4573 if {$match eq {}} {
4574 bell
4575 return
4577 $ctext see $match
4578 set mend "$match + $ml c"
4579 $ctext tag add sel $match $mend
4580 $ctext mark unset anchor
4584 proc searchmark {first last} {
4585 global ctext searchstring
4587 set mend $first.0
4588 while {1} {
4589 set match [$ctext search -count mlen -- $searchstring $mend $last.end]
4590 if {$match eq {}} break
4591 set mend "$match + $mlen c"
4592 $ctext tag add found $match $mend
4596 proc searchmarkvisible {doall} {
4597 global ctext smarktop smarkbot
4599 set topline [lindex [split [$ctext index @0,0] .] 0]
4600 set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
4601 if {$doall || $botline < $smarktop || $topline > $smarkbot} {
4602 # no overlap with previous
4603 searchmark $topline $botline
4604 set smarktop $topline
4605 set smarkbot $botline
4606 } else {
4607 if {$topline < $smarktop} {
4608 searchmark $topline [expr {$smarktop-1}]
4609 set smarktop $topline
4611 if {$botline > $smarkbot} {
4612 searchmark [expr {$smarkbot+1}] $botline
4613 set smarkbot $botline
4618 proc scrolltext {f0 f1} {
4619 global searchstring
4621 .bleft.sb set $f0 $f1
4622 if {$searchstring ne {}} {
4623 searchmarkvisible 0
4627 proc setcoords {} {
4628 global linespc charspc canvx0 canvy0 mainfont
4629 global xspc1 xspc2 lthickness
4631 set linespc [font metrics $mainfont -linespace]
4632 set charspc [font measure $mainfont "m"]
4633 set canvy0 [expr {int(3 + 0.5 * $linespc)}]
4634 set canvx0 [expr {int(3 + 0.5 * $linespc)}]
4635 set lthickness [expr {int($linespc / 9) + 1}]
4636 set xspc1(0) $linespc
4637 set xspc2 $linespc
4640 proc redisplay {} {
4641 global canv
4642 global selectedline
4644 set ymax [lindex [$canv cget -scrollregion] 3]
4645 if {$ymax eq {} || $ymax == 0} return
4646 set span [$canv yview]
4647 clear_display
4648 setcanvscroll
4649 allcanvs yview moveto [lindex $span 0]
4650 drawvisible
4651 if {[info exists selectedline]} {
4652 selectline $selectedline 0
4653 allcanvs yview moveto [lindex $span 0]
4657 proc incrfont {inc} {
4658 global mainfont textfont ctext canv phase
4659 global stopped entries
4660 unmarkmatches
4661 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
4662 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
4663 setcoords
4664 $ctext conf -font $textfont
4665 $ctext tag conf filesep -font [concat $textfont bold]
4666 foreach e $entries {
4667 $e conf -font $mainfont
4669 if {$phase eq "getcommits"} {
4670 $canv itemconf textitems -font $mainfont
4672 redisplay
4675 proc clearsha1 {} {
4676 global sha1entry sha1string
4677 if {[string length $sha1string] == 40} {
4678 $sha1entry delete 0 end
4682 proc sha1change {n1 n2 op} {
4683 global sha1string currentid sha1but
4684 if {$sha1string == {}
4685 || ([info exists currentid] && $sha1string == $currentid)} {
4686 set state disabled
4687 } else {
4688 set state normal
4690 if {[$sha1but cget -state] == $state} return
4691 if {$state == "normal"} {
4692 $sha1but conf -state normal -relief raised -text "Goto: "
4693 } else {
4694 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
4698 proc gotocommit {} {
4699 global sha1string currentid commitrow tagids headids
4700 global displayorder numcommits curview
4702 if {$sha1string == {}
4703 || ([info exists currentid] && $sha1string == $currentid)} return
4704 if {[info exists tagids($sha1string)]} {
4705 set id $tagids($sha1string)
4706 } elseif {[info exists headids($sha1string)]} {
4707 set id $headids($sha1string)
4708 } else {
4709 set id [string tolower $sha1string]
4710 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
4711 set matches {}
4712 foreach i $displayorder {
4713 if {[string match $id* $i]} {
4714 lappend matches $i
4717 if {$matches ne {}} {
4718 if {[llength $matches] > 1} {
4719 error_popup "Short SHA1 id $id is ambiguous"
4720 return
4722 set id [lindex $matches 0]
4726 if {[info exists commitrow($curview,$id)]} {
4727 selectline $commitrow($curview,$id) 1
4728 return
4730 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
4731 set type "SHA1 id"
4732 } else {
4733 set type "Tag/Head"
4735 error_popup "$type $sha1string is not known"
4738 proc lineenter {x y id} {
4739 global hoverx hovery hoverid hovertimer
4740 global commitinfo canv
4742 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4743 set hoverx $x
4744 set hovery $y
4745 set hoverid $id
4746 if {[info exists hovertimer]} {
4747 after cancel $hovertimer
4749 set hovertimer [after 500 linehover]
4750 $canv delete hover
4753 proc linemotion {x y id} {
4754 global hoverx hovery hoverid hovertimer
4756 if {[info exists hoverid] && $id == $hoverid} {
4757 set hoverx $x
4758 set hovery $y
4759 if {[info exists hovertimer]} {
4760 after cancel $hovertimer
4762 set hovertimer [after 500 linehover]
4766 proc lineleave {id} {
4767 global hoverid hovertimer canv
4769 if {[info exists hoverid] && $id == $hoverid} {
4770 $canv delete hover
4771 if {[info exists hovertimer]} {
4772 after cancel $hovertimer
4773 unset hovertimer
4775 unset hoverid
4779 proc linehover {} {
4780 global hoverx hovery hoverid hovertimer
4781 global canv linespc lthickness
4782 global commitinfo mainfont
4784 set text [lindex $commitinfo($hoverid) 0]
4785 set ymax [lindex [$canv cget -scrollregion] 3]
4786 if {$ymax == {}} return
4787 set yfrac [lindex [$canv yview] 0]
4788 set x [expr {$hoverx + 2 * $linespc}]
4789 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
4790 set x0 [expr {$x - 2 * $lthickness}]
4791 set y0 [expr {$y - 2 * $lthickness}]
4792 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
4793 set y1 [expr {$y + $linespc + 2 * $lthickness}]
4794 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
4795 -fill \#ffff80 -outline black -width 1 -tags hover]
4796 $canv raise $t
4797 set t [$canv create text $x $y -anchor nw -text $text -tags hover \
4798 -font $mainfont]
4799 $canv raise $t
4802 proc clickisonarrow {id y} {
4803 global lthickness
4805 set ranges [rowranges $id]
4806 set thresh [expr {2 * $lthickness + 6}]
4807 set n [expr {[llength $ranges] - 1}]
4808 for {set i 1} {$i < $n} {incr i} {
4809 set row [lindex $ranges $i]
4810 if {abs([yc $row] - $y) < $thresh} {
4811 return $i
4814 return {}
4817 proc arrowjump {id n y} {
4818 global canv
4820 # 1 <-> 2, 3 <-> 4, etc...
4821 set n [expr {(($n - 1) ^ 1) + 1}]
4822 set row [lindex [rowranges $id] $n]
4823 set yt [yc $row]
4824 set ymax [lindex [$canv cget -scrollregion] 3]
4825 if {$ymax eq {} || $ymax <= 0} return
4826 set view [$canv yview]
4827 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
4828 set yfrac [expr {$yt / $ymax - $yspan / 2}]
4829 if {$yfrac < 0} {
4830 set yfrac 0
4832 allcanvs yview moveto $yfrac
4835 proc lineclick {x y id isnew} {
4836 global ctext commitinfo children canv thickerline curview
4838 if {![info exists commitinfo($id)] && ![getcommit $id]} return
4839 unmarkmatches
4840 unselectline
4841 normalline
4842 $canv delete hover
4843 # draw this line thicker than normal
4844 set thickerline $id
4845 drawlines $id
4846 if {$isnew} {
4847 set ymax [lindex [$canv cget -scrollregion] 3]
4848 if {$ymax eq {}} return
4849 set yfrac [lindex [$canv yview] 0]
4850 set y [expr {$y + $yfrac * $ymax}]
4852 set dirn [clickisonarrow $id $y]
4853 if {$dirn ne {}} {
4854 arrowjump $id $dirn $y
4855 return
4858 if {$isnew} {
4859 addtohistory [list lineclick $x $y $id 0]
4861 # fill the details pane with info about this line
4862 $ctext conf -state normal
4863 clear_ctext
4864 $ctext tag conf link -foreground blue -underline 1
4865 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4866 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4867 $ctext insert end "Parent:\t"
4868 $ctext insert end $id [list link link0]
4869 $ctext tag bind link0 <1> [list selbyid $id]
4870 set info $commitinfo($id)
4871 $ctext insert end "\n\t[lindex $info 0]\n"
4872 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
4873 set date [formatdate [lindex $info 2]]
4874 $ctext insert end "\tDate:\t$date\n"
4875 set kids $children($curview,$id)
4876 if {$kids ne {}} {
4877 $ctext insert end "\nChildren:"
4878 set i 0
4879 foreach child $kids {
4880 incr i
4881 if {![info exists commitinfo($child)] && ![getcommit $child]} continue
4882 set info $commitinfo($child)
4883 $ctext insert end "\n\t"
4884 $ctext insert end $child [list link link$i]
4885 $ctext tag bind link$i <1> [list selbyid $child]
4886 $ctext insert end "\n\t[lindex $info 0]"
4887 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
4888 set date [formatdate [lindex $info 2]]
4889 $ctext insert end "\n\tDate:\t$date\n"
4892 $ctext conf -state disabled
4893 init_flist {}
4896 proc normalline {} {
4897 global thickerline
4898 if {[info exists thickerline]} {
4899 set id $thickerline
4900 unset thickerline
4901 drawlines $id
4905 proc selbyid {id} {
4906 global commitrow curview
4907 if {[info exists commitrow($curview,$id)]} {
4908 selectline $commitrow($curview,$id) 1
4912 proc mstime {} {
4913 global startmstime
4914 if {![info exists startmstime]} {
4915 set startmstime [clock clicks -milliseconds]
4917 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
4920 proc rowmenu {x y id} {
4921 global rowctxmenu commitrow selectedline rowmenuid curview
4923 if {![info exists selectedline]
4924 || $commitrow($curview,$id) eq $selectedline} {
4925 set state disabled
4926 } else {
4927 set state normal
4929 $rowctxmenu entryconfigure "Diff this*" -state $state
4930 $rowctxmenu entryconfigure "Diff selected*" -state $state
4931 $rowctxmenu entryconfigure "Make patch" -state $state
4932 set rowmenuid $id
4933 tk_popup $rowctxmenu $x $y
4936 proc diffvssel {dirn} {
4937 global rowmenuid selectedline displayorder
4939 if {![info exists selectedline]} return
4940 if {$dirn} {
4941 set oldid [lindex $displayorder $selectedline]
4942 set newid $rowmenuid
4943 } else {
4944 set oldid $rowmenuid
4945 set newid [lindex $displayorder $selectedline]
4947 addtohistory [list doseldiff $oldid $newid]
4948 doseldiff $oldid $newid
4951 proc doseldiff {oldid newid} {
4952 global ctext
4953 global commitinfo
4955 $ctext conf -state normal
4956 clear_ctext
4957 init_flist "Top"
4958 $ctext insert end "From "
4959 $ctext tag conf link -foreground blue -underline 1
4960 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
4961 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
4962 $ctext tag bind link0 <1> [list selbyid $oldid]
4963 $ctext insert end $oldid [list link link0]
4964 $ctext insert end "\n "
4965 $ctext insert end [lindex $commitinfo($oldid) 0]
4966 $ctext insert end "\n\nTo "
4967 $ctext tag bind link1 <1> [list selbyid $newid]
4968 $ctext insert end $newid [list link link1]
4969 $ctext insert end "\n "
4970 $ctext insert end [lindex $commitinfo($newid) 0]
4971 $ctext insert end "\n"
4972 $ctext conf -state disabled
4973 $ctext tag delete Comments
4974 $ctext tag remove found 1.0 end
4975 startdiff [list $oldid $newid]
4978 proc mkpatch {} {
4979 global rowmenuid currentid commitinfo patchtop patchnum
4981 if {![info exists currentid]} return
4982 set oldid $currentid
4983 set oldhead [lindex $commitinfo($oldid) 0]
4984 set newid $rowmenuid
4985 set newhead [lindex $commitinfo($newid) 0]
4986 set top .patch
4987 set patchtop $top
4988 catch {destroy $top}
4989 toplevel $top
4990 label $top.title -text "Generate patch"
4991 grid $top.title - -pady 10
4992 label $top.from -text "From:"
4993 entry $top.fromsha1 -width 40 -relief flat
4994 $top.fromsha1 insert 0 $oldid
4995 $top.fromsha1 conf -state readonly
4996 grid $top.from $top.fromsha1 -sticky w
4997 entry $top.fromhead -width 60 -relief flat
4998 $top.fromhead insert 0 $oldhead
4999 $top.fromhead conf -state readonly
5000 grid x $top.fromhead -sticky w
5001 label $top.to -text "To:"
5002 entry $top.tosha1 -width 40 -relief flat
5003 $top.tosha1 insert 0 $newid
5004 $top.tosha1 conf -state readonly
5005 grid $top.to $top.tosha1 -sticky w
5006 entry $top.tohead -width 60 -relief flat
5007 $top.tohead insert 0 $newhead
5008 $top.tohead conf -state readonly
5009 grid x $top.tohead -sticky w
5010 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
5011 grid $top.rev x -pady 10
5012 label $top.flab -text "Output file:"
5013 entry $top.fname -width 60
5014 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
5015 incr patchnum
5016 grid $top.flab $top.fname -sticky w
5017 frame $top.buts
5018 button $top.buts.gen -text "Generate" -command mkpatchgo
5019 button $top.buts.can -text "Cancel" -command mkpatchcan
5020 grid $top.buts.gen $top.buts.can
5021 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5022 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5023 grid $top.buts - -pady 10 -sticky ew
5024 focus $top.fname
5027 proc mkpatchrev {} {
5028 global patchtop
5030 set oldid [$patchtop.fromsha1 get]
5031 set oldhead [$patchtop.fromhead get]
5032 set newid [$patchtop.tosha1 get]
5033 set newhead [$patchtop.tohead get]
5034 foreach e [list fromsha1 fromhead tosha1 tohead] \
5035 v [list $newid $newhead $oldid $oldhead] {
5036 $patchtop.$e conf -state normal
5037 $patchtop.$e delete 0 end
5038 $patchtop.$e insert 0 $v
5039 $patchtop.$e conf -state readonly
5043 proc mkpatchgo {} {
5044 global patchtop
5046 set oldid [$patchtop.fromsha1 get]
5047 set newid [$patchtop.tosha1 get]
5048 set fname [$patchtop.fname get]
5049 if {[catch {exec git diff-tree -p $oldid $newid >$fname &} err]} {
5050 error_popup "Error creating patch: $err"
5052 catch {destroy $patchtop}
5053 unset patchtop
5056 proc mkpatchcan {} {
5057 global patchtop
5059 catch {destroy $patchtop}
5060 unset patchtop
5063 proc mktag {} {
5064 global rowmenuid mktagtop commitinfo
5066 set top .maketag
5067 set mktagtop $top
5068 catch {destroy $top}
5069 toplevel $top
5070 label $top.title -text "Create tag"
5071 grid $top.title - -pady 10
5072 label $top.id -text "ID:"
5073 entry $top.sha1 -width 40 -relief flat
5074 $top.sha1 insert 0 $rowmenuid
5075 $top.sha1 conf -state readonly
5076 grid $top.id $top.sha1 -sticky w
5077 entry $top.head -width 60 -relief flat
5078 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5079 $top.head conf -state readonly
5080 grid x $top.head -sticky w
5081 label $top.tlab -text "Tag name:"
5082 entry $top.tag -width 60
5083 grid $top.tlab $top.tag -sticky w
5084 frame $top.buts
5085 button $top.buts.gen -text "Create" -command mktaggo
5086 button $top.buts.can -text "Cancel" -command mktagcan
5087 grid $top.buts.gen $top.buts.can
5088 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5089 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5090 grid $top.buts - -pady 10 -sticky ew
5091 focus $top.tag
5094 proc domktag {} {
5095 global mktagtop env tagids idtags
5097 set id [$mktagtop.sha1 get]
5098 set tag [$mktagtop.tag get]
5099 if {$tag == {}} {
5100 error_popup "No tag name specified"
5101 return
5103 if {[info exists tagids($tag)]} {
5104 error_popup "Tag \"$tag\" already exists"
5105 return
5107 if {[catch {
5108 set dir [gitdir]
5109 set fname [file join $dir "refs/tags" $tag]
5110 set f [open $fname w]
5111 puts $f $id
5112 close $f
5113 } err]} {
5114 error_popup "Error creating tag: $err"
5115 return
5118 set tagids($tag) $id
5119 lappend idtags($id) $tag
5120 redrawtags $id
5121 addedtag $id
5124 proc redrawtags {id} {
5125 global canv linehtag commitrow idpos selectedline curview
5126 global mainfont canvxmax
5128 if {![info exists commitrow($curview,$id)]} return
5129 drawcmitrow $commitrow($curview,$id)
5130 $canv delete tag.$id
5131 set xt [eval drawtags $id $idpos($id)]
5132 $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
5133 set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
5134 set xr [expr {$xt + [font measure $mainfont $text]}]
5135 if {$xr > $canvxmax} {
5136 set canvxmax $xr
5137 setcanvscroll
5139 if {[info exists selectedline]
5140 && $selectedline == $commitrow($curview,$id)} {
5141 selectline $selectedline 0
5145 proc mktagcan {} {
5146 global mktagtop
5148 catch {destroy $mktagtop}
5149 unset mktagtop
5152 proc mktaggo {} {
5153 domktag
5154 mktagcan
5157 proc writecommit {} {
5158 global rowmenuid wrcomtop commitinfo wrcomcmd
5160 set top .writecommit
5161 set wrcomtop $top
5162 catch {destroy $top}
5163 toplevel $top
5164 label $top.title -text "Write commit to file"
5165 grid $top.title - -pady 10
5166 label $top.id -text "ID:"
5167 entry $top.sha1 -width 40 -relief flat
5168 $top.sha1 insert 0 $rowmenuid
5169 $top.sha1 conf -state readonly
5170 grid $top.id $top.sha1 -sticky w
5171 entry $top.head -width 60 -relief flat
5172 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
5173 $top.head conf -state readonly
5174 grid x $top.head -sticky w
5175 label $top.clab -text "Command:"
5176 entry $top.cmd -width 60 -textvariable wrcomcmd
5177 grid $top.clab $top.cmd -sticky w -pady 10
5178 label $top.flab -text "Output file:"
5179 entry $top.fname -width 60
5180 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
5181 grid $top.flab $top.fname -sticky w
5182 frame $top.buts
5183 button $top.buts.gen -text "Write" -command wrcomgo
5184 button $top.buts.can -text "Cancel" -command wrcomcan
5185 grid $top.buts.gen $top.buts.can
5186 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5187 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5188 grid $top.buts - -pady 10 -sticky ew
5189 focus $top.fname
5192 proc wrcomgo {} {
5193 global wrcomtop
5195 set id [$wrcomtop.sha1 get]
5196 set cmd "echo $id | [$wrcomtop.cmd get]"
5197 set fname [$wrcomtop.fname get]
5198 if {[catch {exec sh -c $cmd >$fname &} err]} {
5199 error_popup "Error writing commit: $err"
5201 catch {destroy $wrcomtop}
5202 unset wrcomtop
5205 proc wrcomcan {} {
5206 global wrcomtop
5208 catch {destroy $wrcomtop}
5209 unset wrcomtop
5212 proc mkbranch {} {
5213 global rowmenuid mkbrtop
5215 set top .makebranch
5216 catch {destroy $top}
5217 toplevel $top
5218 label $top.title -text "Create new branch"
5219 grid $top.title - -pady 10
5220 label $top.id -text "ID:"
5221 entry $top.sha1 -width 40 -relief flat
5222 $top.sha1 insert 0 $rowmenuid
5223 $top.sha1 conf -state readonly
5224 grid $top.id $top.sha1 -sticky w
5225 label $top.nlab -text "Name:"
5226 entry $top.name -width 40
5227 grid $top.nlab $top.name -sticky w
5228 frame $top.buts
5229 button $top.buts.go -text "Create" -command [list mkbrgo $top]
5230 button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
5231 grid $top.buts.go $top.buts.can
5232 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5233 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5234 grid $top.buts - -pady 10 -sticky ew
5235 focus $top.name
5238 proc mkbrgo {top} {
5239 global headids idheads
5241 set name [$top.name get]
5242 set id [$top.sha1 get]
5243 if {$name eq {}} {
5244 error_popup "Please specify a name for the new branch"
5245 return
5247 catch {destroy $top}
5248 nowbusy newbranch
5249 update
5250 if {[catch {
5251 exec git branch $name $id
5252 } err]} {
5253 notbusy newbranch
5254 error_popup $err
5255 } else {
5256 addedhead $id $name
5257 # XXX should update list of heads displayed for selected commit
5258 notbusy newbranch
5259 redrawtags $id
5263 proc cherrypick {} {
5264 global rowmenuid curview commitrow
5265 global mainhead desc_heads anc_tags desc_tags allparents allchildren
5267 if {[info exists desc_heads($rowmenuid)]
5268 && [lsearch -exact $desc_heads($rowmenuid) $mainhead] >= 0} {
5269 set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
5270 included in branch $mainhead -- really re-apply it?"]
5271 if {!$ok} return
5273 nowbusy cherrypick
5274 update
5275 set oldhead [exec git rev-parse HEAD]
5276 # Unfortunately git-cherry-pick writes stuff to stderr even when
5277 # no error occurs, and exec takes that as an indication of error...
5278 if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
5279 notbusy cherrypick
5280 error_popup $err
5281 return
5283 set newhead [exec git rev-parse HEAD]
5284 if {$newhead eq $oldhead} {
5285 notbusy cherrypick
5286 error_popup "No changes committed"
5287 return
5289 set allparents($newhead) $oldhead
5290 lappend allchildren($oldhead) $newhead
5291 set desc_heads($newhead) $mainhead
5292 if {[info exists anc_tags($oldhead)]} {
5293 set anc_tags($newhead) $anc_tags($oldhead)
5295 set desc_tags($newhead) {}
5296 if {[info exists commitrow($curview,$oldhead)]} {
5297 insertrow $commitrow($curview,$oldhead) $newhead
5298 if {$mainhead ne {}} {
5299 movedhead $newhead $mainhead
5301 redrawtags $oldhead
5302 redrawtags $newhead
5304 notbusy cherrypick
5307 # context menu for a head
5308 proc headmenu {x y id head} {
5309 global headmenuid headmenuhead headctxmenu
5311 set headmenuid $id
5312 set headmenuhead $head
5313 tk_popup $headctxmenu $x $y
5316 proc cobranch {} {
5317 global headmenuid headmenuhead mainhead headids
5319 # check the tree is clean first??
5320 set oldmainhead $mainhead
5321 nowbusy checkout
5322 update
5323 if {[catch {
5324 exec git checkout $headmenuhead
5325 } err]} {
5326 notbusy checkout
5327 error_popup $err
5328 } else {
5329 notbusy checkout
5330 set mainhead $headmenuhead
5331 if {[info exists headids($oldmainhead)]} {
5332 redrawtags $headids($oldmainhead)
5334 redrawtags $headmenuid
5338 proc rmbranch {} {
5339 global desc_heads headmenuid headmenuhead mainhead
5340 global headids idheads
5342 set head $headmenuhead
5343 set id $headmenuid
5344 if {$head eq $mainhead} {
5345 error_popup "Cannot delete the currently checked-out branch"
5346 return
5348 if {$desc_heads($id) eq $head} {
5349 # the stuff on this branch isn't on any other branch
5350 if {![confirm_popup "The commits on branch $head aren't on any other\
5351 branch.\nReally delete branch $head?"]} return
5353 nowbusy rmbranch
5354 update
5355 if {[catch {exec git branch -D $head} err]} {
5356 notbusy rmbranch
5357 error_popup $err
5358 return
5360 removedhead $id $head
5361 redrawtags $id
5362 notbusy rmbranch
5365 # Stuff for finding nearby tags
5366 proc getallcommits {} {
5367 global allcstart allcommits allcfd allids
5369 set allids {}
5370 set fd [open [concat | git rev-list --all --topo-order --parents] r]
5371 set allcfd $fd
5372 fconfigure $fd -blocking 0
5373 set allcommits "reading"
5374 nowbusy allcommits
5375 restartgetall $fd
5378 proc discardallcommits {} {
5379 global allparents allchildren allcommits allcfd
5380 global desc_tags anc_tags alldtags tagisdesc allids desc_heads
5382 if {![info exists allcommits]} return
5383 if {$allcommits eq "reading"} {
5384 catch {close $allcfd}
5386 foreach v {allcommits allchildren allparents allids desc_tags anc_tags
5387 alldtags tagisdesc desc_heads} {
5388 catch {unset $v}
5392 proc restartgetall {fd} {
5393 global allcstart
5395 fileevent $fd readable [list getallclines $fd]
5396 set allcstart [clock clicks -milliseconds]
5399 proc combine_dtags {l1 l2} {
5400 global tagisdesc notfirstd
5402 set res [lsort -unique [concat $l1 $l2]]
5403 for {set i 0} {$i < [llength $res]} {incr i} {
5404 set x [lindex $res $i]
5405 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5406 set y [lindex $res $j]
5407 if {[info exists tagisdesc($x,$y)]} {
5408 if {$tagisdesc($x,$y) > 0} {
5409 # x is a descendent of y, exclude x
5410 set res [lreplace $res $i $i]
5411 incr i -1
5412 break
5413 } else {
5414 # y is a descendent of x, exclude y
5415 set res [lreplace $res $j $j]
5417 } else {
5418 # no relation, keep going
5419 incr j
5423 return $res
5426 proc combine_atags {l1 l2} {
5427 global tagisdesc
5429 set res [lsort -unique [concat $l1 $l2]]
5430 for {set i 0} {$i < [llength $res]} {incr i} {
5431 set x [lindex $res $i]
5432 for {set j [expr {$i+1}]} {$j < [llength $res]} {} {
5433 set y [lindex $res $j]
5434 if {[info exists tagisdesc($x,$y)]} {
5435 if {$tagisdesc($x,$y) < 0} {
5436 # x is an ancestor of y, exclude x
5437 set res [lreplace $res $i $i]
5438 incr i -1
5439 break
5440 } else {
5441 # y is an ancestor of x, exclude y
5442 set res [lreplace $res $j $j]
5444 } else {
5445 # no relation, keep going
5446 incr j
5450 return $res
5453 proc forward_pass {id children} {
5454 global idtags desc_tags idheads desc_heads alldtags tagisdesc
5456 set dtags {}
5457 set dheads {}
5458 foreach child $children {
5459 if {[info exists idtags($child)]} {
5460 set ctags [list $child]
5461 } else {
5462 set ctags $desc_tags($child)
5464 if {$dtags eq {}} {
5465 set dtags $ctags
5466 } elseif {$ctags ne $dtags} {
5467 set dtags [combine_dtags $dtags $ctags]
5469 set cheads $desc_heads($child)
5470 if {$dheads eq {}} {
5471 set dheads $cheads
5472 } elseif {$cheads ne $dheads} {
5473 set dheads [lsort -unique [concat $dheads $cheads]]
5476 set desc_tags($id) $dtags
5477 if {[info exists idtags($id)]} {
5478 set adt $dtags
5479 foreach tag $dtags {
5480 set adt [concat $adt $alldtags($tag)]
5482 set adt [lsort -unique $adt]
5483 set alldtags($id) $adt
5484 foreach tag $adt {
5485 set tagisdesc($id,$tag) -1
5486 set tagisdesc($tag,$id) 1
5489 if {[info exists idheads($id)]} {
5490 set dheads [concat $dheads $idheads($id)]
5492 set desc_heads($id) $dheads
5495 proc getallclines {fd} {
5496 global allparents allchildren allcommits allcstart
5497 global desc_tags anc_tags idtags tagisdesc allids
5498 global idheads travindex
5500 while {[gets $fd line] >= 0} {
5501 set id [lindex $line 0]
5502 lappend allids $id
5503 set olds [lrange $line 1 end]
5504 set allparents($id) $olds
5505 if {![info exists allchildren($id)]} {
5506 set allchildren($id) {}
5508 foreach p $olds {
5509 lappend allchildren($p) $id
5511 # compute nearest tagged descendents as we go
5512 # also compute descendent heads
5513 forward_pass $id $allchildren($id)
5514 if {[clock clicks -milliseconds] - $allcstart >= 50} {
5515 fileevent $fd readable {}
5516 after idle restartgetall $fd
5517 return
5520 if {[eof $fd]} {
5521 set travindex [llength $allids]
5522 set allcommits "traversing"
5523 after idle restartatags
5524 if {[catch {close $fd} err]} {
5525 error_popup "Error reading full commit graph: $err.\n\
5526 Results may be incomplete."
5531 # walk backward through the tree and compute nearest tagged ancestors
5532 proc restartatags {} {
5533 global allids allparents idtags anc_tags travindex
5535 set t0 [clock clicks -milliseconds]
5536 set i $travindex
5537 while {[incr i -1] >= 0} {
5538 set id [lindex $allids $i]
5539 set atags {}
5540 foreach p $allparents($id) {
5541 if {[info exists idtags($p)]} {
5542 set ptags [list $p]
5543 } else {
5544 set ptags $anc_tags($p)
5546 if {$atags eq {}} {
5547 set atags $ptags
5548 } elseif {$ptags ne $atags} {
5549 set atags [combine_atags $atags $ptags]
5552 set anc_tags($id) $atags
5553 if {[clock clicks -milliseconds] - $t0 >= 50} {
5554 set travindex $i
5555 after idle restartatags
5556 return
5559 set allcommits "done"
5560 set travindex 0
5561 notbusy allcommits
5562 dispneartags
5565 # update the desc_tags and anc_tags arrays for a new tag just added
5566 proc addedtag {id} {
5567 global desc_tags anc_tags allparents allchildren allcommits
5568 global idtags tagisdesc alldtags
5570 if {![info exists desc_tags($id)]} return
5571 set adt $desc_tags($id)
5572 foreach t $desc_tags($id) {
5573 set adt [concat $adt $alldtags($t)]
5575 set adt [lsort -unique $adt]
5576 set alldtags($id) $adt
5577 foreach t $adt {
5578 set tagisdesc($id,$t) -1
5579 set tagisdesc($t,$id) 1
5581 if {[info exists anc_tags($id)]} {
5582 set todo $anc_tags($id)
5583 while {$todo ne {}} {
5584 set do [lindex $todo 0]
5585 set todo [lrange $todo 1 end]
5586 if {[info exists tagisdesc($id,$do)]} continue
5587 set tagisdesc($do,$id) -1
5588 set tagisdesc($id,$do) 1
5589 if {[info exists anc_tags($do)]} {
5590 set todo [concat $todo $anc_tags($do)]
5595 set lastold $desc_tags($id)
5596 set lastnew [list $id]
5597 set nup 0
5598 set nch 0
5599 set todo $allparents($id)
5600 while {$todo ne {}} {
5601 set do [lindex $todo 0]
5602 set todo [lrange $todo 1 end]
5603 if {![info exists desc_tags($do)]} continue
5604 if {$desc_tags($do) ne $lastold} {
5605 set lastold $desc_tags($do)
5606 set lastnew [combine_dtags $lastold [list $id]]
5607 incr nch
5609 if {$lastold eq $lastnew} continue
5610 set desc_tags($do) $lastnew
5611 incr nup
5612 if {![info exists idtags($do)]} {
5613 set todo [concat $todo $allparents($do)]
5617 if {![info exists anc_tags($id)]} return
5618 set lastold $anc_tags($id)
5619 set lastnew [list $id]
5620 set nup 0
5621 set nch 0
5622 set todo $allchildren($id)
5623 while {$todo ne {}} {
5624 set do [lindex $todo 0]
5625 set todo [lrange $todo 1 end]
5626 if {![info exists anc_tags($do)]} continue
5627 if {$anc_tags($do) ne $lastold} {
5628 set lastold $anc_tags($do)
5629 set lastnew [combine_atags $lastold [list $id]]
5630 incr nch
5632 if {$lastold eq $lastnew} continue
5633 set anc_tags($do) $lastnew
5634 incr nup
5635 if {![info exists idtags($do)]} {
5636 set todo [concat $todo $allchildren($do)]
5641 # update the desc_heads array for a new head just added
5642 proc addedhead {hid head} {
5643 global desc_heads allparents headids idheads
5645 set headids($head) $hid
5646 lappend idheads($hid) $head
5648 set todo [list $hid]
5649 while {$todo ne {}} {
5650 set do [lindex $todo 0]
5651 set todo [lrange $todo 1 end]
5652 if {![info exists desc_heads($do)] ||
5653 [lsearch -exact $desc_heads($do) $head] >= 0} continue
5654 set oldheads $desc_heads($do)
5655 lappend desc_heads($do) $head
5656 set heads $desc_heads($do)
5657 while {1} {
5658 set p $allparents($do)
5659 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5660 $desc_heads($p) ne $oldheads} break
5661 set do $p
5662 set desc_heads($do) $heads
5664 set todo [concat $todo $p]
5668 # update the desc_heads array for a head just removed
5669 proc removedhead {hid head} {
5670 global desc_heads allparents headids idheads
5672 unset headids($head)
5673 if {$idheads($hid) eq $head} {
5674 unset idheads($hid)
5675 } else {
5676 set i [lsearch -exact $idheads($hid) $head]
5677 if {$i >= 0} {
5678 set idheads($hid) [lreplace $idheads($hid) $i $i]
5682 set todo [list $hid]
5683 while {$todo ne {}} {
5684 set do [lindex $todo 0]
5685 set todo [lrange $todo 1 end]
5686 if {![info exists desc_heads($do)]} continue
5687 set i [lsearch -exact $desc_heads($do) $head]
5688 if {$i < 0} continue
5689 set oldheads $desc_heads($do)
5690 set heads [lreplace $desc_heads($do) $i $i]
5691 while {1} {
5692 set desc_heads($do) $heads
5693 set p $allparents($do)
5694 if {[llength $p] != 1 || ![info exists desc_heads($p)] ||
5695 $desc_heads($p) ne $oldheads} break
5696 set do $p
5698 set todo [concat $todo $p]
5702 # update things for a head moved to a child of its previous location
5703 proc movedhead {id name} {
5704 global headids idheads
5706 set oldid $headids($name)
5707 set headids($name) $id
5708 if {$idheads($oldid) eq $name} {
5709 unset idheads($oldid)
5710 } else {
5711 set i [lsearch -exact $idheads($oldid) $name]
5712 if {$i >= 0} {
5713 set idheads($oldid) [lreplace $idheads($oldid) $i $i]
5716 lappend idheads($id) $name
5719 proc changedrefs {} {
5720 global desc_heads desc_tags anc_tags allcommits allids
5721 global allchildren allparents idtags travindex
5723 if {![info exists allcommits]} return
5724 catch {unset desc_heads}
5725 catch {unset desc_tags}
5726 catch {unset anc_tags}
5727 catch {unset alldtags}
5728 catch {unset tagisdesc}
5729 foreach id $allids {
5730 forward_pass $id $allchildren($id)
5732 if {$allcommits ne "reading"} {
5733 set travindex [llength $allids]
5734 if {$allcommits ne "traversing"} {
5735 set allcommits "traversing"
5736 after idle restartatags
5741 proc rereadrefs {} {
5742 global idtags idheads idotherrefs mainhead
5744 set refids [concat [array names idtags] \
5745 [array names idheads] [array names idotherrefs]]
5746 foreach id $refids {
5747 if {![info exists ref($id)]} {
5748 set ref($id) [listrefs $id]
5751 set oldmainhead $mainhead
5752 readrefs
5753 changedrefs
5754 set refids [lsort -unique [concat $refids [array names idtags] \
5755 [array names idheads] [array names idotherrefs]]]
5756 foreach id $refids {
5757 set v [listrefs $id]
5758 if {![info exists ref($id)] || $ref($id) != $v ||
5759 ($id eq $oldmainhead && $id ne $mainhead) ||
5760 ($id eq $mainhead && $id ne $oldmainhead)} {
5761 redrawtags $id
5766 proc listrefs {id} {
5767 global idtags idheads idotherrefs
5769 set x {}
5770 if {[info exists idtags($id)]} {
5771 set x $idtags($id)
5773 set y {}
5774 if {[info exists idheads($id)]} {
5775 set y $idheads($id)
5777 set z {}
5778 if {[info exists idotherrefs($id)]} {
5779 set z $idotherrefs($id)
5781 return [list $x $y $z]
5784 proc showtag {tag isnew} {
5785 global ctext tagcontents tagids linknum
5787 if {$isnew} {
5788 addtohistory [list showtag $tag 0]
5790 $ctext conf -state normal
5791 clear_ctext
5792 set linknum 0
5793 if {[info exists tagcontents($tag)]} {
5794 set text $tagcontents($tag)
5795 } else {
5796 set text "Tag: $tag\nId: $tagids($tag)"
5798 appendwithlinks $text {}
5799 $ctext conf -state disabled
5800 init_flist {}
5803 proc doquit {} {
5804 global stopped
5805 set stopped 100
5806 savestuff .
5807 destroy .
5810 proc doprefs {} {
5811 global maxwidth maxgraphpct diffopts
5812 global oldprefs prefstop showneartags
5813 global bgcolor fgcolor ctext diffcolors
5815 set top .gitkprefs
5816 set prefstop $top
5817 if {[winfo exists $top]} {
5818 raise $top
5819 return
5821 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5822 set oldprefs($v) [set $v]
5824 toplevel $top
5825 wm title $top "Gitk preferences"
5826 label $top.ldisp -text "Commit list display options"
5827 grid $top.ldisp - -sticky w -pady 10
5828 label $top.spacer -text " "
5829 label $top.maxwidthl -text "Maximum graph width (lines)" \
5830 -font optionfont
5831 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
5832 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
5833 label $top.maxpctl -text "Maximum graph width (% of pane)" \
5834 -font optionfont
5835 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
5836 grid x $top.maxpctl $top.maxpct -sticky w
5838 label $top.ddisp -text "Diff display options"
5839 grid $top.ddisp - -sticky w -pady 10
5840 label $top.diffoptl -text "Options for diff program" \
5841 -font optionfont
5842 entry $top.diffopt -width 20 -textvariable diffopts
5843 grid x $top.diffoptl $top.diffopt -sticky w
5844 frame $top.ntag
5845 label $top.ntag.l -text "Display nearby tags" -font optionfont
5846 checkbutton $top.ntag.b -variable showneartags
5847 pack $top.ntag.b $top.ntag.l -side left
5848 grid x $top.ntag -sticky w
5850 label $top.cdisp -text "Colors: press to choose"
5851 grid $top.cdisp - -sticky w -pady 10
5852 label $top.bg -padx 40 -relief sunk -background $bgcolor
5853 button $top.bgbut -text "Background" -font optionfont \
5854 -command [list choosecolor bgcolor 0 $top.bg background setbg]
5855 grid x $top.bgbut $top.bg -sticky w
5856 label $top.fg -padx 40 -relief sunk -background $fgcolor
5857 button $top.fgbut -text "Foreground" -font optionfont \
5858 -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
5859 grid x $top.fgbut $top.fg -sticky w
5860 label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
5861 button $top.diffoldbut -text "Diff: old lines" -font optionfont \
5862 -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
5863 [list $ctext tag conf d0 -foreground]]
5864 grid x $top.diffoldbut $top.diffold -sticky w
5865 label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
5866 button $top.diffnewbut -text "Diff: new lines" -font optionfont \
5867 -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
5868 [list $ctext tag conf d1 -foreground]]
5869 grid x $top.diffnewbut $top.diffnew -sticky w
5870 label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
5871 button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
5872 -command [list choosecolor diffcolors 2 $top.hunksep \
5873 "diff hunk header" \
5874 [list $ctext tag conf hunksep -foreground]]
5875 grid x $top.hunksepbut $top.hunksep -sticky w
5877 frame $top.buts
5878 button $top.buts.ok -text "OK" -command prefsok
5879 button $top.buts.can -text "Cancel" -command prefscan
5880 grid $top.buts.ok $top.buts.can
5881 grid columnconfigure $top.buts 0 -weight 1 -uniform a
5882 grid columnconfigure $top.buts 1 -weight 1 -uniform a
5883 grid $top.buts - - -pady 10 -sticky ew
5886 proc choosecolor {v vi w x cmd} {
5887 global $v
5889 set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
5890 -title "Gitk: choose color for $x"]
5891 if {$c eq {}} return
5892 $w conf -background $c
5893 lset $v $vi $c
5894 eval $cmd $c
5897 proc setbg {c} {
5898 global bglist
5900 foreach w $bglist {
5901 $w conf -background $c
5905 proc setfg {c} {
5906 global fglist canv
5908 foreach w $fglist {
5909 $w conf -foreground $c
5911 allcanvs itemconf text -fill $c
5912 $canv itemconf circle -outline $c
5915 proc prefscan {} {
5916 global maxwidth maxgraphpct diffopts
5917 global oldprefs prefstop showneartags
5919 foreach v {maxwidth maxgraphpct diffopts showneartags} {
5920 set $v $oldprefs($v)
5922 catch {destroy $prefstop}
5923 unset prefstop
5926 proc prefsok {} {
5927 global maxwidth maxgraphpct
5928 global oldprefs prefstop showneartags
5930 catch {destroy $prefstop}
5931 unset prefstop
5932 if {$maxwidth != $oldprefs(maxwidth)
5933 || $maxgraphpct != $oldprefs(maxgraphpct)} {
5934 redisplay
5935 } elseif {$showneartags != $oldprefs(showneartags)} {
5936 reselectline
5940 proc formatdate {d} {
5941 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
5944 # This list of encoding names and aliases is distilled from
5945 # http://www.iana.org/assignments/character-sets.
5946 # Not all of them are supported by Tcl.
5947 set encoding_aliases {
5948 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
5949 ISO646-US US-ASCII us IBM367 cp367 csASCII }
5950 { ISO-10646-UTF-1 csISO10646UTF1 }
5951 { ISO_646.basic:1983 ref csISO646basic1983 }
5952 { INVARIANT csINVARIANT }
5953 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
5954 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
5955 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
5956 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
5957 { NATS-DANO iso-ir-9-1 csNATSDANO }
5958 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
5959 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
5960 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
5961 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
5962 { ISO-2022-KR csISO2022KR }
5963 { EUC-KR csEUCKR }
5964 { ISO-2022-JP csISO2022JP }
5965 { ISO-2022-JP-2 csISO2022JP2 }
5966 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
5967 csISO13JISC6220jp }
5968 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
5969 { IT iso-ir-15 ISO646-IT csISO15Italian }
5970 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
5971 { ES iso-ir-17 ISO646-ES csISO17Spanish }
5972 { greek7-old iso-ir-18 csISO18Greek7Old }
5973 { latin-greek iso-ir-19 csISO19LatinGreek }
5974 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
5975 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
5976 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
5977 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
5978 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
5979 { BS_viewdata iso-ir-47 csISO47BSViewdata }
5980 { INIS iso-ir-49 csISO49INIS }
5981 { INIS-8 iso-ir-50 csISO50INIS8 }
5982 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
5983 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
5984 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
5985 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
5986 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
5987 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
5988 csISO60Norwegian1 }
5989 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
5990 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
5991 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
5992 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
5993 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
5994 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
5995 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
5996 { greek7 iso-ir-88 csISO88Greek7 }
5997 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
5998 { iso-ir-90 csISO90 }
5999 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
6000 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
6001 csISO92JISC62991984b }
6002 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
6003 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
6004 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
6005 csISO95JIS62291984handadd }
6006 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
6007 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
6008 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
6009 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
6010 CP819 csISOLatin1 }
6011 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
6012 { T.61-7bit iso-ir-102 csISO102T617bit }
6013 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
6014 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
6015 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
6016 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
6017 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
6018 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
6019 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
6020 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
6021 arabic csISOLatinArabic }
6022 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
6023 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
6024 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
6025 greek greek8 csISOLatinGreek }
6026 { T.101-G2 iso-ir-128 csISO128T101G2 }
6027 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
6028 csISOLatinHebrew }
6029 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
6030 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
6031 { CSN_369103 iso-ir-139 csISO139CSN369103 }
6032 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
6033 { ISO_6937-2-add iso-ir-142 csISOTextComm }
6034 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
6035 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
6036 csISOLatinCyrillic }
6037 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
6038 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
6039 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
6040 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
6041 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
6042 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
6043 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
6044 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
6045 { ISO_10367-box iso-ir-155 csISO10367Box }
6046 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
6047 { latin-lap lap iso-ir-158 csISO158Lap }
6048 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
6049 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
6050 { us-dk csUSDK }
6051 { dk-us csDKUS }
6052 { JIS_X0201 X0201 csHalfWidthKatakana }
6053 { KSC5636 ISO646-KR csKSC5636 }
6054 { ISO-10646-UCS-2 csUnicode }
6055 { ISO-10646-UCS-4 csUCS4 }
6056 { DEC-MCS dec csDECMCS }
6057 { hp-roman8 roman8 r8 csHPRoman8 }
6058 { macintosh mac csMacintosh }
6059 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
6060 csIBM037 }
6061 { IBM038 EBCDIC-INT cp038 csIBM038 }
6062 { IBM273 CP273 csIBM273 }
6063 { IBM274 EBCDIC-BE CP274 csIBM274 }
6064 { IBM275 EBCDIC-BR cp275 csIBM275 }
6065 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
6066 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
6067 { IBM280 CP280 ebcdic-cp-it csIBM280 }
6068 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
6069 { IBM284 CP284 ebcdic-cp-es csIBM284 }
6070 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
6071 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
6072 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
6073 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
6074 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
6075 { IBM424 cp424 ebcdic-cp-he csIBM424 }
6076 { IBM437 cp437 437 csPC8CodePage437 }
6077 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
6078 { IBM775 cp775 csPC775Baltic }
6079 { IBM850 cp850 850 csPC850Multilingual }
6080 { IBM851 cp851 851 csIBM851 }
6081 { IBM852 cp852 852 csPCp852 }
6082 { IBM855 cp855 855 csIBM855 }
6083 { IBM857 cp857 857 csIBM857 }
6084 { IBM860 cp860 860 csIBM860 }
6085 { IBM861 cp861 861 cp-is csIBM861 }
6086 { IBM862 cp862 862 csPC862LatinHebrew }
6087 { IBM863 cp863 863 csIBM863 }
6088 { IBM864 cp864 csIBM864 }
6089 { IBM865 cp865 865 csIBM865 }
6090 { IBM866 cp866 866 csIBM866 }
6091 { IBM868 CP868 cp-ar csIBM868 }
6092 { IBM869 cp869 869 cp-gr csIBM869 }
6093 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
6094 { IBM871 CP871 ebcdic-cp-is csIBM871 }
6095 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
6096 { IBM891 cp891 csIBM891 }
6097 { IBM903 cp903 csIBM903 }
6098 { IBM904 cp904 904 csIBBM904 }
6099 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
6100 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
6101 { IBM1026 CP1026 csIBM1026 }
6102 { EBCDIC-AT-DE csIBMEBCDICATDE }
6103 { EBCDIC-AT-DE-A csEBCDICATDEA }
6104 { EBCDIC-CA-FR csEBCDICCAFR }
6105 { EBCDIC-DK-NO csEBCDICDKNO }
6106 { EBCDIC-DK-NO-A csEBCDICDKNOA }
6107 { EBCDIC-FI-SE csEBCDICFISE }
6108 { EBCDIC-FI-SE-A csEBCDICFISEA }
6109 { EBCDIC-FR csEBCDICFR }
6110 { EBCDIC-IT csEBCDICIT }
6111 { EBCDIC-PT csEBCDICPT }
6112 { EBCDIC-ES csEBCDICES }
6113 { EBCDIC-ES-A csEBCDICESA }
6114 { EBCDIC-ES-S csEBCDICESS }
6115 { EBCDIC-UK csEBCDICUK }
6116 { EBCDIC-US csEBCDICUS }
6117 { UNKNOWN-8BIT csUnknown8BiT }
6118 { MNEMONIC csMnemonic }
6119 { MNEM csMnem }
6120 { VISCII csVISCII }
6121 { VIQR csVIQR }
6122 { KOI8-R csKOI8R }
6123 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
6124 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
6125 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
6126 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
6127 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
6128 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
6129 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
6130 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
6131 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
6132 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
6133 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
6134 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
6135 { IBM1047 IBM-1047 }
6136 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
6137 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
6138 { UNICODE-1-1 csUnicode11 }
6139 { CESU-8 csCESU-8 }
6140 { BOCU-1 csBOCU-1 }
6141 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
6142 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
6143 l8 }
6144 { ISO-8859-15 ISO_8859-15 Latin-9 }
6145 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
6146 { GBK CP936 MS936 windows-936 }
6147 { JIS_Encoding csJISEncoding }
6148 { Shift_JIS MS_Kanji csShiftJIS }
6149 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
6150 EUC-JP }
6151 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
6152 { ISO-10646-UCS-Basic csUnicodeASCII }
6153 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
6154 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
6155 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
6156 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
6157 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
6158 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
6159 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
6160 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
6161 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
6162 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
6163 { Adobe-Standard-Encoding csAdobeStandardEncoding }
6164 { Ventura-US csVenturaUS }
6165 { Ventura-International csVenturaInternational }
6166 { PC8-Danish-Norwegian csPC8DanishNorwegian }
6167 { PC8-Turkish csPC8Turkish }
6168 { IBM-Symbols csIBMSymbols }
6169 { IBM-Thai csIBMThai }
6170 { HP-Legal csHPLegal }
6171 { HP-Pi-font csHPPiFont }
6172 { HP-Math8 csHPMath8 }
6173 { Adobe-Symbol-Encoding csHPPSMath }
6174 { HP-DeskTop csHPDesktop }
6175 { Ventura-Math csVenturaMath }
6176 { Microsoft-Publishing csMicrosoftPublishing }
6177 { Windows-31J csWindows31J }
6178 { GB2312 csGB2312 }
6179 { Big5 csBig5 }
6182 proc tcl_encoding {enc} {
6183 global encoding_aliases
6184 set names [encoding names]
6185 set lcnames [string tolower $names]
6186 set enc [string tolower $enc]
6187 set i [lsearch -exact $lcnames $enc]
6188 if {$i < 0} {
6189 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
6190 if {[regsub {^iso[-_]} $enc iso encx]} {
6191 set i [lsearch -exact $lcnames $encx]
6194 if {$i < 0} {
6195 foreach l $encoding_aliases {
6196 set ll [string tolower $l]
6197 if {[lsearch -exact $ll $enc] < 0} continue
6198 # look through the aliases for one that tcl knows about
6199 foreach e $ll {
6200 set i [lsearch -exact $lcnames $e]
6201 if {$i < 0} {
6202 if {[regsub {^iso[-_]} $e iso ex]} {
6203 set i [lsearch -exact $lcnames $ex]
6206 if {$i >= 0} break
6208 break
6211 if {$i >= 0} {
6212 return [lindex $names $i]
6214 return {}
6217 # defaults...
6218 set datemode 0
6219 set diffopts "-U 5 -p"
6220 set wrcomcmd "git diff-tree --stdin -p --pretty"
6222 set gitencoding {}
6223 catch {
6224 set gitencoding [exec git config --get i18n.commitencoding]
6226 if {$gitencoding == ""} {
6227 set gitencoding "utf-8"
6229 set tclencoding [tcl_encoding $gitencoding]
6230 if {$tclencoding == {}} {
6231 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
6234 set mainfont {Helvetica 9}
6235 set textfont {Courier 9}
6236 set uifont {Helvetica 9 bold}
6237 set findmergefiles 0
6238 set maxgraphpct 50
6239 set maxwidth 16
6240 set revlistorder 0
6241 set fastdate 0
6242 set uparrowlen 7
6243 set downarrowlen 7
6244 set mingaplen 30
6245 set cmitmode "patch"
6246 set wrapcomment "none"
6247 set showneartags 1
6249 set colors {green red blue magenta darkgrey brown orange}
6250 set bgcolor white
6251 set fgcolor black
6252 set diffcolors {red "#00a000" blue}
6254 catch {source ~/.gitk}
6256 font create optionfont -family sans-serif -size -12
6258 set revtreeargs {}
6259 foreach arg $argv {
6260 switch -regexp -- $arg {
6261 "^$" { }
6262 "^-d" { set datemode 1 }
6263 default {
6264 lappend revtreeargs $arg
6269 # check that we can find a .git directory somewhere...
6270 set gitdir [gitdir]
6271 if {![file isdirectory $gitdir]} {
6272 show_error {} . "Cannot find the git directory \"$gitdir\"."
6273 exit 1
6276 set cmdline_files {}
6277 set i [lsearch -exact $revtreeargs "--"]
6278 if {$i >= 0} {
6279 set cmdline_files [lrange $revtreeargs [expr {$i + 1}] end]
6280 set revtreeargs [lrange $revtreeargs 0 [expr {$i - 1}]]
6281 } elseif {$revtreeargs ne {}} {
6282 if {[catch {
6283 set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
6284 set cmdline_files [split $f "\n"]
6285 set n [llength $cmdline_files]
6286 set revtreeargs [lrange $revtreeargs 0 end-$n]
6287 } err]} {
6288 # unfortunately we get both stdout and stderr in $err,
6289 # so look for "fatal:".
6290 set i [string first "fatal:" $err]
6291 if {$i > 0} {
6292 set err [string range $err [expr {$i + 6}] end]
6294 show_error {} . "Bad arguments to gitk:\n$err"
6295 exit 1
6299 set history {}
6300 set historyindex 0
6301 set fh_serial 0
6302 set nhl_names {}
6303 set highlight_paths {}
6304 set searchdirn -forwards
6305 set boldrows {}
6306 set boldnamerows {}
6308 set optim_delay 16
6310 set nextviewnum 1
6311 set curview 0
6312 set selectedview 0
6313 set selectedhlview None
6314 set viewfiles(0) {}
6315 set viewperm(0) 0
6316 set viewargs(0) {}
6318 set cmdlineok 0
6319 set stopped 0
6320 set stuffsaved 0
6321 set patchnum 0
6322 setcoords
6323 makewindow
6324 wm title . "[file tail $argv0]: [file tail [pwd]]"
6325 readrefs
6327 if {$cmdline_files ne {} || $revtreeargs ne {}} {
6328 # create a view for the files/dirs specified on the command line
6329 set curview 1
6330 set selectedview 1
6331 set nextviewnum 2
6332 set viewname(1) "Command line"
6333 set viewfiles(1) $cmdline_files
6334 set viewargs(1) $revtreeargs
6335 set viewperm(1) 0
6336 addviewmenu 1
6337 .bar.view entryconf Edit* -state normal
6338 .bar.view entryconf Delete* -state normal
6341 if {[info exists permviews]} {
6342 foreach v $permviews {
6343 set n $nextviewnum
6344 incr nextviewnum
6345 set viewname($n) [lindex $v 0]
6346 set viewfiles($n) [lindex $v 1]
6347 set viewargs($n) [lindex $v 2]
6348 set viewperm($n) 1
6349 addviewmenu $n
6352 getcommits