show-branch: usability updates.
[git/jnareb-git/bp-gitweb.git] / gitk
blobf12b3ce20928b0228a2b10696db5e16e96f64cc0
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005 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 ".git"
19 proc parse_args {rargs} {
20 global parsed_args
22 if [catch {
23 set parse_args [concat --default HEAD $rargs]
24 set parsed_args [split [eval exec git-rev-parse $parse_args] "\n"]
25 }] {
26 # if git-rev-parse failed for some reason...
27 if {$rargs == {}} {
28 set rargs HEAD
30 set parsed_args $rargs
32 return $parsed_args
35 proc start_rev_list {rlargs} {
36 global startmsecs nextupdate ncmupdate
37 global commfd leftover tclencoding
39 set startmsecs [clock clicks -milliseconds]
40 set nextupdate [expr {$startmsecs + 100}]
41 set ncmupdate 1
42 if [catch {
43 set commfd [open [concat | git-rev-list --header --topo-order \
44 --parents $rlargs] r]
45 } err] {
46 puts stderr "Error executing git-rev-list: $err"
47 exit 1
49 set leftover {}
50 fconfigure $commfd -blocking 0 -translation lf
51 if {$tclencoding != {}} {
52 fconfigure $commfd -encoding $tclencoding
54 fileevent $commfd readable [list getcommitlines $commfd]
55 . config -cursor watch
56 settextcursor watch
59 proc getcommits {rargs} {
60 global oldcommits commits phase canv mainfont env
62 # check that we can find a .git directory somewhere...
63 set gitdir [gitdir]
64 if {![file isdirectory $gitdir]} {
65 error_popup "Cannot find the git directory \"$gitdir\"."
66 exit 1
68 set oldcommits {}
69 set commits {}
70 set phase getcommits
71 start_rev_list [parse_args $rargs]
72 $canv delete all
73 $canv create text 3 3 -anchor nw -text "Reading commits..." \
74 -font $mainfont -tags textitems
77 proc getcommitlines {commfd} {
78 global oldcommits commits parents cdate children nchildren
79 global commitlisted phase nextupdate
80 global stopped redisplaying leftover
81 global canv
83 set stuff [read $commfd]
84 if {$stuff == {}} {
85 if {![eof $commfd]} return
86 # set it blocking so we wait for the process to terminate
87 fconfigure $commfd -blocking 1
88 if {![catch {close $commfd} err]} {
89 after idle finishcommits
90 return
92 if {[string range $err 0 4] == "usage"} {
93 set err \
94 "Gitk: error reading commits: bad arguments to git-rev-list.\
95 (Note: arguments to gitk are passed to git-rev-list\
96 to allow selection of commits to be displayed.)"
97 } else {
98 set err "Error reading commits: $err"
100 error_popup $err
101 exit 1
103 set start 0
104 while 1 {
105 set i [string first "\0" $stuff $start]
106 if {$i < 0} {
107 append leftover [string range $stuff $start end]
108 return
110 set cmit [string range $stuff $start [expr {$i - 1}]]
111 if {$start == 0} {
112 set cmit "$leftover$cmit"
113 set leftover {}
115 set start [expr {$i + 1}]
116 set j [string first "\n" $cmit]
117 set ok 0
118 if {$j >= 0} {
119 set ids [string range $cmit 0 [expr {$j - 1}]]
120 set ok 1
121 foreach id $ids {
122 if {![regexp {^[0-9a-f]{40}$} $id]} {
123 set ok 0
124 break
128 if {!$ok} {
129 set shortcmit $cmit
130 if {[string length $shortcmit] > 80} {
131 set shortcmit "[string range $shortcmit 0 80]..."
133 error_popup "Can't parse git-rev-list output: {$shortcmit}"
134 exit 1
136 set id [lindex $ids 0]
137 set olds [lrange $ids 1 end]
138 set cmit [string range $cmit [expr {$j + 1}] end]
139 lappend commits $id
140 set commitlisted($id) 1
141 parsecommit $id $cmit 1 [lrange $ids 1 end]
142 drawcommit $id 1
143 if {[clock clicks -milliseconds] >= $nextupdate} {
144 doupdate 1
146 while {$redisplaying} {
147 set redisplaying 0
148 if {$stopped == 1} {
149 set stopped 0
150 set phase "getcommits"
151 foreach id $commits {
152 drawcommit $id 1
153 if {$stopped} break
154 if {[clock clicks -milliseconds] >= $nextupdate} {
155 doupdate 1
163 proc doupdate {reading} {
164 global commfd nextupdate numcommits ncmupdate
166 if {$reading} {
167 fileevent $commfd readable {}
169 update
170 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
171 if {$numcommits < 100} {
172 set ncmupdate [expr {$numcommits + 1}]
173 } elseif {$numcommits < 10000} {
174 set ncmupdate [expr {$numcommits + 10}]
175 } else {
176 set ncmupdate [expr {$numcommits + 100}]
178 if {$reading} {
179 fileevent $commfd readable [list getcommitlines $commfd]
183 proc readcommit {id} {
184 if [catch {set contents [exec git-cat-file commit $id]}] return
185 parsecommit $id $contents 0 {}
188 proc updatecommits {rargs} {
189 global commitlisted commfd phase
190 global startmsecs nextupdate ncmupdate
191 global idtags idheads idotherrefs
192 global leftover
193 global parsed_args
194 global canv mainfont
195 global oldcommits commits
196 global parents nchildren children ncleft
198 set old_args $parsed_args
199 parse_args $rargs
201 if {$phase == "getcommits" || $phase == "incrdraw"} {
202 # havent read all the old commits, just start again from scratch
203 stopfindproc
204 set oldcommits {}
205 set commits {}
206 foreach v {children nchildren parents commitlisted commitinfo
207 selectedline matchinglines treediffs
208 mergefilelist currentid rowtextx} {
209 global $v
210 catch {unset $v}
212 readrefs
213 if {$phase == "incrdraw"} {
214 allcanvs delete all
215 $canv create text 3 3 -anchor nw -text "Reading commits..." \
216 -font $mainfont -tags textitems
217 set phase getcommits
219 start_rev_list $parsed_args
220 return
223 foreach id $old_args {
224 if {![regexp {^[0-9a-f]{40}$} $id]} continue
225 if {[info exists oldref($id)]} continue
226 set oldref($id) $id
227 lappend ignoreold "^$id"
229 foreach id $parsed_args {
230 if {![regexp {^[0-9a-f]{40}$} $id]} continue
231 if {[info exists ref($id)]} continue
232 set ref($id) $id
233 lappend ignorenew "^$id"
236 foreach a $old_args {
237 if {![info exists ref($a)]} {
238 lappend ignorenew $a
242 set phase updatecommits
243 set oldcommits $commits
244 set commits {}
245 set removed_commits [split [eval exec git-rev-list $ignorenew] "\n" ]
246 if {[llength $removed_commits] > 0} {
247 allcanvs delete all
248 foreach c $removed_commits {
249 set i [lsearch -exact $oldcommits $c]
250 if {$i >= 0} {
251 set oldcommits [lreplace $oldcommits $i $i]
252 unset commitlisted($c)
253 foreach p $parents($c) {
254 if {[info exists nchildren($p)]} {
255 set j [lsearch -exact $children($p) $c]
256 if {$j >= 0} {
257 set children($p) [lreplace $children($p) $j $j]
258 incr nchildren($p) -1
264 set phase removecommits
267 set args {}
268 foreach a $parsed_args {
269 if {![info exists oldref($a)]} {
270 lappend args $a
274 readrefs
275 start_rev_list [concat $ignoreold $args]
278 proc updatechildren {id olds} {
279 global children nchildren parents nparents ncleft
281 if {![info exists nchildren($id)]} {
282 set children($id) {}
283 set nchildren($id) 0
284 set ncleft($id) 0
286 set parents($id) $olds
287 set nparents($id) [llength $olds]
288 foreach p $olds {
289 if {![info exists nchildren($p)]} {
290 set children($p) [list $id]
291 set nchildren($p) 1
292 set ncleft($p) 1
293 } elseif {[lsearch -exact $children($p) $id] < 0} {
294 lappend children($p) $id
295 incr nchildren($p)
296 incr ncleft($p)
301 proc parsecommit {id contents listed olds} {
302 global commitinfo cdate
304 set inhdr 1
305 set comment {}
306 set headline {}
307 set auname {}
308 set audate {}
309 set comname {}
310 set comdate {}
311 updatechildren $id $olds
312 set hdrend [string first "\n\n" $contents]
313 if {$hdrend < 0} {
314 # should never happen...
315 set hdrend [string length $contents]
317 set header [string range $contents 0 [expr {$hdrend - 1}]]
318 set comment [string range $contents [expr {$hdrend + 2}] end]
319 foreach line [split $header "\n"] {
320 set tag [lindex $line 0]
321 if {$tag == "author"} {
322 set audate [lindex $line end-1]
323 set auname [lrange $line 1 end-2]
324 } elseif {$tag == "committer"} {
325 set comdate [lindex $line end-1]
326 set comname [lrange $line 1 end-2]
329 set headline {}
330 # take the first line of the comment as the headline
331 set i [string first "\n" $comment]
332 if {$i >= 0} {
333 set headline [string trim [string range $comment 0 $i]]
334 } else {
335 set headline $comment
337 if {!$listed} {
338 # git-rev-list indents the comment by 4 spaces;
339 # if we got this via git-cat-file, add the indentation
340 set newcomment {}
341 foreach line [split $comment "\n"] {
342 append newcomment " "
343 append newcomment $line
344 append newcomment "\n"
346 set comment $newcomment
348 if {$comdate != {}} {
349 set cdate($id) $comdate
351 set commitinfo($id) [list $headline $auname $audate \
352 $comname $comdate $comment]
355 proc readrefs {} {
356 global tagids idtags headids idheads tagcontents
357 global otherrefids idotherrefs
359 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
360 catch {unset $v}
362 set refd [open [list | git-ls-remote [gitdir]] r]
363 while {0 <= [set n [gets $refd line]]} {
364 if {![regexp {^([0-9a-f]{40}) refs/([^^]*)$} $line \
365 match id path]} {
366 continue
368 if {![regexp {^(tags|heads)/(.*)$} $path match type name]} {
369 set type others
370 set name $path
372 if {$type == "tags"} {
373 set tagids($name) $id
374 lappend idtags($id) $name
375 set obj {}
376 set type {}
377 set tag {}
378 catch {
379 set commit [exec git-rev-parse "$id^0"]
380 if {"$commit" != "$id"} {
381 set tagids($name) $commit
382 lappend idtags($commit) $name
385 catch {
386 set tagcontents($name) [exec git-cat-file tag "$id"]
388 } elseif { $type == "heads" } {
389 set headids($name) $id
390 lappend idheads($id) $name
391 } else {
392 set otherrefids($name) $id
393 lappend idotherrefs($id) $name
396 close $refd
399 proc error_popup msg {
400 set w .error
401 toplevel $w
402 wm transient $w .
403 message $w.m -text $msg -justify center -aspect 400
404 pack $w.m -side top -fill x -padx 20 -pady 20
405 button $w.ok -text OK -command "destroy $w"
406 pack $w.ok -side bottom -fill x
407 bind $w <Visibility> "grab $w; focus $w"
408 tkwait window $w
411 proc makewindow {rargs} {
412 global canv canv2 canv3 linespc charspc ctext cflist textfont
413 global findtype findtypemenu findloc findstring fstring geometry
414 global entries sha1entry sha1string sha1but
415 global maincursor textcursor curtextcursor
416 global rowctxmenu mergemax
418 menu .bar
419 .bar add cascade -label "File" -menu .bar.file
420 menu .bar.file
421 .bar.file add command -label "Update" -command [list updatecommits $rargs]
422 .bar.file add command -label "Reread references" -command rereadrefs
423 .bar.file add command -label "Quit" -command doquit
424 menu .bar.edit
425 .bar add cascade -label "Edit" -menu .bar.edit
426 .bar.edit add command -label "Preferences" -command doprefs
427 menu .bar.help
428 .bar add cascade -label "Help" -menu .bar.help
429 .bar.help add command -label "About gitk" -command about
430 . configure -menu .bar
432 if {![info exists geometry(canv1)]} {
433 set geometry(canv1) [expr {45 * $charspc}]
434 set geometry(canv2) [expr {30 * $charspc}]
435 set geometry(canv3) [expr {15 * $charspc}]
436 set geometry(canvh) [expr {25 * $linespc + 4}]
437 set geometry(ctextw) 80
438 set geometry(ctexth) 30
439 set geometry(cflistw) 30
441 panedwindow .ctop -orient vertical
442 if {[info exists geometry(width)]} {
443 .ctop conf -width $geometry(width) -height $geometry(height)
444 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
445 set geometry(ctexth) [expr {($texth - 8) /
446 [font metrics $textfont -linespace]}]
448 frame .ctop.top
449 frame .ctop.top.bar
450 pack .ctop.top.bar -side bottom -fill x
451 set cscroll .ctop.top.csb
452 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
453 pack $cscroll -side right -fill y
454 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
455 pack .ctop.top.clist -side top -fill both -expand 1
456 .ctop add .ctop.top
457 set canv .ctop.top.clist.canv
458 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
459 -bg white -bd 0 \
460 -yscrollincr $linespc -yscrollcommand "$cscroll set"
461 .ctop.top.clist add $canv
462 set canv2 .ctop.top.clist.canv2
463 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
464 -bg white -bd 0 -yscrollincr $linespc
465 .ctop.top.clist add $canv2
466 set canv3 .ctop.top.clist.canv3
467 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
468 -bg white -bd 0 -yscrollincr $linespc
469 .ctop.top.clist add $canv3
470 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
472 set sha1entry .ctop.top.bar.sha1
473 set entries $sha1entry
474 set sha1but .ctop.top.bar.sha1label
475 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
476 -command gotocommit -width 8
477 $sha1but conf -disabledforeground [$sha1but cget -foreground]
478 pack .ctop.top.bar.sha1label -side left
479 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
480 trace add variable sha1string write sha1change
481 pack $sha1entry -side left -pady 2
483 image create bitmap bm-left -data {
484 #define left_width 16
485 #define left_height 16
486 static unsigned char left_bits[] = {
487 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
488 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
489 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
491 image create bitmap bm-right -data {
492 #define right_width 16
493 #define right_height 16
494 static unsigned char right_bits[] = {
495 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
496 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
497 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
499 button .ctop.top.bar.leftbut -image bm-left -command goback \
500 -state disabled -width 26
501 pack .ctop.top.bar.leftbut -side left -fill y
502 button .ctop.top.bar.rightbut -image bm-right -command goforw \
503 -state disabled -width 26
504 pack .ctop.top.bar.rightbut -side left -fill y
506 button .ctop.top.bar.findbut -text "Find" -command dofind
507 pack .ctop.top.bar.findbut -side left
508 set findstring {}
509 set fstring .ctop.top.bar.findstring
510 lappend entries $fstring
511 entry $fstring -width 30 -font $textfont -textvariable findstring
512 pack $fstring -side left -expand 1 -fill x
513 set findtype Exact
514 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
515 findtype Exact IgnCase Regexp]
516 set findloc "All fields"
517 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
518 Comments Author Committer Files Pickaxe
519 pack .ctop.top.bar.findloc -side right
520 pack .ctop.top.bar.findtype -side right
521 # for making sure type==Exact whenever loc==Pickaxe
522 trace add variable findloc write findlocchange
524 panedwindow .ctop.cdet -orient horizontal
525 .ctop add .ctop.cdet
526 frame .ctop.cdet.left
527 set ctext .ctop.cdet.left.ctext
528 text $ctext -bg white -state disabled -font $textfont \
529 -width $geometry(ctextw) -height $geometry(ctexth) \
530 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
531 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
532 pack .ctop.cdet.left.sb -side right -fill y
533 pack $ctext -side left -fill both -expand 1
534 .ctop.cdet add .ctop.cdet.left
536 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
537 $ctext tag conf hunksep -fore blue
538 $ctext tag conf d0 -fore red
539 $ctext tag conf d1 -fore "#00a000"
540 $ctext tag conf m0 -fore red
541 $ctext tag conf m1 -fore blue
542 $ctext tag conf m2 -fore green
543 $ctext tag conf m3 -fore purple
544 $ctext tag conf m4 -fore brown
545 $ctext tag conf mmax -fore darkgrey
546 set mergemax 5
547 $ctext tag conf mresult -font [concat $textfont bold]
548 $ctext tag conf msep -font [concat $textfont bold]
549 $ctext tag conf found -back yellow
551 frame .ctop.cdet.right
552 set cflist .ctop.cdet.right.cfiles
553 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
554 -yscrollcommand ".ctop.cdet.right.sb set"
555 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
556 pack .ctop.cdet.right.sb -side right -fill y
557 pack $cflist -side left -fill both -expand 1
558 .ctop.cdet add .ctop.cdet.right
559 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
561 pack .ctop -side top -fill both -expand 1
563 bindall <1> {selcanvline %W %x %y}
564 #bindall <B1-Motion> {selcanvline %W %x %y}
565 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
566 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
567 bindall <2> "allcanvs scan mark 0 %y"
568 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
569 bind . <Key-Up> "selnextline -1"
570 bind . <Key-Down> "selnextline 1"
571 bind . <Key-Right> "goforw"
572 bind . <Key-Left> "goback"
573 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
574 bind . <Key-Next> "allcanvs yview scroll 1 pages"
575 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
576 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
577 bindkey <Key-space> "$ctext yview scroll 1 pages"
578 bindkey p "selnextline -1"
579 bindkey n "selnextline 1"
580 bindkey z "goback"
581 bindkey x "goforw"
582 bindkey i "selnextline -1"
583 bindkey k "selnextline 1"
584 bindkey j "goback"
585 bindkey l "goforw"
586 bindkey b "$ctext yview scroll -1 pages"
587 bindkey d "$ctext yview scroll 18 units"
588 bindkey u "$ctext yview scroll -18 units"
589 bindkey / {findnext 1}
590 bindkey <Key-Return> {findnext 0}
591 bindkey ? findprev
592 bindkey f nextfile
593 bind . <Control-q> doquit
594 bind . <Control-f> dofind
595 bind . <Control-g> {findnext 0}
596 bind . <Control-r> findprev
597 bind . <Control-equal> {incrfont 1}
598 bind . <Control-KP_Add> {incrfont 1}
599 bind . <Control-minus> {incrfont -1}
600 bind . <Control-KP_Subtract> {incrfont -1}
601 bind $cflist <<ListboxSelect>> listboxsel
602 bind . <Destroy> {savestuff %W}
603 bind . <Button-1> "click %W"
604 bind $fstring <Key-Return> dofind
605 bind $sha1entry <Key-Return> gotocommit
606 bind $sha1entry <<PasteSelection>> clearsha1
608 set maincursor [. cget -cursor]
609 set textcursor [$ctext cget -cursor]
610 set curtextcursor $textcursor
612 set rowctxmenu .rowctxmenu
613 menu $rowctxmenu -tearoff 0
614 $rowctxmenu add command -label "Diff this -> selected" \
615 -command {diffvssel 0}
616 $rowctxmenu add command -label "Diff selected -> this" \
617 -command {diffvssel 1}
618 $rowctxmenu add command -label "Make patch" -command mkpatch
619 $rowctxmenu add command -label "Create tag" -command mktag
620 $rowctxmenu add command -label "Write commit to file" -command writecommit
623 # when we make a key binding for the toplevel, make sure
624 # it doesn't get triggered when that key is pressed in the
625 # find string entry widget.
626 proc bindkey {ev script} {
627 global entries
628 bind . $ev $script
629 set escript [bind Entry $ev]
630 if {$escript == {}} {
631 set escript [bind Entry <Key>]
633 foreach e $entries {
634 bind $e $ev "$escript; break"
638 # set the focus back to the toplevel for any click outside
639 # the entry widgets
640 proc click {w} {
641 global entries
642 foreach e $entries {
643 if {$w == $e} return
645 focus .
648 proc savestuff {w} {
649 global canv canv2 canv3 ctext cflist mainfont textfont
650 global stuffsaved findmergefiles maxgraphpct
651 global maxwidth
653 if {$stuffsaved} return
654 if {![winfo viewable .]} return
655 catch {
656 set f [open "~/.gitk-new" w]
657 puts $f [list set mainfont $mainfont]
658 puts $f [list set textfont $textfont]
659 puts $f [list set findmergefiles $findmergefiles]
660 puts $f [list set maxgraphpct $maxgraphpct]
661 puts $f [list set maxwidth $maxwidth]
662 puts $f "set geometry(width) [winfo width .ctop]"
663 puts $f "set geometry(height) [winfo height .ctop]"
664 puts $f "set geometry(canv1) [expr {[winfo width $canv]-2}]"
665 puts $f "set geometry(canv2) [expr {[winfo width $canv2]-2}]"
666 puts $f "set geometry(canv3) [expr {[winfo width $canv3]-2}]"
667 puts $f "set geometry(canvh) [expr {[winfo height $canv]-2}]"
668 set wid [expr {([winfo width $ctext] - 8) \
669 / [font measure $textfont "0"]}]
670 puts $f "set geometry(ctextw) $wid"
671 set wid [expr {([winfo width $cflist] - 11) \
672 / [font measure [$cflist cget -font] "0"]}]
673 puts $f "set geometry(cflistw) $wid"
674 close $f
675 file rename -force "~/.gitk-new" "~/.gitk"
677 set stuffsaved 1
680 proc resizeclistpanes {win w} {
681 global oldwidth
682 if [info exists oldwidth($win)] {
683 set s0 [$win sash coord 0]
684 set s1 [$win sash coord 1]
685 if {$w < 60} {
686 set sash0 [expr {int($w/2 - 2)}]
687 set sash1 [expr {int($w*5/6 - 2)}]
688 } else {
689 set factor [expr {1.0 * $w / $oldwidth($win)}]
690 set sash0 [expr {int($factor * [lindex $s0 0])}]
691 set sash1 [expr {int($factor * [lindex $s1 0])}]
692 if {$sash0 < 30} {
693 set sash0 30
695 if {$sash1 < $sash0 + 20} {
696 set sash1 [expr {$sash0 + 20}]
698 if {$sash1 > $w - 10} {
699 set sash1 [expr {$w - 10}]
700 if {$sash0 > $sash1 - 20} {
701 set sash0 [expr {$sash1 - 20}]
705 $win sash place 0 $sash0 [lindex $s0 1]
706 $win sash place 1 $sash1 [lindex $s1 1]
708 set oldwidth($win) $w
711 proc resizecdetpanes {win w} {
712 global oldwidth
713 if [info exists oldwidth($win)] {
714 set s0 [$win sash coord 0]
715 if {$w < 60} {
716 set sash0 [expr {int($w*3/4 - 2)}]
717 } else {
718 set factor [expr {1.0 * $w / $oldwidth($win)}]
719 set sash0 [expr {int($factor * [lindex $s0 0])}]
720 if {$sash0 < 45} {
721 set sash0 45
723 if {$sash0 > $w - 15} {
724 set sash0 [expr {$w - 15}]
727 $win sash place 0 $sash0 [lindex $s0 1]
729 set oldwidth($win) $w
732 proc allcanvs args {
733 global canv canv2 canv3
734 eval $canv $args
735 eval $canv2 $args
736 eval $canv3 $args
739 proc bindall {event action} {
740 global canv canv2 canv3
741 bind $canv $event $action
742 bind $canv2 $event $action
743 bind $canv3 $event $action
746 proc about {} {
747 set w .about
748 if {[winfo exists $w]} {
749 raise $w
750 return
752 toplevel $w
753 wm title $w "About gitk"
754 message $w.m -text {
755 Gitk version 1.2
757 Copyright © 2005 Paul Mackerras
759 Use and redistribute under the terms of the GNU General Public License} \
760 -justify center -aspect 400
761 pack $w.m -side top -fill x -padx 20 -pady 20
762 button $w.ok -text Close -command "destroy $w"
763 pack $w.ok -side bottom
766 proc assigncolor {id} {
767 global colormap commcolors colors nextcolor
768 global parents nparents children nchildren
769 global cornercrossings crossings
771 if [info exists colormap($id)] return
772 set ncolors [llength $colors]
773 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
774 set child [lindex $children($id) 0]
775 if {[info exists colormap($child)]
776 && $nparents($child) == 1} {
777 set colormap($id) $colormap($child)
778 return
781 set badcolors {}
782 if {[info exists cornercrossings($id)]} {
783 foreach x $cornercrossings($id) {
784 if {[info exists colormap($x)]
785 && [lsearch -exact $badcolors $colormap($x)] < 0} {
786 lappend badcolors $colormap($x)
789 if {[llength $badcolors] >= $ncolors} {
790 set badcolors {}
793 set origbad $badcolors
794 if {[llength $badcolors] < $ncolors - 1} {
795 if {[info exists crossings($id)]} {
796 foreach x $crossings($id) {
797 if {[info exists colormap($x)]
798 && [lsearch -exact $badcolors $colormap($x)] < 0} {
799 lappend badcolors $colormap($x)
802 if {[llength $badcolors] >= $ncolors} {
803 set badcolors $origbad
806 set origbad $badcolors
808 if {[llength $badcolors] < $ncolors - 1} {
809 foreach child $children($id) {
810 if {[info exists colormap($child)]
811 && [lsearch -exact $badcolors $colormap($child)] < 0} {
812 lappend badcolors $colormap($child)
814 if {[info exists parents($child)]} {
815 foreach p $parents($child) {
816 if {[info exists colormap($p)]
817 && [lsearch -exact $badcolors $colormap($p)] < 0} {
818 lappend badcolors $colormap($p)
823 if {[llength $badcolors] >= $ncolors} {
824 set badcolors $origbad
827 for {set i 0} {$i <= $ncolors} {incr i} {
828 set c [lindex $colors $nextcolor]
829 if {[incr nextcolor] >= $ncolors} {
830 set nextcolor 0
832 if {[lsearch -exact $badcolors $c]} break
834 set colormap($id) $c
837 proc initgraph {} {
838 global canvy canvy0 lineno numcommits nextcolor linespc
839 global nchildren ncleft
840 global displist nhyperspace
842 allcanvs delete all
843 set nextcolor 0
844 set canvy $canvy0
845 set lineno -1
846 set numcommits 0
847 foreach v {mainline mainlinearrow sidelines colormap cornercrossings
848 crossings idline lineid} {
849 global $v
850 catch {unset $v}
852 foreach id [array names nchildren] {
853 set ncleft($id) $nchildren($id)
855 set displist {}
856 set nhyperspace 0
859 proc bindline {t id} {
860 global canv
862 $canv bind $t <Enter> "lineenter %x %y $id"
863 $canv bind $t <Motion> "linemotion %x %y $id"
864 $canv bind $t <Leave> "lineleave $id"
865 $canv bind $t <Button-1> "lineclick %x %y $id 1"
868 proc drawlines {id xtra delold} {
869 global mainline mainlinearrow sidelines lthickness colormap canv
871 if {$delold} {
872 $canv delete lines.$id
874 if {[info exists mainline($id)]} {
875 set t [$canv create line $mainline($id) \
876 -width [expr {($xtra + 1) * $lthickness}] \
877 -fill $colormap($id) -tags lines.$id \
878 -arrow $mainlinearrow($id)]
879 $canv lower $t
880 bindline $t $id
882 if {[info exists sidelines($id)]} {
883 foreach ls $sidelines($id) {
884 set coords [lindex $ls 0]
885 set thick [lindex $ls 1]
886 set arrow [lindex $ls 2]
887 set t [$canv create line $coords -fill $colormap($id) \
888 -width [expr {($thick + $xtra) * $lthickness}] \
889 -arrow $arrow -tags lines.$id]
890 $canv lower $t
891 bindline $t $id
896 # level here is an index in displist
897 proc drawcommitline {level} {
898 global parents children nparents displist
899 global canv canv2 canv3 mainfont namefont canvy linespc
900 global lineid linehtag linentag linedtag commitinfo
901 global colormap numcommits currentparents dupparents
902 global idtags idline idheads idotherrefs
903 global lineno lthickness mainline mainlinearrow sidelines
904 global commitlisted rowtextx idpos lastuse displist
905 global oldnlines olddlevel olddisplist
907 incr numcommits
908 incr lineno
909 set id [lindex $displist $level]
910 set lastuse($id) $lineno
911 set lineid($lineno) $id
912 set idline($id) $lineno
913 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
914 if {![info exists commitinfo($id)]} {
915 readcommit $id
916 if {![info exists commitinfo($id)]} {
917 set commitinfo($id) {"No commit information available"}
918 set nparents($id) 0
921 assigncolor $id
922 set currentparents {}
923 set dupparents {}
924 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
925 foreach p $parents($id) {
926 if {[lsearch -exact $currentparents $p] < 0} {
927 lappend currentparents $p
928 } else {
929 # remember that this parent was listed twice
930 lappend dupparents $p
934 set x [xcoord $level $level $lineno]
935 set y1 $canvy
936 set canvy [expr {$canvy + $linespc}]
937 allcanvs conf -scrollregion \
938 [list 0 0 0 [expr {$y1 + 0.5 * $linespc + 2}]]
939 if {[info exists mainline($id)]} {
940 lappend mainline($id) $x $y1
941 if {$mainlinearrow($id) ne "none"} {
942 set mainline($id) [trimdiagstart $mainline($id)]
945 drawlines $id 0 0
946 set orad [expr {$linespc / 3}]
947 set t [$canv create oval [expr {$x - $orad}] [expr {$y1 - $orad}] \
948 [expr {$x + $orad - 1}] [expr {$y1 + $orad - 1}] \
949 -fill $ofill -outline black -width 1]
950 $canv raise $t
951 $canv bind $t <1> {selcanvline {} %x %y}
952 set xt [xcoord [llength $displist] $level $lineno]
953 if {[llength $currentparents] > 2} {
954 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
956 set rowtextx($lineno) $xt
957 set idpos($id) [list $x $xt $y1]
958 if {[info exists idtags($id)] || [info exists idheads($id)]
959 || [info exists idotherrefs($id)]} {
960 set xt [drawtags $id $x $xt $y1]
962 set headline [lindex $commitinfo($id) 0]
963 set name [lindex $commitinfo($id) 1]
964 set date [lindex $commitinfo($id) 2]
965 set date [formatdate $date]
966 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
967 -text $headline -font $mainfont ]
968 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
969 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
970 -text $name -font $namefont]
971 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
972 -text $date -font $mainfont]
974 set olddlevel $level
975 set olddisplist $displist
976 set oldnlines [llength $displist]
979 proc drawtags {id x xt y1} {
980 global idtags idheads idotherrefs
981 global linespc lthickness
982 global canv mainfont idline rowtextx
984 set marks {}
985 set ntags 0
986 set nheads 0
987 if {[info exists idtags($id)]} {
988 set marks $idtags($id)
989 set ntags [llength $marks]
991 if {[info exists idheads($id)]} {
992 set marks [concat $marks $idheads($id)]
993 set nheads [llength $idheads($id)]
995 if {[info exists idotherrefs($id)]} {
996 set marks [concat $marks $idotherrefs($id)]
998 if {$marks eq {}} {
999 return $xt
1002 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
1003 set yt [expr {$y1 - 0.5 * $linespc}]
1004 set yb [expr {$yt + $linespc - 1}]
1005 set xvals {}
1006 set wvals {}
1007 foreach tag $marks {
1008 set wid [font measure $mainfont $tag]
1009 lappend xvals $xt
1010 lappend wvals $wid
1011 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
1013 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
1014 -width $lthickness -fill black -tags tag.$id]
1015 $canv lower $t
1016 foreach tag $marks x $xvals wid $wvals {
1017 set xl [expr {$x + $delta}]
1018 set xr [expr {$x + $delta + $wid + $lthickness}]
1019 if {[incr ntags -1] >= 0} {
1020 # draw a tag
1021 set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
1022 $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
1023 -width 1 -outline black -fill yellow -tags tag.$id]
1024 $canv bind $t <1> [list showtag $tag 1]
1025 set rowtextx($idline($id)) [expr {$xr + $linespc}]
1026 } else {
1027 # draw a head or other ref
1028 if {[incr nheads -1] >= 0} {
1029 set col green
1030 } else {
1031 set col "#ddddff"
1033 set xl [expr {$xl - $delta/2}]
1034 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
1035 -width 1 -outline black -fill $col -tags tag.$id
1037 set t [$canv create text $xl $y1 -anchor w -text $tag \
1038 -font $mainfont -tags tag.$id]
1039 if {$ntags >= 0} {
1040 $canv bind $t <1> [list showtag $tag 1]
1043 return $xt
1046 proc notecrossings {id lo hi corner} {
1047 global olddisplist crossings cornercrossings
1049 for {set i $lo} {[incr i] < $hi} {} {
1050 set p [lindex $olddisplist $i]
1051 if {$p == {}} continue
1052 if {$i == $corner} {
1053 if {![info exists cornercrossings($id)]
1054 || [lsearch -exact $cornercrossings($id) $p] < 0} {
1055 lappend cornercrossings($id) $p
1057 if {![info exists cornercrossings($p)]
1058 || [lsearch -exact $cornercrossings($p) $id] < 0} {
1059 lappend cornercrossings($p) $id
1061 } else {
1062 if {![info exists crossings($id)]
1063 || [lsearch -exact $crossings($id) $p] < 0} {
1064 lappend crossings($id) $p
1066 if {![info exists crossings($p)]
1067 || [lsearch -exact $crossings($p) $id] < 0} {
1068 lappend crossings($p) $id
1074 proc xcoord {i level ln} {
1075 global canvx0 xspc1 xspc2
1077 set x [expr {$canvx0 + $i * $xspc1($ln)}]
1078 if {$i > 0 && $i == $level} {
1079 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
1080 } elseif {$i > $level} {
1081 set x [expr {$x + $xspc2 - $xspc1($ln)}]
1083 return $x
1086 # it seems Tk can't draw arrows on the end of diagonal line segments...
1087 proc trimdiagend {line} {
1088 while {[llength $line] > 4} {
1089 set x1 [lindex $line end-3]
1090 set y1 [lindex $line end-2]
1091 set x2 [lindex $line end-1]
1092 set y2 [lindex $line end]
1093 if {($x1 == $x2) != ($y1 == $y2)} break
1094 set line [lreplace $line end-1 end]
1096 return $line
1099 proc trimdiagstart {line} {
1100 while {[llength $line] > 4} {
1101 set x1 [lindex $line 0]
1102 set y1 [lindex $line 1]
1103 set x2 [lindex $line 2]
1104 set y2 [lindex $line 3]
1105 if {($x1 == $x2) != ($y1 == $y2)} break
1106 set line [lreplace $line 0 1]
1108 return $line
1111 proc drawslants {id needonscreen nohs} {
1112 global canv mainline mainlinearrow sidelines
1113 global canvx0 canvy xspc1 xspc2 lthickness
1114 global currentparents dupparents
1115 global lthickness linespc canvy colormap lineno geometry
1116 global maxgraphpct maxwidth
1117 global displist onscreen lastuse
1118 global parents commitlisted
1119 global oldnlines olddlevel olddisplist
1120 global nhyperspace numcommits nnewparents
1122 if {$lineno < 0} {
1123 lappend displist $id
1124 set onscreen($id) 1
1125 return 0
1128 set y1 [expr {$canvy - $linespc}]
1129 set y2 $canvy
1131 # work out what we need to get back on screen
1132 set reins {}
1133 if {$onscreen($id) < 0} {
1134 # next to do isn't displayed, better get it on screen...
1135 lappend reins [list $id 0]
1137 # make sure all the previous commits's parents are on the screen
1138 foreach p $currentparents {
1139 if {$onscreen($p) < 0} {
1140 lappend reins [list $p 0]
1143 # bring back anything requested by caller
1144 if {$needonscreen ne {}} {
1145 lappend reins $needonscreen
1148 # try the shortcut
1149 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1150 set dlevel $olddlevel
1151 set x [xcoord $dlevel $dlevel $lineno]
1152 set mainline($id) [list $x $y1]
1153 set mainlinearrow($id) none
1154 set lastuse($id) $lineno
1155 set displist [lreplace $displist $dlevel $dlevel $id]
1156 set onscreen($id) 1
1157 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1158 return $dlevel
1161 # update displist
1162 set displist [lreplace $displist $olddlevel $olddlevel]
1163 set j $olddlevel
1164 foreach p $currentparents {
1165 set lastuse($p) $lineno
1166 if {$onscreen($p) == 0} {
1167 set displist [linsert $displist $j $p]
1168 set onscreen($p) 1
1169 incr j
1172 if {$onscreen($id) == 0} {
1173 lappend displist $id
1174 set onscreen($id) 1
1177 # remove the null entry if present
1178 set nullentry [lsearch -exact $displist {}]
1179 if {$nullentry >= 0} {
1180 set displist [lreplace $displist $nullentry $nullentry]
1183 # bring back the ones we need now (if we did it earlier
1184 # it would change displist and invalidate olddlevel)
1185 foreach pi $reins {
1186 # test again in case of duplicates in reins
1187 set p [lindex $pi 0]
1188 if {$onscreen($p) < 0} {
1189 set onscreen($p) 1
1190 set lastuse($p) $lineno
1191 set displist [linsert $displist [lindex $pi 1] $p]
1192 incr nhyperspace -1
1196 set lastuse($id) $lineno
1198 # see if we need to make any lines jump off into hyperspace
1199 set displ [llength $displist]
1200 if {$displ > $maxwidth} {
1201 set ages {}
1202 foreach x $displist {
1203 lappend ages [list $lastuse($x) $x]
1205 set ages [lsort -integer -index 0 $ages]
1206 set k 0
1207 while {$displ > $maxwidth} {
1208 set use [lindex $ages $k 0]
1209 set victim [lindex $ages $k 1]
1210 if {$use >= $lineno - 5} break
1211 incr k
1212 if {[lsearch -exact $nohs $victim] >= 0} continue
1213 set i [lsearch -exact $displist $victim]
1214 set displist [lreplace $displist $i $i]
1215 set onscreen($victim) -1
1216 incr nhyperspace
1217 incr displ -1
1218 if {$i < $nullentry} {
1219 incr nullentry -1
1221 set x [lindex $mainline($victim) end-1]
1222 lappend mainline($victim) $x $y1
1223 set line [trimdiagend $mainline($victim)]
1224 set arrow "last"
1225 if {$mainlinearrow($victim) ne "none"} {
1226 set line [trimdiagstart $line]
1227 set arrow "both"
1229 lappend sidelines($victim) [list $line 1 $arrow]
1230 unset mainline($victim)
1234 set dlevel [lsearch -exact $displist $id]
1236 # If we are reducing, put in a null entry
1237 if {$displ < $oldnlines} {
1238 # does the next line look like a merge?
1239 # i.e. does it have > 1 new parent?
1240 if {$nnewparents($id) > 1} {
1241 set i [expr {$dlevel + 1}]
1242 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1243 set i $olddlevel
1244 if {$nullentry >= 0 && $nullentry < $i} {
1245 incr i -1
1247 } elseif {$nullentry >= 0} {
1248 set i $nullentry
1249 while {$i < $displ
1250 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1251 incr i
1253 } else {
1254 set i $olddlevel
1255 if {$dlevel >= $i} {
1256 incr i
1259 if {$i < $displ} {
1260 set displist [linsert $displist $i {}]
1261 incr displ
1262 if {$dlevel >= $i} {
1263 incr dlevel
1268 # decide on the line spacing for the next line
1269 set lj [expr {$lineno + 1}]
1270 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1271 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1272 set xspc1($lj) $xspc2
1273 } else {
1274 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1275 if {$xspc1($lj) < $lthickness} {
1276 set xspc1($lj) $lthickness
1280 foreach idi $reins {
1281 set id [lindex $idi 0]
1282 set j [lsearch -exact $displist $id]
1283 set xj [xcoord $j $dlevel $lj]
1284 set mainline($id) [list $xj $y2]
1285 set mainlinearrow($id) first
1288 set i -1
1289 foreach id $olddisplist {
1290 incr i
1291 if {$id == {}} continue
1292 if {$onscreen($id) <= 0} continue
1293 set xi [xcoord $i $olddlevel $lineno]
1294 if {$i == $olddlevel} {
1295 foreach p $currentparents {
1296 set j [lsearch -exact $displist $p]
1297 set coords [list $xi $y1]
1298 set xj [xcoord $j $dlevel $lj]
1299 if {$xj < $xi - $linespc} {
1300 lappend coords [expr {$xj + $linespc}] $y1
1301 notecrossings $p $j $i [expr {$j + 1}]
1302 } elseif {$xj > $xi + $linespc} {
1303 lappend coords [expr {$xj - $linespc}] $y1
1304 notecrossings $p $i $j [expr {$j - 1}]
1306 if {[lsearch -exact $dupparents $p] >= 0} {
1307 # draw a double-width line to indicate the doubled parent
1308 lappend coords $xj $y2
1309 lappend sidelines($p) [list $coords 2 none]
1310 if {![info exists mainline($p)]} {
1311 set mainline($p) [list $xj $y2]
1312 set mainlinearrow($p) none
1314 } else {
1315 # normal case, no parent duplicated
1316 set yb $y2
1317 set dx [expr {abs($xi - $xj)}]
1318 if {0 && $dx < $linespc} {
1319 set yb [expr {$y1 + $dx}]
1321 if {![info exists mainline($p)]} {
1322 if {$xi != $xj} {
1323 lappend coords $xj $yb
1325 set mainline($p) $coords
1326 set mainlinearrow($p) none
1327 } else {
1328 lappend coords $xj $yb
1329 if {$yb < $y2} {
1330 lappend coords $xj $y2
1332 lappend sidelines($p) [list $coords 1 none]
1336 } else {
1337 set j $i
1338 if {[lindex $displist $i] != $id} {
1339 set j [lsearch -exact $displist $id]
1341 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1342 || ($olddlevel < $i && $i < $dlevel)
1343 || ($dlevel < $i && $i < $olddlevel)} {
1344 set xj [xcoord $j $dlevel $lj]
1345 lappend mainline($id) $xi $y1 $xj $y2
1349 return $dlevel
1352 # search for x in a list of lists
1353 proc llsearch {llist x} {
1354 set i 0
1355 foreach l $llist {
1356 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1357 return $i
1359 incr i
1361 return -1
1364 proc drawmore {reading} {
1365 global displayorder numcommits ncmupdate nextupdate
1366 global stopped nhyperspace parents commitlisted
1367 global maxwidth onscreen displist currentparents olddlevel
1369 set n [llength $displayorder]
1370 while {$numcommits < $n} {
1371 set id [lindex $displayorder $numcommits]
1372 set ctxend [expr {$numcommits + 10}]
1373 if {!$reading && $ctxend > $n} {
1374 set ctxend $n
1376 set dlist {}
1377 if {$numcommits > 0} {
1378 set dlist [lreplace $displist $olddlevel $olddlevel]
1379 set i $olddlevel
1380 foreach p $currentparents {
1381 if {$onscreen($p) == 0} {
1382 set dlist [linsert $dlist $i $p]
1383 incr i
1387 set nohs {}
1388 set reins {}
1389 set isfat [expr {[llength $dlist] > $maxwidth}]
1390 if {$nhyperspace > 0 || $isfat} {
1391 if {$ctxend > $n} break
1392 # work out what to bring back and
1393 # what we want to don't want to send into hyperspace
1394 set room 1
1395 for {set k $numcommits} {$k < $ctxend} {incr k} {
1396 set x [lindex $displayorder $k]
1397 set i [llsearch $dlist $x]
1398 if {$i < 0} {
1399 set i [llength $dlist]
1400 lappend dlist $x
1402 if {[lsearch -exact $nohs $x] < 0} {
1403 lappend nohs $x
1405 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1406 set reins [list $x $i]
1408 set newp {}
1409 if {[info exists commitlisted($x)]} {
1410 set right 0
1411 foreach p $parents($x) {
1412 if {[llsearch $dlist $p] < 0} {
1413 lappend newp $p
1414 if {[lsearch -exact $nohs $p] < 0} {
1415 lappend nohs $p
1417 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1418 set reins [list $p [expr {$i + $right}]]
1421 set right 1
1424 set l [lindex $dlist $i]
1425 if {[llength $l] == 1} {
1426 set l $newp
1427 } else {
1428 set j [lsearch -exact $l $x]
1429 set l [concat [lreplace $l $j $j] $newp]
1431 set dlist [lreplace $dlist $i $i $l]
1432 if {$room && $isfat && [llength $newp] <= 1} {
1433 set room 0
1438 set dlevel [drawslants $id $reins $nohs]
1439 drawcommitline $dlevel
1440 if {[clock clicks -milliseconds] >= $nextupdate
1441 && $numcommits >= $ncmupdate} {
1442 doupdate $reading
1443 if {$stopped} break
1448 # level here is an index in todo
1449 proc updatetodo {level noshortcut} {
1450 global ncleft todo nnewparents
1451 global commitlisted parents onscreen
1453 set id [lindex $todo $level]
1454 set olds {}
1455 if {[info exists commitlisted($id)]} {
1456 foreach p $parents($id) {
1457 if {[lsearch -exact $olds $p] < 0} {
1458 lappend olds $p
1462 if {!$noshortcut && [llength $olds] == 1} {
1463 set p [lindex $olds 0]
1464 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1465 set ncleft($p) 0
1466 set todo [lreplace $todo $level $level $p]
1467 set onscreen($p) 0
1468 set nnewparents($id) 1
1469 return 0
1473 set todo [lreplace $todo $level $level]
1474 set i $level
1475 set n 0
1476 foreach p $olds {
1477 incr ncleft($p) -1
1478 set k [lsearch -exact $todo $p]
1479 if {$k < 0} {
1480 set todo [linsert $todo $i $p]
1481 set onscreen($p) 0
1482 incr i
1483 incr n
1486 set nnewparents($id) $n
1488 return 1
1491 proc decidenext {{noread 0}} {
1492 global ncleft todo
1493 global datemode cdate
1494 global commitinfo
1496 # choose which one to do next time around
1497 set todol [llength $todo]
1498 set level -1
1499 set latest {}
1500 for {set k $todol} {[incr k -1] >= 0} {} {
1501 set p [lindex $todo $k]
1502 if {$ncleft($p) == 0} {
1503 if {$datemode} {
1504 if {![info exists commitinfo($p)]} {
1505 if {$noread} {
1506 return {}
1508 readcommit $p
1510 if {$latest == {} || $cdate($p) > $latest} {
1511 set level $k
1512 set latest $cdate($p)
1514 } else {
1515 set level $k
1516 break
1521 return $level
1524 proc drawcommit {id reading} {
1525 global phase todo nchildren datemode nextupdate revlistorder ncleft
1526 global numcommits ncmupdate displayorder todo onscreen parents
1527 global commitlisted commitordered
1529 if {$phase != "incrdraw"} {
1530 set phase incrdraw
1531 set displayorder {}
1532 set todo {}
1533 initgraph
1534 catch {unset commitordered}
1536 set commitordered($id) 1
1537 if {$nchildren($id) == 0} {
1538 lappend todo $id
1539 set onscreen($id) 0
1541 if {$revlistorder} {
1542 set level [lsearch -exact $todo $id]
1543 if {$level < 0} {
1544 error_popup "oops, $id isn't in todo"
1545 return
1547 lappend displayorder $id
1548 updatetodo $level 0
1549 } else {
1550 set level [decidenext 1]
1551 if {$level == {} || $level < 0} return
1552 while 1 {
1553 set id [lindex $todo $level]
1554 if {![info exists commitordered($id)]} {
1555 break
1557 lappend displayorder [lindex $todo $level]
1558 if {[updatetodo $level $datemode]} {
1559 set level [decidenext 1]
1560 if {$level == {} || $level < 0} break
1564 drawmore $reading
1567 proc finishcommits {} {
1568 global phase oldcommits commits
1569 global canv mainfont ctext maincursor textcursor
1570 global parents displayorder todo
1572 if {$phase == "incrdraw" || $phase == "removecommits"} {
1573 foreach id $oldcommits {
1574 lappend commits $id
1575 drawcommit $id 0
1577 set oldcommits {}
1578 drawrest
1579 } elseif {$phase == "updatecommits"} {
1580 # there were no new commits, in fact
1581 set commits $oldcommits
1582 set oldcommits {}
1583 set phase {}
1584 } else {
1585 $canv delete all
1586 $canv create text 3 3 -anchor nw -text "No commits selected" \
1587 -font $mainfont -tags textitems
1588 set phase {}
1590 . config -cursor $maincursor
1591 settextcursor $textcursor
1594 # Don't change the text pane cursor if it is currently the hand cursor,
1595 # showing that we are over a sha1 ID link.
1596 proc settextcursor {c} {
1597 global ctext curtextcursor
1599 if {[$ctext cget -cursor] == $curtextcursor} {
1600 $ctext config -cursor $c
1602 set curtextcursor $c
1605 proc drawgraph {} {
1606 global nextupdate startmsecs ncmupdate
1607 global displayorder onscreen
1609 if {$displayorder == {}} return
1610 set startmsecs [clock clicks -milliseconds]
1611 set nextupdate [expr {$startmsecs + 100}]
1612 set ncmupdate 1
1613 initgraph
1614 foreach id $displayorder {
1615 set onscreen($id) 0
1617 drawmore 0
1620 proc drawrest {} {
1621 global phase stopped redisplaying selectedline
1622 global datemode todo displayorder ncleft
1623 global numcommits ncmupdate
1624 global nextupdate startmsecs revlistorder
1626 set level [decidenext]
1627 if {$level >= 0} {
1628 set phase drawgraph
1629 while 1 {
1630 lappend displayorder [lindex $todo $level]
1631 set hard [updatetodo $level $datemode]
1632 if {$hard} {
1633 set level [decidenext]
1634 if {$level < 0} break
1638 if {$todo != {}} {
1639 puts "ERROR: none of the pending commits can be done yet:"
1640 foreach p $todo {
1641 puts " $p ($ncleft($p))"
1645 drawmore 0
1646 set phase {}
1647 set drawmsecs [expr {[clock clicks -milliseconds] - $startmsecs}]
1648 #puts "overall $drawmsecs ms for $numcommits commits"
1649 if {$redisplaying} {
1650 if {$stopped == 0 && [info exists selectedline]} {
1651 selectline $selectedline 0
1653 if {$stopped == 1} {
1654 set stopped 0
1655 after idle drawgraph
1656 } else {
1657 set redisplaying 0
1662 proc findmatches {f} {
1663 global findtype foundstring foundstrlen
1664 if {$findtype == "Regexp"} {
1665 set matches [regexp -indices -all -inline $foundstring $f]
1666 } else {
1667 if {$findtype == "IgnCase"} {
1668 set str [string tolower $f]
1669 } else {
1670 set str $f
1672 set matches {}
1673 set i 0
1674 while {[set j [string first $foundstring $str $i]] >= 0} {
1675 lappend matches [list $j [expr {$j+$foundstrlen-1}]]
1676 set i [expr {$j + $foundstrlen}]
1679 return $matches
1682 proc dofind {} {
1683 global findtype findloc findstring markedmatches commitinfo
1684 global numcommits lineid linehtag linentag linedtag
1685 global mainfont namefont canv canv2 canv3 selectedline
1686 global matchinglines foundstring foundstrlen
1688 stopfindproc
1689 unmarkmatches
1690 focus .
1691 set matchinglines {}
1692 if {$findloc == "Pickaxe"} {
1693 findpatches
1694 return
1696 if {$findtype == "IgnCase"} {
1697 set foundstring [string tolower $findstring]
1698 } else {
1699 set foundstring $findstring
1701 set foundstrlen [string length $findstring]
1702 if {$foundstrlen == 0} return
1703 if {$findloc == "Files"} {
1704 findfiles
1705 return
1707 if {![info exists selectedline]} {
1708 set oldsel -1
1709 } else {
1710 set oldsel $selectedline
1712 set didsel 0
1713 set fldtypes {Headline Author Date Committer CDate Comment}
1714 for {set l 0} {$l < $numcommits} {incr l} {
1715 set id $lineid($l)
1716 set info $commitinfo($id)
1717 set doesmatch 0
1718 foreach f $info ty $fldtypes {
1719 if {$findloc != "All fields" && $findloc != $ty} {
1720 continue
1722 set matches [findmatches $f]
1723 if {$matches == {}} continue
1724 set doesmatch 1
1725 if {$ty == "Headline"} {
1726 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1727 } elseif {$ty == "Author"} {
1728 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1729 } elseif {$ty == "Date"} {
1730 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1733 if {$doesmatch} {
1734 lappend matchinglines $l
1735 if {!$didsel && $l > $oldsel} {
1736 findselectline $l
1737 set didsel 1
1741 if {$matchinglines == {}} {
1742 bell
1743 } elseif {!$didsel} {
1744 findselectline [lindex $matchinglines 0]
1748 proc findselectline {l} {
1749 global findloc commentend ctext
1750 selectline $l 1
1751 if {$findloc == "All fields" || $findloc == "Comments"} {
1752 # highlight the matches in the comments
1753 set f [$ctext get 1.0 $commentend]
1754 set matches [findmatches $f]
1755 foreach match $matches {
1756 set start [lindex $match 0]
1757 set end [expr {[lindex $match 1] + 1}]
1758 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1763 proc findnext {restart} {
1764 global matchinglines selectedline
1765 if {![info exists matchinglines]} {
1766 if {$restart} {
1767 dofind
1769 return
1771 if {![info exists selectedline]} return
1772 foreach l $matchinglines {
1773 if {$l > $selectedline} {
1774 findselectline $l
1775 return
1778 bell
1781 proc findprev {} {
1782 global matchinglines selectedline
1783 if {![info exists matchinglines]} {
1784 dofind
1785 return
1787 if {![info exists selectedline]} return
1788 set prev {}
1789 foreach l $matchinglines {
1790 if {$l >= $selectedline} break
1791 set prev $l
1793 if {$prev != {}} {
1794 findselectline $prev
1795 } else {
1796 bell
1800 proc findlocchange {name ix op} {
1801 global findloc findtype findtypemenu
1802 if {$findloc == "Pickaxe"} {
1803 set findtype Exact
1804 set state disabled
1805 } else {
1806 set state normal
1808 $findtypemenu entryconf 1 -state $state
1809 $findtypemenu entryconf 2 -state $state
1812 proc stopfindproc {{done 0}} {
1813 global findprocpid findprocfile findids
1814 global ctext findoldcursor phase maincursor textcursor
1815 global findinprogress
1817 catch {unset findids}
1818 if {[info exists findprocpid]} {
1819 if {!$done} {
1820 catch {exec kill $findprocpid}
1822 catch {close $findprocfile}
1823 unset findprocpid
1825 if {[info exists findinprogress]} {
1826 unset findinprogress
1827 if {$phase != "incrdraw"} {
1828 . config -cursor $maincursor
1829 settextcursor $textcursor
1834 proc findpatches {} {
1835 global findstring selectedline numcommits
1836 global findprocpid findprocfile
1837 global finddidsel ctext lineid findinprogress
1838 global findinsertpos
1840 if {$numcommits == 0} return
1842 # make a list of all the ids to search, starting at the one
1843 # after the selected line (if any)
1844 if {[info exists selectedline]} {
1845 set l $selectedline
1846 } else {
1847 set l -1
1849 set inputids {}
1850 for {set i 0} {$i < $numcommits} {incr i} {
1851 if {[incr l] >= $numcommits} {
1852 set l 0
1854 append inputids $lineid($l) "\n"
1857 if {[catch {
1858 set f [open [list | git-diff-tree --stdin -s -r -S$findstring \
1859 << $inputids] r]
1860 } err]} {
1861 error_popup "Error starting search process: $err"
1862 return
1865 set findinsertpos end
1866 set findprocfile $f
1867 set findprocpid [pid $f]
1868 fconfigure $f -blocking 0
1869 fileevent $f readable readfindproc
1870 set finddidsel 0
1871 . config -cursor watch
1872 settextcursor watch
1873 set findinprogress 1
1876 proc readfindproc {} {
1877 global findprocfile finddidsel
1878 global idline matchinglines findinsertpos
1880 set n [gets $findprocfile line]
1881 if {$n < 0} {
1882 if {[eof $findprocfile]} {
1883 stopfindproc 1
1884 if {!$finddidsel} {
1885 bell
1888 return
1890 if {![regexp {^[0-9a-f]{40}} $line id]} {
1891 error_popup "Can't parse git-diff-tree output: $line"
1892 stopfindproc
1893 return
1895 if {![info exists idline($id)]} {
1896 puts stderr "spurious id: $id"
1897 return
1899 set l $idline($id)
1900 insertmatch $l $id
1903 proc insertmatch {l id} {
1904 global matchinglines findinsertpos finddidsel
1906 if {$findinsertpos == "end"} {
1907 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1908 set matchinglines [linsert $matchinglines 0 $l]
1909 set findinsertpos 1
1910 } else {
1911 lappend matchinglines $l
1913 } else {
1914 set matchinglines [linsert $matchinglines $findinsertpos $l]
1915 incr findinsertpos
1917 markheadline $l $id
1918 if {!$finddidsel} {
1919 findselectline $l
1920 set finddidsel 1
1924 proc findfiles {} {
1925 global selectedline numcommits lineid ctext
1926 global ffileline finddidsel parents nparents
1927 global findinprogress findstartline findinsertpos
1928 global treediffs fdiffids fdiffsneeded fdiffpos
1929 global findmergefiles
1931 if {$numcommits == 0} return
1933 if {[info exists selectedline]} {
1934 set l [expr {$selectedline + 1}]
1935 } else {
1936 set l 0
1938 set ffileline $l
1939 set findstartline $l
1940 set diffsneeded {}
1941 set fdiffsneeded {}
1942 while 1 {
1943 set id $lineid($l)
1944 if {$findmergefiles || $nparents($id) == 1} {
1945 foreach p $parents($id) {
1946 if {![info exists treediffs([list $id $p])]} {
1947 append diffsneeded "$id $p\n"
1948 lappend fdiffsneeded [list $id $p]
1952 if {[incr l] >= $numcommits} {
1953 set l 0
1955 if {$l == $findstartline} break
1958 # start off a git-diff-tree process if needed
1959 if {$diffsneeded ne {}} {
1960 if {[catch {
1961 set df [open [list | git-diff-tree -r --stdin << $diffsneeded] r]
1962 } err ]} {
1963 error_popup "Error starting search process: $err"
1964 return
1966 catch {unset fdiffids}
1967 set fdiffpos 0
1968 fconfigure $df -blocking 0
1969 fileevent $df readable [list readfilediffs $df]
1972 set finddidsel 0
1973 set findinsertpos end
1974 set id $lineid($l)
1975 set p [lindex $parents($id) 0]
1976 . config -cursor watch
1977 settextcursor watch
1978 set findinprogress 1
1979 findcont [list $id $p]
1980 update
1983 proc readfilediffs {df} {
1984 global findids fdiffids fdiffs
1986 set n [gets $df line]
1987 if {$n < 0} {
1988 if {[eof $df]} {
1989 donefilediff
1990 if {[catch {close $df} err]} {
1991 stopfindproc
1992 bell
1993 error_popup "Error in git-diff-tree: $err"
1994 } elseif {[info exists findids]} {
1995 set ids $findids
1996 stopfindproc
1997 bell
1998 error_popup "Couldn't find diffs for {$ids}"
2001 return
2003 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
2004 # start of a new string of diffs
2005 donefilediff
2006 set fdiffids [list $id $p]
2007 set fdiffs {}
2008 } elseif {[string match ":*" $line]} {
2009 lappend fdiffs [lindex $line 5]
2013 proc donefilediff {} {
2014 global fdiffids fdiffs treediffs findids
2015 global fdiffsneeded fdiffpos
2017 if {[info exists fdiffids]} {
2018 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
2019 && $fdiffpos < [llength $fdiffsneeded]} {
2020 # git-diff-tree doesn't output anything for a commit
2021 # which doesn't change anything
2022 set nullids [lindex $fdiffsneeded $fdiffpos]
2023 set treediffs($nullids) {}
2024 if {[info exists findids] && $nullids eq $findids} {
2025 unset findids
2026 findcont $nullids
2028 incr fdiffpos
2030 incr fdiffpos
2032 if {![info exists treediffs($fdiffids)]} {
2033 set treediffs($fdiffids) $fdiffs
2035 if {[info exists findids] && $fdiffids eq $findids} {
2036 unset findids
2037 findcont $fdiffids
2042 proc findcont {ids} {
2043 global findids treediffs parents nparents
2044 global ffileline findstartline finddidsel
2045 global lineid numcommits matchinglines findinprogress
2046 global findmergefiles
2048 set id [lindex $ids 0]
2049 set p [lindex $ids 1]
2050 set pi [lsearch -exact $parents($id) $p]
2051 set l $ffileline
2052 while 1 {
2053 if {$findmergefiles || $nparents($id) == 1} {
2054 if {![info exists treediffs($ids)]} {
2055 set findids $ids
2056 set ffileline $l
2057 return
2059 set doesmatch 0
2060 foreach f $treediffs($ids) {
2061 set x [findmatches $f]
2062 if {$x != {}} {
2063 set doesmatch 1
2064 break
2067 if {$doesmatch} {
2068 insertmatch $l $id
2069 set pi $nparents($id)
2071 } else {
2072 set pi $nparents($id)
2074 if {[incr pi] >= $nparents($id)} {
2075 set pi 0
2076 if {[incr l] >= $numcommits} {
2077 set l 0
2079 if {$l == $findstartline} break
2080 set id $lineid($l)
2082 set p [lindex $parents($id) $pi]
2083 set ids [list $id $p]
2085 stopfindproc
2086 if {!$finddidsel} {
2087 bell
2091 # mark a commit as matching by putting a yellow background
2092 # behind the headline
2093 proc markheadline {l id} {
2094 global canv mainfont linehtag commitinfo
2096 set bbox [$canv bbox $linehtag($l)]
2097 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
2098 $canv lower $t
2101 # mark the bits of a headline, author or date that match a find string
2102 proc markmatches {canv l str tag matches font} {
2103 set bbox [$canv bbox $tag]
2104 set x0 [lindex $bbox 0]
2105 set y0 [lindex $bbox 1]
2106 set y1 [lindex $bbox 3]
2107 foreach match $matches {
2108 set start [lindex $match 0]
2109 set end [lindex $match 1]
2110 if {$start > $end} continue
2111 set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
2112 set xlen [font measure $font [string range $str 0 [expr {$end}]]]
2113 set t [$canv create rect [expr {$x0+$xoff}] $y0 \
2114 [expr {$x0+$xlen+2}] $y1 \
2115 -outline {} -tags matches -fill yellow]
2116 $canv lower $t
2120 proc unmarkmatches {} {
2121 global matchinglines findids
2122 allcanvs delete matches
2123 catch {unset matchinglines}
2124 catch {unset findids}
2127 proc selcanvline {w x y} {
2128 global canv canvy0 ctext linespc
2129 global lineid linehtag linentag linedtag rowtextx
2130 set ymax [lindex [$canv cget -scrollregion] 3]
2131 if {$ymax == {}} return
2132 set yfrac [lindex [$canv yview] 0]
2133 set y [expr {$y + $yfrac * $ymax}]
2134 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
2135 if {$l < 0} {
2136 set l 0
2138 if {$w eq $canv} {
2139 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
2141 unmarkmatches
2142 selectline $l 1
2145 proc commit_descriptor {p} {
2146 global commitinfo
2147 set l "..."
2148 if {[info exists commitinfo($p)]} {
2149 set l [lindex $commitinfo($p) 0]
2151 return "$p ($l)"
2154 # append some text to the ctext widget, and make any SHA1 ID
2155 # that we know about be a clickable link.
2156 proc appendwithlinks {text} {
2157 global ctext idline linknum
2159 set start [$ctext index "end - 1c"]
2160 $ctext insert end $text
2161 $ctext insert end "\n"
2162 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2163 foreach l $links {
2164 set s [lindex $l 0]
2165 set e [lindex $l 1]
2166 set linkid [string range $text $s $e]
2167 if {![info exists idline($linkid)]} continue
2168 incr e
2169 $ctext tag add link "$start + $s c" "$start + $e c"
2170 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2171 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2172 incr linknum
2174 $ctext tag conf link -foreground blue -underline 1
2175 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2176 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2179 proc selectline {l isnew} {
2180 global canv canv2 canv3 ctext commitinfo selectedline
2181 global lineid linehtag linentag linedtag
2182 global canvy0 linespc parents nparents children
2183 global cflist currentid sha1entry
2184 global commentend idtags idline linknum
2186 $canv delete hover
2187 normalline
2188 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2189 $canv delete secsel
2190 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2191 -tags secsel -fill [$canv cget -selectbackground]]
2192 $canv lower $t
2193 $canv2 delete secsel
2194 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2195 -tags secsel -fill [$canv2 cget -selectbackground]]
2196 $canv2 lower $t
2197 $canv3 delete secsel
2198 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2199 -tags secsel -fill [$canv3 cget -selectbackground]]
2200 $canv3 lower $t
2201 set y [expr {$canvy0 + $l * $linespc}]
2202 set ymax [lindex [$canv cget -scrollregion] 3]
2203 set ytop [expr {$y - $linespc - 1}]
2204 set ybot [expr {$y + $linespc + 1}]
2205 set wnow [$canv yview]
2206 set wtop [expr {[lindex $wnow 0] * $ymax}]
2207 set wbot [expr {[lindex $wnow 1] * $ymax}]
2208 set wh [expr {$wbot - $wtop}]
2209 set newtop $wtop
2210 if {$ytop < $wtop} {
2211 if {$ybot < $wtop} {
2212 set newtop [expr {$y - $wh / 2.0}]
2213 } else {
2214 set newtop $ytop
2215 if {$newtop > $wtop - $linespc} {
2216 set newtop [expr {$wtop - $linespc}]
2219 } elseif {$ybot > $wbot} {
2220 if {$ytop > $wbot} {
2221 set newtop [expr {$y - $wh / 2.0}]
2222 } else {
2223 set newtop [expr {$ybot - $wh}]
2224 if {$newtop < $wtop + $linespc} {
2225 set newtop [expr {$wtop + $linespc}]
2229 if {$newtop != $wtop} {
2230 if {$newtop < 0} {
2231 set newtop 0
2233 allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
2236 if {$isnew} {
2237 addtohistory [list selectline $l 0]
2240 set selectedline $l
2242 set id $lineid($l)
2243 set currentid $id
2244 $sha1entry delete 0 end
2245 $sha1entry insert 0 $id
2246 $sha1entry selection from 0
2247 $sha1entry selection to end
2249 $ctext conf -state normal
2250 $ctext delete 0.0 end
2251 set linknum 0
2252 $ctext mark set fmark.0 0.0
2253 $ctext mark gravity fmark.0 left
2254 set info $commitinfo($id)
2255 set date [formatdate [lindex $info 2]]
2256 $ctext insert end "Author: [lindex $info 1] $date\n"
2257 set date [formatdate [lindex $info 4]]
2258 $ctext insert end "Committer: [lindex $info 3] $date\n"
2259 if {[info exists idtags($id)]} {
2260 $ctext insert end "Tags:"
2261 foreach tag $idtags($id) {
2262 $ctext insert end " $tag"
2264 $ctext insert end "\n"
2267 set comment {}
2268 if {[info exists parents($id)]} {
2269 foreach p $parents($id) {
2270 append comment "Parent: [commit_descriptor $p]\n"
2273 if {[info exists children($id)]} {
2274 foreach c $children($id) {
2275 append comment "Child: [commit_descriptor $c]\n"
2278 append comment "\n"
2279 append comment [lindex $info 5]
2281 # make anything that looks like a SHA1 ID be a clickable link
2282 appendwithlinks $comment
2284 $ctext tag delete Comments
2285 $ctext tag remove found 1.0 end
2286 $ctext conf -state disabled
2287 set commentend [$ctext index "end - 1c"]
2289 $cflist delete 0 end
2290 $cflist insert end "Comments"
2291 if {$nparents($id) == 1} {
2292 startdiff $id
2293 } elseif {$nparents($id) > 1} {
2294 mergediff $id
2298 proc selnextline {dir} {
2299 global selectedline
2300 if {![info exists selectedline]} return
2301 set l [expr {$selectedline + $dir}]
2302 unmarkmatches
2303 selectline $l 1
2306 proc unselectline {} {
2307 global selectedline
2309 catch {unset selectedline}
2310 allcanvs delete secsel
2313 proc addtohistory {cmd} {
2314 global history historyindex
2316 if {$historyindex > 0
2317 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2318 return
2321 if {$historyindex < [llength $history]} {
2322 set history [lreplace $history $historyindex end $cmd]
2323 } else {
2324 lappend history $cmd
2326 incr historyindex
2327 if {$historyindex > 1} {
2328 .ctop.top.bar.leftbut conf -state normal
2329 } else {
2330 .ctop.top.bar.leftbut conf -state disabled
2332 .ctop.top.bar.rightbut conf -state disabled
2335 proc goback {} {
2336 global history historyindex
2338 if {$historyindex > 1} {
2339 incr historyindex -1
2340 set cmd [lindex $history [expr {$historyindex - 1}]]
2341 eval $cmd
2342 .ctop.top.bar.rightbut conf -state normal
2344 if {$historyindex <= 1} {
2345 .ctop.top.bar.leftbut conf -state disabled
2349 proc goforw {} {
2350 global history historyindex
2352 if {$historyindex < [llength $history]} {
2353 set cmd [lindex $history $historyindex]
2354 incr historyindex
2355 eval $cmd
2356 .ctop.top.bar.leftbut conf -state normal
2358 if {$historyindex >= [llength $history]} {
2359 .ctop.top.bar.rightbut conf -state disabled
2363 proc mergediff {id} {
2364 global parents diffmergeid diffmergegca mergefilelist diffpindex
2366 set diffmergeid $id
2367 set diffpindex -1
2368 set diffmergegca [findgca $parents($id)]
2369 if {[info exists mergefilelist($id)]} {
2370 if {$mergefilelist($id) ne {}} {
2371 showmergediff
2373 } else {
2374 contmergediff {}
2378 proc findgca {ids} {
2379 set gca {}
2380 foreach id $ids {
2381 if {$gca eq {}} {
2382 set gca $id
2383 } else {
2384 if {[catch {
2385 set gca [exec git-merge-base $gca $id]
2386 } err]} {
2387 return {}
2391 return $gca
2394 proc contmergediff {ids} {
2395 global diffmergeid diffpindex parents nparents diffmergegca
2396 global treediffs mergefilelist diffids treepending
2398 # diff the child against each of the parents, and diff
2399 # each of the parents against the GCA.
2400 while 1 {
2401 if {[lindex $ids 1] == $diffmergeid && $diffmergegca ne {}} {
2402 set ids [list $diffmergegca [lindex $ids 0]]
2403 } else {
2404 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2405 set p [lindex $parents($diffmergeid) $diffpindex]
2406 set ids [list $p $diffmergeid]
2408 if {![info exists treediffs($ids)]} {
2409 set diffids $ids
2410 if {![info exists treepending]} {
2411 gettreediffs $ids
2413 return
2417 # If a file in some parent is different from the child and also
2418 # different from the GCA, then it's interesting.
2419 # If we don't have a GCA, then a file is interesting if it is
2420 # different from the child in all the parents.
2421 if {$diffmergegca ne {}} {
2422 set files {}
2423 foreach p $parents($diffmergeid) {
2424 set gcadiffs $treediffs([list $diffmergegca $p])
2425 foreach f $treediffs([list $p $diffmergeid]) {
2426 if {[lsearch -exact $files $f] < 0
2427 && [lsearch -exact $gcadiffs $f] >= 0} {
2428 lappend files $f
2432 set files [lsort $files]
2433 } else {
2434 set p [lindex $parents($diffmergeid) 0]
2435 set files $treediffs([list $diffmergeid $p])
2436 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2437 set p [lindex $parents($diffmergeid) $i]
2438 set df $treediffs([list $p $diffmergeid])
2439 set nf {}
2440 foreach f $files {
2441 if {[lsearch -exact $df $f] >= 0} {
2442 lappend nf $f
2445 set files $nf
2449 set mergefilelist($diffmergeid) $files
2450 if {$files ne {}} {
2451 showmergediff
2455 proc showmergediff {} {
2456 global cflist diffmergeid mergefilelist parents
2457 global diffopts diffinhunk currentfile currenthunk filelines
2458 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2460 set files $mergefilelist($diffmergeid)
2461 foreach f $files {
2462 $cflist insert end $f
2464 set env(GIT_DIFF_OPTS) $diffopts
2465 set flist {}
2466 catch {unset currentfile}
2467 catch {unset currenthunk}
2468 catch {unset filelines}
2469 catch {unset groupfilenum}
2470 catch {unset grouphunks}
2471 set groupfilelast -1
2472 foreach p $parents($diffmergeid) {
2473 set cmd [list | git-diff-tree -p $p $diffmergeid]
2474 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2475 if {[catch {set f [open $cmd r]} err]} {
2476 error_popup "Error getting diffs: $err"
2477 foreach f $flist {
2478 catch {close $f}
2480 return
2482 lappend flist $f
2483 set ids [list $diffmergeid $p]
2484 set mergefds($ids) $f
2485 set diffinhunk($ids) 0
2486 set diffblocked($ids) 0
2487 fconfigure $f -blocking 0
2488 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2492 proc getmergediffline {f ids id} {
2493 global diffmergeid diffinhunk diffoldlines diffnewlines
2494 global currentfile currenthunk
2495 global diffoldstart diffnewstart diffoldlno diffnewlno
2496 global diffblocked mergefilelist
2497 global noldlines nnewlines difflcounts filelines
2499 set n [gets $f line]
2500 if {$n < 0} {
2501 if {![eof $f]} return
2504 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2505 if {$n < 0} {
2506 close $f
2508 return
2511 if {$diffinhunk($ids) != 0} {
2512 set fi $currentfile($ids)
2513 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2514 # continuing an existing hunk
2515 set line [string range $line 1 end]
2516 set p [lindex $ids 1]
2517 if {$match eq "-" || $match eq " "} {
2518 set filelines($p,$fi,$diffoldlno($ids)) $line
2519 incr diffoldlno($ids)
2521 if {$match eq "+" || $match eq " "} {
2522 set filelines($id,$fi,$diffnewlno($ids)) $line
2523 incr diffnewlno($ids)
2525 if {$match eq " "} {
2526 if {$diffinhunk($ids) == 2} {
2527 lappend difflcounts($ids) \
2528 [list $noldlines($ids) $nnewlines($ids)]
2529 set noldlines($ids) 0
2530 set diffinhunk($ids) 1
2532 incr noldlines($ids)
2533 } elseif {$match eq "-" || $match eq "+"} {
2534 if {$diffinhunk($ids) == 1} {
2535 lappend difflcounts($ids) [list $noldlines($ids)]
2536 set noldlines($ids) 0
2537 set nnewlines($ids) 0
2538 set diffinhunk($ids) 2
2540 if {$match eq "-"} {
2541 incr noldlines($ids)
2542 } else {
2543 incr nnewlines($ids)
2546 # and if it's \ No newline at end of line, then what?
2547 return
2549 # end of a hunk
2550 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2551 lappend difflcounts($ids) [list $noldlines($ids)]
2552 } elseif {$diffinhunk($ids) == 2
2553 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2554 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2556 set currenthunk($ids) [list $currentfile($ids) \
2557 $diffoldstart($ids) $diffnewstart($ids) \
2558 $diffoldlno($ids) $diffnewlno($ids) \
2559 $difflcounts($ids)]
2560 set diffinhunk($ids) 0
2561 # -1 = need to block, 0 = unblocked, 1 = is blocked
2562 set diffblocked($ids) -1
2563 processhunks
2564 if {$diffblocked($ids) == -1} {
2565 fileevent $f readable {}
2566 set diffblocked($ids) 1
2570 if {$n < 0} {
2571 # eof
2572 if {!$diffblocked($ids)} {
2573 close $f
2574 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2575 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2576 processhunks
2578 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2579 # start of a new file
2580 set currentfile($ids) \
2581 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2582 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2583 $line match f1l f1c f2l f2c rest]} {
2584 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2585 # start of a new hunk
2586 if {$f1l == 0 && $f1c == 0} {
2587 set f1l 1
2589 if {$f2l == 0 && $f2c == 0} {
2590 set f2l 1
2592 set diffinhunk($ids) 1
2593 set diffoldstart($ids) $f1l
2594 set diffnewstart($ids) $f2l
2595 set diffoldlno($ids) $f1l
2596 set diffnewlno($ids) $f2l
2597 set difflcounts($ids) {}
2598 set noldlines($ids) 0
2599 set nnewlines($ids) 0
2604 proc processhunks {} {
2605 global diffmergeid parents nparents currenthunk
2606 global mergefilelist diffblocked mergefds
2607 global grouphunks grouplinestart grouplineend groupfilenum
2609 set nfiles [llength $mergefilelist($diffmergeid)]
2610 while 1 {
2611 set fi $nfiles
2612 set lno 0
2613 # look for the earliest hunk
2614 foreach p $parents($diffmergeid) {
2615 set ids [list $diffmergeid $p]
2616 if {![info exists currenthunk($ids)]} return
2617 set i [lindex $currenthunk($ids) 0]
2618 set l [lindex $currenthunk($ids) 2]
2619 if {$i < $fi || ($i == $fi && $l < $lno)} {
2620 set fi $i
2621 set lno $l
2622 set pi $p
2626 if {$fi < $nfiles} {
2627 set ids [list $diffmergeid $pi]
2628 set hunk $currenthunk($ids)
2629 unset currenthunk($ids)
2630 if {$diffblocked($ids) > 0} {
2631 fileevent $mergefds($ids) readable \
2632 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2634 set diffblocked($ids) 0
2636 if {[info exists groupfilenum] && $groupfilenum == $fi
2637 && $lno <= $grouplineend} {
2638 # add this hunk to the pending group
2639 lappend grouphunks($pi) $hunk
2640 set endln [lindex $hunk 4]
2641 if {$endln > $grouplineend} {
2642 set grouplineend $endln
2644 continue
2648 # succeeding stuff doesn't belong in this group, so
2649 # process the group now
2650 if {[info exists groupfilenum]} {
2651 processgroup
2652 unset groupfilenum
2653 unset grouphunks
2656 if {$fi >= $nfiles} break
2658 # start a new group
2659 set groupfilenum $fi
2660 set grouphunks($pi) [list $hunk]
2661 set grouplinestart $lno
2662 set grouplineend [lindex $hunk 4]
2666 proc processgroup {} {
2667 global groupfilelast groupfilenum difffilestart
2668 global mergefilelist diffmergeid ctext filelines
2669 global parents diffmergeid diffoffset
2670 global grouphunks grouplinestart grouplineend nparents
2671 global mergemax
2673 $ctext conf -state normal
2674 set id $diffmergeid
2675 set f $groupfilenum
2676 if {$groupfilelast != $f} {
2677 $ctext insert end "\n"
2678 set here [$ctext index "end - 1c"]
2679 set difffilestart($f) $here
2680 set mark fmark.[expr {$f + 1}]
2681 $ctext mark set $mark $here
2682 $ctext mark gravity $mark left
2683 set header [lindex $mergefilelist($id) $f]
2684 set l [expr {(78 - [string length $header]) / 2}]
2685 set pad [string range "----------------------------------------" 1 $l]
2686 $ctext insert end "$pad $header $pad\n" filesep
2687 set groupfilelast $f
2688 foreach p $parents($id) {
2689 set diffoffset($p) 0
2693 $ctext insert end "@@" msep
2694 set nlines [expr {$grouplineend - $grouplinestart}]
2695 set events {}
2696 set pnum 0
2697 foreach p $parents($id) {
2698 set startline [expr {$grouplinestart + $diffoffset($p)}]
2699 set ol $startline
2700 set nl $grouplinestart
2701 if {[info exists grouphunks($p)]} {
2702 foreach h $grouphunks($p) {
2703 set l [lindex $h 2]
2704 if {$nl < $l} {
2705 for {} {$nl < $l} {incr nl} {
2706 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2707 incr ol
2710 foreach chunk [lindex $h 5] {
2711 if {[llength $chunk] == 2} {
2712 set olc [lindex $chunk 0]
2713 set nlc [lindex $chunk 1]
2714 set nnl [expr {$nl + $nlc}]
2715 lappend events [list $nl $nnl $pnum $olc $nlc]
2716 incr ol $olc
2717 set nl $nnl
2718 } else {
2719 incr ol [lindex $chunk 0]
2720 incr nl [lindex $chunk 0]
2725 if {$nl < $grouplineend} {
2726 for {} {$nl < $grouplineend} {incr nl} {
2727 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2728 incr ol
2731 set nlines [expr {$ol - $startline}]
2732 $ctext insert end " -$startline,$nlines" msep
2733 incr pnum
2736 set nlines [expr {$grouplineend - $grouplinestart}]
2737 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2739 set events [lsort -integer -index 0 $events]
2740 set nevents [llength $events]
2741 set nmerge $nparents($diffmergeid)
2742 set l $grouplinestart
2743 for {set i 0} {$i < $nevents} {set i $j} {
2744 set nl [lindex $events $i 0]
2745 while {$l < $nl} {
2746 $ctext insert end " $filelines($id,$f,$l)\n"
2747 incr l
2749 set e [lindex $events $i]
2750 set enl [lindex $e 1]
2751 set j $i
2752 set active {}
2753 while 1 {
2754 set pnum [lindex $e 2]
2755 set olc [lindex $e 3]
2756 set nlc [lindex $e 4]
2757 if {![info exists delta($pnum)]} {
2758 set delta($pnum) [expr {$olc - $nlc}]
2759 lappend active $pnum
2760 } else {
2761 incr delta($pnum) [expr {$olc - $nlc}]
2763 if {[incr j] >= $nevents} break
2764 set e [lindex $events $j]
2765 if {[lindex $e 0] >= $enl} break
2766 if {[lindex $e 1] > $enl} {
2767 set enl [lindex $e 1]
2770 set nlc [expr {$enl - $l}]
2771 set ncol mresult
2772 set bestpn -1
2773 if {[llength $active] == $nmerge - 1} {
2774 # no diff for one of the parents, i.e. it's identical
2775 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2776 if {![info exists delta($pnum)]} {
2777 if {$pnum < $mergemax} {
2778 lappend ncol m$pnum
2779 } else {
2780 lappend ncol mmax
2782 break
2785 } elseif {[llength $active] == $nmerge} {
2786 # all parents are different, see if one is very similar
2787 set bestsim 30
2788 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2789 set sim [similarity $pnum $l $nlc $f \
2790 [lrange $events $i [expr {$j-1}]]]
2791 if {$sim > $bestsim} {
2792 set bestsim $sim
2793 set bestpn $pnum
2796 if {$bestpn >= 0} {
2797 lappend ncol m$bestpn
2800 set pnum -1
2801 foreach p $parents($id) {
2802 incr pnum
2803 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2804 set olc [expr {$nlc + $delta($pnum)}]
2805 set ol [expr {$l + $diffoffset($p)}]
2806 incr diffoffset($p) $delta($pnum)
2807 unset delta($pnum)
2808 for {} {$olc > 0} {incr olc -1} {
2809 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2810 incr ol
2813 set endl [expr {$l + $nlc}]
2814 if {$bestpn >= 0} {
2815 # show this pretty much as a normal diff
2816 set p [lindex $parents($id) $bestpn]
2817 set ol [expr {$l + $diffoffset($p)}]
2818 incr diffoffset($p) $delta($bestpn)
2819 unset delta($bestpn)
2820 for {set k $i} {$k < $j} {incr k} {
2821 set e [lindex $events $k]
2822 if {[lindex $e 2] != $bestpn} continue
2823 set nl [lindex $e 0]
2824 set ol [expr {$ol + $nl - $l}]
2825 for {} {$l < $nl} {incr l} {
2826 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2828 set c [lindex $e 3]
2829 for {} {$c > 0} {incr c -1} {
2830 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2831 incr ol
2833 set nl [lindex $e 1]
2834 for {} {$l < $nl} {incr l} {
2835 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2839 for {} {$l < $endl} {incr l} {
2840 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2843 while {$l < $grouplineend} {
2844 $ctext insert end " $filelines($id,$f,$l)\n"
2845 incr l
2847 $ctext conf -state disabled
2850 proc similarity {pnum l nlc f events} {
2851 global diffmergeid parents diffoffset filelines
2853 set id $diffmergeid
2854 set p [lindex $parents($id) $pnum]
2855 set ol [expr {$l + $diffoffset($p)}]
2856 set endl [expr {$l + $nlc}]
2857 set same 0
2858 set diff 0
2859 foreach e $events {
2860 if {[lindex $e 2] != $pnum} continue
2861 set nl [lindex $e 0]
2862 set ol [expr {$ol + $nl - $l}]
2863 for {} {$l < $nl} {incr l} {
2864 incr same [string length $filelines($id,$f,$l)]
2865 incr same
2867 set oc [lindex $e 3]
2868 for {} {$oc > 0} {incr oc -1} {
2869 incr diff [string length $filelines($p,$f,$ol)]
2870 incr diff
2871 incr ol
2873 set nl [lindex $e 1]
2874 for {} {$l < $nl} {incr l} {
2875 incr diff [string length $filelines($id,$f,$l)]
2876 incr diff
2879 for {} {$l < $endl} {incr l} {
2880 incr same [string length $filelines($id,$f,$l)]
2881 incr same
2883 if {$same == 0} {
2884 return 0
2886 return [expr {200 * $same / (2 * $same + $diff)}]
2889 proc startdiff {ids} {
2890 global treediffs diffids treepending diffmergeid
2892 set diffids $ids
2893 catch {unset diffmergeid}
2894 if {![info exists treediffs($ids)]} {
2895 if {![info exists treepending]} {
2896 gettreediffs $ids
2898 } else {
2899 addtocflist $ids
2903 proc addtocflist {ids} {
2904 global treediffs cflist
2905 foreach f $treediffs($ids) {
2906 $cflist insert end $f
2908 getblobdiffs $ids
2911 proc gettreediffs {ids} {
2912 global treediff parents treepending
2913 set treepending $ids
2914 set treediff {}
2915 if [catch {set gdtf [open [concat | git-diff-tree --no-commit-id -r $ids] r]}] return
2916 fconfigure $gdtf -blocking 0
2917 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2920 proc gettreediffline {gdtf ids} {
2921 global treediff treediffs treepending diffids diffmergeid
2923 set n [gets $gdtf line]
2924 if {$n < 0} {
2925 if {![eof $gdtf]} return
2926 close $gdtf
2927 set treediffs($ids) $treediff
2928 unset treepending
2929 if {$ids != $diffids} {
2930 gettreediffs $diffids
2931 } else {
2932 if {[info exists diffmergeid]} {
2933 contmergediff $ids
2934 } else {
2935 addtocflist $ids
2938 return
2940 set file [lindex $line 5]
2941 lappend treediff $file
2944 proc getblobdiffs {ids} {
2945 global diffopts blobdifffd diffids env curdifftag curtagstart
2946 global difffilestart nextupdate diffinhdr treediffs
2948 set env(GIT_DIFF_OPTS) $diffopts
2949 set cmd [concat | git-diff-tree --no-commit-id -r -p -C $ids]
2950 if {[catch {set bdf [open $cmd r]} err]} {
2951 puts "error getting diffs: $err"
2952 return
2954 set diffinhdr 0
2955 fconfigure $bdf -blocking 0
2956 set blobdifffd($ids) $bdf
2957 set curdifftag Comments
2958 set curtagstart 0.0
2959 catch {unset difffilestart}
2960 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2961 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
2964 proc getblobdiffline {bdf ids} {
2965 global diffids blobdifffd ctext curdifftag curtagstart
2966 global diffnexthead diffnextnote difffilestart
2967 global nextupdate diffinhdr treediffs
2969 set n [gets $bdf line]
2970 if {$n < 0} {
2971 if {[eof $bdf]} {
2972 close $bdf
2973 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
2974 $ctext tag add $curdifftag $curtagstart end
2977 return
2979 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
2980 return
2982 $ctext conf -state normal
2983 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
2984 # start of a new file
2985 $ctext insert end "\n"
2986 $ctext tag add $curdifftag $curtagstart end
2987 set curtagstart [$ctext index "end - 1c"]
2988 set header $newname
2989 set here [$ctext index "end - 1c"]
2990 set i [lsearch -exact $treediffs($diffids) $fname]
2991 if {$i >= 0} {
2992 set difffilestart($i) $here
2993 incr i
2994 $ctext mark set fmark.$i $here
2995 $ctext mark gravity fmark.$i left
2997 if {$newname != $fname} {
2998 set i [lsearch -exact $treediffs($diffids) $newname]
2999 if {$i >= 0} {
3000 set difffilestart($i) $here
3001 incr i
3002 $ctext mark set fmark.$i $here
3003 $ctext mark gravity fmark.$i left
3006 set curdifftag "f:$fname"
3007 $ctext tag delete $curdifftag
3008 set l [expr {(78 - [string length $header]) / 2}]
3009 set pad [string range "----------------------------------------" 1 $l]
3010 $ctext insert end "$pad $header $pad\n" filesep
3011 set diffinhdr 1
3012 } elseif {[regexp {^(---|\+\+\+)} $line]} {
3013 set diffinhdr 0
3014 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
3015 $line match f1l f1c f2l f2c rest]} {
3016 $ctext insert end "$line\n" hunksep
3017 set diffinhdr 0
3018 } else {
3019 set x [string range $line 0 0]
3020 if {$x == "-" || $x == "+"} {
3021 set tag [expr {$x == "+"}]
3022 $ctext insert end "$line\n" d$tag
3023 } elseif {$x == " "} {
3024 $ctext insert end "$line\n"
3025 } elseif {$diffinhdr || $x == "\\"} {
3026 # e.g. "\ No newline at end of file"
3027 $ctext insert end "$line\n" filesep
3028 } else {
3029 # Something else we don't recognize
3030 if {$curdifftag != "Comments"} {
3031 $ctext insert end "\n"
3032 $ctext tag add $curdifftag $curtagstart end
3033 set curtagstart [$ctext index "end - 1c"]
3034 set curdifftag Comments
3036 $ctext insert end "$line\n" filesep
3039 $ctext conf -state disabled
3040 if {[clock clicks -milliseconds] >= $nextupdate} {
3041 incr nextupdate 100
3042 fileevent $bdf readable {}
3043 update
3044 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
3048 proc nextfile {} {
3049 global difffilestart ctext
3050 set here [$ctext index @0,0]
3051 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
3052 if {[$ctext compare $difffilestart($i) > $here]} {
3053 if {![info exists pos]
3054 || [$ctext compare $difffilestart($i) < $pos]} {
3055 set pos $difffilestart($i)
3059 if {[info exists pos]} {
3060 $ctext yview $pos
3064 proc listboxsel {} {
3065 global ctext cflist currentid
3066 if {![info exists currentid]} return
3067 set sel [lsort [$cflist curselection]]
3068 if {$sel eq {}} return
3069 set first [lindex $sel 0]
3070 catch {$ctext yview fmark.$first}
3073 proc setcoords {} {
3074 global linespc charspc canvx0 canvy0 mainfont
3075 global xspc1 xspc2 lthickness
3077 set linespc [font metrics $mainfont -linespace]
3078 set charspc [font measure $mainfont "m"]
3079 set canvy0 [expr {3 + 0.5 * $linespc}]
3080 set canvx0 [expr {3 + 0.5 * $linespc}]
3081 set lthickness [expr {int($linespc / 9) + 1}]
3082 set xspc1(0) $linespc
3083 set xspc2 $linespc
3086 proc redisplay {} {
3087 global stopped redisplaying phase
3088 if {$stopped > 1} return
3089 if {$phase == "getcommits"} return
3090 set redisplaying 1
3091 if {$phase == "drawgraph" || $phase == "incrdraw"} {
3092 set stopped 1
3093 } else {
3094 drawgraph
3098 proc incrfont {inc} {
3099 global mainfont namefont textfont ctext canv phase
3100 global stopped entries
3101 unmarkmatches
3102 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
3103 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
3104 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
3105 setcoords
3106 $ctext conf -font $textfont
3107 $ctext tag conf filesep -font [concat $textfont bold]
3108 foreach e $entries {
3109 $e conf -font $mainfont
3111 if {$phase == "getcommits"} {
3112 $canv itemconf textitems -font $mainfont
3114 redisplay
3117 proc clearsha1 {} {
3118 global sha1entry sha1string
3119 if {[string length $sha1string] == 40} {
3120 $sha1entry delete 0 end
3124 proc sha1change {n1 n2 op} {
3125 global sha1string currentid sha1but
3126 if {$sha1string == {}
3127 || ([info exists currentid] && $sha1string == $currentid)} {
3128 set state disabled
3129 } else {
3130 set state normal
3132 if {[$sha1but cget -state] == $state} return
3133 if {$state == "normal"} {
3134 $sha1but conf -state normal -relief raised -text "Goto: "
3135 } else {
3136 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3140 proc gotocommit {} {
3141 global sha1string currentid idline tagids
3142 global lineid numcommits
3144 if {$sha1string == {}
3145 || ([info exists currentid] && $sha1string == $currentid)} return
3146 if {[info exists tagids($sha1string)]} {
3147 set id $tagids($sha1string)
3148 } else {
3149 set id [string tolower $sha1string]
3150 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3151 set matches {}
3152 for {set l 0} {$l < $numcommits} {incr l} {
3153 if {[string match $id* $lineid($l)]} {
3154 lappend matches $lineid($l)
3157 if {$matches ne {}} {
3158 if {[llength $matches] > 1} {
3159 error_popup "Short SHA1 id $id is ambiguous"
3160 return
3162 set id [lindex $matches 0]
3166 if {[info exists idline($id)]} {
3167 selectline $idline($id) 1
3168 return
3170 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
3171 set type "SHA1 id"
3172 } else {
3173 set type "Tag"
3175 error_popup "$type $sha1string is not known"
3178 proc lineenter {x y id} {
3179 global hoverx hovery hoverid hovertimer
3180 global commitinfo canv
3182 if {![info exists commitinfo($id)]} return
3183 set hoverx $x
3184 set hovery $y
3185 set hoverid $id
3186 if {[info exists hovertimer]} {
3187 after cancel $hovertimer
3189 set hovertimer [after 500 linehover]
3190 $canv delete hover
3193 proc linemotion {x y id} {
3194 global hoverx hovery hoverid hovertimer
3196 if {[info exists hoverid] && $id == $hoverid} {
3197 set hoverx $x
3198 set hovery $y
3199 if {[info exists hovertimer]} {
3200 after cancel $hovertimer
3202 set hovertimer [after 500 linehover]
3206 proc lineleave {id} {
3207 global hoverid hovertimer canv
3209 if {[info exists hoverid] && $id == $hoverid} {
3210 $canv delete hover
3211 if {[info exists hovertimer]} {
3212 after cancel $hovertimer
3213 unset hovertimer
3215 unset hoverid
3219 proc linehover {} {
3220 global hoverx hovery hoverid hovertimer
3221 global canv linespc lthickness
3222 global commitinfo mainfont
3224 set text [lindex $commitinfo($hoverid) 0]
3225 set ymax [lindex [$canv cget -scrollregion] 3]
3226 if {$ymax == {}} return
3227 set yfrac [lindex [$canv yview] 0]
3228 set x [expr {$hoverx + 2 * $linespc}]
3229 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3230 set x0 [expr {$x - 2 * $lthickness}]
3231 set y0 [expr {$y - 2 * $lthickness}]
3232 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3233 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3234 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3235 -fill \#ffff80 -outline black -width 1 -tags hover]
3236 $canv raise $t
3237 set t [$canv create text $x $y -anchor nw -text $text -tags hover -font $mainfont]
3238 $canv raise $t
3241 proc clickisonarrow {id y} {
3242 global mainline mainlinearrow sidelines lthickness
3244 set thresh [expr {2 * $lthickness + 6}]
3245 if {[info exists mainline($id)]} {
3246 if {$mainlinearrow($id) ne "none"} {
3247 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3248 return "up"
3252 if {[info exists sidelines($id)]} {
3253 foreach ls $sidelines($id) {
3254 set coords [lindex $ls 0]
3255 set arrow [lindex $ls 2]
3256 if {$arrow eq "first" || $arrow eq "both"} {
3257 if {abs([lindex $coords 1] - $y) < $thresh} {
3258 return "up"
3261 if {$arrow eq "last" || $arrow eq "both"} {
3262 if {abs([lindex $coords end] - $y) < $thresh} {
3263 return "down"
3268 return {}
3271 proc arrowjump {id dirn y} {
3272 global mainline sidelines canv canv2 canv3
3274 set yt {}
3275 if {$dirn eq "down"} {
3276 if {[info exists mainline($id)]} {
3277 set y1 [lindex $mainline($id) 1]
3278 if {$y1 > $y} {
3279 set yt $y1
3282 if {[info exists sidelines($id)]} {
3283 foreach ls $sidelines($id) {
3284 set y1 [lindex $ls 0 1]
3285 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3286 set yt $y1
3290 } else {
3291 if {[info exists sidelines($id)]} {
3292 foreach ls $sidelines($id) {
3293 set y1 [lindex $ls 0 end]
3294 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3295 set yt $y1
3300 if {$yt eq {}} return
3301 set ymax [lindex [$canv cget -scrollregion] 3]
3302 if {$ymax eq {} || $ymax <= 0} return
3303 set view [$canv yview]
3304 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3305 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3306 if {$yfrac < 0} {
3307 set yfrac 0
3309 $canv yview moveto $yfrac
3310 $canv2 yview moveto $yfrac
3311 $canv3 yview moveto $yfrac
3314 proc lineclick {x y id isnew} {
3315 global ctext commitinfo children cflist canv thickerline
3317 unmarkmatches
3318 unselectline
3319 normalline
3320 $canv delete hover
3321 # draw this line thicker than normal
3322 drawlines $id 1 1
3323 set thickerline $id
3324 if {$isnew} {
3325 set ymax [lindex [$canv cget -scrollregion] 3]
3326 if {$ymax eq {}} return
3327 set yfrac [lindex [$canv yview] 0]
3328 set y [expr {$y + $yfrac * $ymax}]
3330 set dirn [clickisonarrow $id $y]
3331 if {$dirn ne {}} {
3332 arrowjump $id $dirn $y
3333 return
3336 if {$isnew} {
3337 addtohistory [list lineclick $x $y $id 0]
3339 # fill the details pane with info about this line
3340 $ctext conf -state normal
3341 $ctext delete 0.0 end
3342 $ctext tag conf link -foreground blue -underline 1
3343 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3344 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3345 $ctext insert end "Parent:\t"
3346 $ctext insert end $id [list link link0]
3347 $ctext tag bind link0 <1> [list selbyid $id]
3348 set info $commitinfo($id)
3349 $ctext insert end "\n\t[lindex $info 0]\n"
3350 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3351 set date [formatdate [lindex $info 2]]
3352 $ctext insert end "\tDate:\t$date\n"
3353 if {[info exists children($id)]} {
3354 $ctext insert end "\nChildren:"
3355 set i 0
3356 foreach child $children($id) {
3357 incr i
3358 set info $commitinfo($child)
3359 $ctext insert end "\n\t"
3360 $ctext insert end $child [list link link$i]
3361 $ctext tag bind link$i <1> [list selbyid $child]
3362 $ctext insert end "\n\t[lindex $info 0]"
3363 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3364 set date [formatdate [lindex $info 2]]
3365 $ctext insert end "\n\tDate:\t$date\n"
3368 $ctext conf -state disabled
3370 $cflist delete 0 end
3373 proc normalline {} {
3374 global thickerline
3375 if {[info exists thickerline]} {
3376 drawlines $thickerline 0 1
3377 unset thickerline
3381 proc selbyid {id} {
3382 global idline
3383 if {[info exists idline($id)]} {
3384 selectline $idline($id) 1
3388 proc mstime {} {
3389 global startmstime
3390 if {![info exists startmstime]} {
3391 set startmstime [clock clicks -milliseconds]
3393 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3396 proc rowmenu {x y id} {
3397 global rowctxmenu idline selectedline rowmenuid
3399 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3400 set state disabled
3401 } else {
3402 set state normal
3404 $rowctxmenu entryconfigure 0 -state $state
3405 $rowctxmenu entryconfigure 1 -state $state
3406 $rowctxmenu entryconfigure 2 -state $state
3407 set rowmenuid $id
3408 tk_popup $rowctxmenu $x $y
3411 proc diffvssel {dirn} {
3412 global rowmenuid selectedline lineid
3414 if {![info exists selectedline]} return
3415 if {$dirn} {
3416 set oldid $lineid($selectedline)
3417 set newid $rowmenuid
3418 } else {
3419 set oldid $rowmenuid
3420 set newid $lineid($selectedline)
3422 addtohistory [list doseldiff $oldid $newid]
3423 doseldiff $oldid $newid
3426 proc doseldiff {oldid newid} {
3427 global ctext cflist
3428 global commitinfo
3430 $ctext conf -state normal
3431 $ctext delete 0.0 end
3432 $ctext mark set fmark.0 0.0
3433 $ctext mark gravity fmark.0 left
3434 $cflist delete 0 end
3435 $cflist insert end "Top"
3436 $ctext insert end "From "
3437 $ctext tag conf link -foreground blue -underline 1
3438 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3439 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3440 $ctext tag bind link0 <1> [list selbyid $oldid]
3441 $ctext insert end $oldid [list link link0]
3442 $ctext insert end "\n "
3443 $ctext insert end [lindex $commitinfo($oldid) 0]
3444 $ctext insert end "\n\nTo "
3445 $ctext tag bind link1 <1> [list selbyid $newid]
3446 $ctext insert end $newid [list link link1]
3447 $ctext insert end "\n "
3448 $ctext insert end [lindex $commitinfo($newid) 0]
3449 $ctext insert end "\n"
3450 $ctext conf -state disabled
3451 $ctext tag delete Comments
3452 $ctext tag remove found 1.0 end
3453 startdiff [list $oldid $newid]
3456 proc mkpatch {} {
3457 global rowmenuid currentid commitinfo patchtop patchnum
3459 if {![info exists currentid]} return
3460 set oldid $currentid
3461 set oldhead [lindex $commitinfo($oldid) 0]
3462 set newid $rowmenuid
3463 set newhead [lindex $commitinfo($newid) 0]
3464 set top .patch
3465 set patchtop $top
3466 catch {destroy $top}
3467 toplevel $top
3468 label $top.title -text "Generate patch"
3469 grid $top.title - -pady 10
3470 label $top.from -text "From:"
3471 entry $top.fromsha1 -width 40 -relief flat
3472 $top.fromsha1 insert 0 $oldid
3473 $top.fromsha1 conf -state readonly
3474 grid $top.from $top.fromsha1 -sticky w
3475 entry $top.fromhead -width 60 -relief flat
3476 $top.fromhead insert 0 $oldhead
3477 $top.fromhead conf -state readonly
3478 grid x $top.fromhead -sticky w
3479 label $top.to -text "To:"
3480 entry $top.tosha1 -width 40 -relief flat
3481 $top.tosha1 insert 0 $newid
3482 $top.tosha1 conf -state readonly
3483 grid $top.to $top.tosha1 -sticky w
3484 entry $top.tohead -width 60 -relief flat
3485 $top.tohead insert 0 $newhead
3486 $top.tohead conf -state readonly
3487 grid x $top.tohead -sticky w
3488 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3489 grid $top.rev x -pady 10
3490 label $top.flab -text "Output file:"
3491 entry $top.fname -width 60
3492 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3493 incr patchnum
3494 grid $top.flab $top.fname -sticky w
3495 frame $top.buts
3496 button $top.buts.gen -text "Generate" -command mkpatchgo
3497 button $top.buts.can -text "Cancel" -command mkpatchcan
3498 grid $top.buts.gen $top.buts.can
3499 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3500 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3501 grid $top.buts - -pady 10 -sticky ew
3502 focus $top.fname
3505 proc mkpatchrev {} {
3506 global patchtop
3508 set oldid [$patchtop.fromsha1 get]
3509 set oldhead [$patchtop.fromhead get]
3510 set newid [$patchtop.tosha1 get]
3511 set newhead [$patchtop.tohead get]
3512 foreach e [list fromsha1 fromhead tosha1 tohead] \
3513 v [list $newid $newhead $oldid $oldhead] {
3514 $patchtop.$e conf -state normal
3515 $patchtop.$e delete 0 end
3516 $patchtop.$e insert 0 $v
3517 $patchtop.$e conf -state readonly
3521 proc mkpatchgo {} {
3522 global patchtop
3524 set oldid [$patchtop.fromsha1 get]
3525 set newid [$patchtop.tosha1 get]
3526 set fname [$patchtop.fname get]
3527 if {[catch {exec git-diff-tree -p $oldid $newid >$fname &} err]} {
3528 error_popup "Error creating patch: $err"
3530 catch {destroy $patchtop}
3531 unset patchtop
3534 proc mkpatchcan {} {
3535 global patchtop
3537 catch {destroy $patchtop}
3538 unset patchtop
3541 proc mktag {} {
3542 global rowmenuid mktagtop commitinfo
3544 set top .maketag
3545 set mktagtop $top
3546 catch {destroy $top}
3547 toplevel $top
3548 label $top.title -text "Create tag"
3549 grid $top.title - -pady 10
3550 label $top.id -text "ID:"
3551 entry $top.sha1 -width 40 -relief flat
3552 $top.sha1 insert 0 $rowmenuid
3553 $top.sha1 conf -state readonly
3554 grid $top.id $top.sha1 -sticky w
3555 entry $top.head -width 60 -relief flat
3556 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3557 $top.head conf -state readonly
3558 grid x $top.head -sticky w
3559 label $top.tlab -text "Tag name:"
3560 entry $top.tag -width 60
3561 grid $top.tlab $top.tag -sticky w
3562 frame $top.buts
3563 button $top.buts.gen -text "Create" -command mktaggo
3564 button $top.buts.can -text "Cancel" -command mktagcan
3565 grid $top.buts.gen $top.buts.can
3566 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3567 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3568 grid $top.buts - -pady 10 -sticky ew
3569 focus $top.tag
3572 proc domktag {} {
3573 global mktagtop env tagids idtags
3575 set id [$mktagtop.sha1 get]
3576 set tag [$mktagtop.tag get]
3577 if {$tag == {}} {
3578 error_popup "No tag name specified"
3579 return
3581 if {[info exists tagids($tag)]} {
3582 error_popup "Tag \"$tag\" already exists"
3583 return
3585 if {[catch {
3586 set dir [gitdir]
3587 set fname [file join $dir "refs/tags" $tag]
3588 set f [open $fname w]
3589 puts $f $id
3590 close $f
3591 } err]} {
3592 error_popup "Error creating tag: $err"
3593 return
3596 set tagids($tag) $id
3597 lappend idtags($id) $tag
3598 redrawtags $id
3601 proc redrawtags {id} {
3602 global canv linehtag idline idpos selectedline
3604 if {![info exists idline($id)]} return
3605 $canv delete tag.$id
3606 set xt [eval drawtags $id $idpos($id)]
3607 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3608 if {[info exists selectedline] && $selectedline == $idline($id)} {
3609 selectline $selectedline 0
3613 proc mktagcan {} {
3614 global mktagtop
3616 catch {destroy $mktagtop}
3617 unset mktagtop
3620 proc mktaggo {} {
3621 domktag
3622 mktagcan
3625 proc writecommit {} {
3626 global rowmenuid wrcomtop commitinfo wrcomcmd
3628 set top .writecommit
3629 set wrcomtop $top
3630 catch {destroy $top}
3631 toplevel $top
3632 label $top.title -text "Write commit to file"
3633 grid $top.title - -pady 10
3634 label $top.id -text "ID:"
3635 entry $top.sha1 -width 40 -relief flat
3636 $top.sha1 insert 0 $rowmenuid
3637 $top.sha1 conf -state readonly
3638 grid $top.id $top.sha1 -sticky w
3639 entry $top.head -width 60 -relief flat
3640 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3641 $top.head conf -state readonly
3642 grid x $top.head -sticky w
3643 label $top.clab -text "Command:"
3644 entry $top.cmd -width 60 -textvariable wrcomcmd
3645 grid $top.clab $top.cmd -sticky w -pady 10
3646 label $top.flab -text "Output file:"
3647 entry $top.fname -width 60
3648 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3649 grid $top.flab $top.fname -sticky w
3650 frame $top.buts
3651 button $top.buts.gen -text "Write" -command wrcomgo
3652 button $top.buts.can -text "Cancel" -command wrcomcan
3653 grid $top.buts.gen $top.buts.can
3654 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3655 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3656 grid $top.buts - -pady 10 -sticky ew
3657 focus $top.fname
3660 proc wrcomgo {} {
3661 global wrcomtop
3663 set id [$wrcomtop.sha1 get]
3664 set cmd "echo $id | [$wrcomtop.cmd get]"
3665 set fname [$wrcomtop.fname get]
3666 if {[catch {exec sh -c $cmd >$fname &} err]} {
3667 error_popup "Error writing commit: $err"
3669 catch {destroy $wrcomtop}
3670 unset wrcomtop
3673 proc wrcomcan {} {
3674 global wrcomtop
3676 catch {destroy $wrcomtop}
3677 unset wrcomtop
3680 proc listrefs {id} {
3681 global idtags idheads idotherrefs
3683 set x {}
3684 if {[info exists idtags($id)]} {
3685 set x $idtags($id)
3687 set y {}
3688 if {[info exists idheads($id)]} {
3689 set y $idheads($id)
3691 set z {}
3692 if {[info exists idotherrefs($id)]} {
3693 set z $idotherrefs($id)
3695 return [list $x $y $z]
3698 proc rereadrefs {} {
3699 global idtags idheads idotherrefs
3700 global tagids headids otherrefids
3702 set refids [concat [array names idtags] \
3703 [array names idheads] [array names idotherrefs]]
3704 foreach id $refids {
3705 if {![info exists ref($id)]} {
3706 set ref($id) [listrefs $id]
3709 readrefs
3710 set refids [lsort -unique [concat $refids [array names idtags] \
3711 [array names idheads] [array names idotherrefs]]]
3712 foreach id $refids {
3713 set v [listrefs $id]
3714 if {![info exists ref($id)] || $ref($id) != $v} {
3715 redrawtags $id
3720 proc showtag {tag isnew} {
3721 global ctext cflist tagcontents tagids linknum
3723 if {$isnew} {
3724 addtohistory [list showtag $tag 0]
3726 $ctext conf -state normal
3727 $ctext delete 0.0 end
3728 set linknum 0
3729 if {[info exists tagcontents($tag)]} {
3730 set text $tagcontents($tag)
3731 } else {
3732 set text "Tag: $tag\nId: $tagids($tag)"
3734 appendwithlinks $text
3735 $ctext conf -state disabled
3736 $cflist delete 0 end
3739 proc doquit {} {
3740 global stopped
3741 set stopped 100
3742 destroy .
3745 proc doprefs {} {
3746 global maxwidth maxgraphpct diffopts findmergefiles
3747 global oldprefs prefstop
3749 set top .gitkprefs
3750 set prefstop $top
3751 if {[winfo exists $top]} {
3752 raise $top
3753 return
3755 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3756 set oldprefs($v) [set $v]
3758 toplevel $top
3759 wm title $top "Gitk preferences"
3760 label $top.ldisp -text "Commit list display options"
3761 grid $top.ldisp - -sticky w -pady 10
3762 label $top.spacer -text " "
3763 label $top.maxwidthl -text "Maximum graph width (lines)" \
3764 -font optionfont
3765 spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
3766 grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
3767 label $top.maxpctl -text "Maximum graph width (% of pane)" \
3768 -font optionfont
3769 spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
3770 grid x $top.maxpctl $top.maxpct -sticky w
3771 checkbutton $top.findm -variable findmergefiles
3772 label $top.findml -text "Include merges for \"Find\" in \"Files\"" \
3773 -font optionfont
3774 grid $top.findm $top.findml - -sticky w
3775 label $top.ddisp -text "Diff display options"
3776 grid $top.ddisp - -sticky w -pady 10
3777 label $top.diffoptl -text "Options for diff program" \
3778 -font optionfont
3779 entry $top.diffopt -width 20 -textvariable diffopts
3780 grid x $top.diffoptl $top.diffopt -sticky w
3781 frame $top.buts
3782 button $top.buts.ok -text "OK" -command prefsok
3783 button $top.buts.can -text "Cancel" -command prefscan
3784 grid $top.buts.ok $top.buts.can
3785 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3786 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3787 grid $top.buts - - -pady 10 -sticky ew
3790 proc prefscan {} {
3791 global maxwidth maxgraphpct diffopts findmergefiles
3792 global oldprefs prefstop
3794 foreach v {maxwidth maxgraphpct diffopts findmergefiles} {
3795 set $v $oldprefs($v)
3797 catch {destroy $prefstop}
3798 unset prefstop
3801 proc prefsok {} {
3802 global maxwidth maxgraphpct
3803 global oldprefs prefstop
3805 catch {destroy $prefstop}
3806 unset prefstop
3807 if {$maxwidth != $oldprefs(maxwidth)
3808 || $maxgraphpct != $oldprefs(maxgraphpct)} {
3809 redisplay
3813 proc formatdate {d} {
3814 return [clock format $d -format "%Y-%m-%d %H:%M:%S"]
3817 # This list of encoding names and aliases is distilled from
3818 # http://www.iana.org/assignments/character-sets.
3819 # Not all of them are supported by Tcl.
3820 set encoding_aliases {
3821 { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
3822 ISO646-US US-ASCII us IBM367 cp367 csASCII }
3823 { ISO-10646-UTF-1 csISO10646UTF1 }
3824 { ISO_646.basic:1983 ref csISO646basic1983 }
3825 { INVARIANT csINVARIANT }
3826 { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
3827 { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
3828 { NATS-SEFI iso-ir-8-1 csNATSSEFI }
3829 { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
3830 { NATS-DANO iso-ir-9-1 csNATSDANO }
3831 { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
3832 { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
3833 { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
3834 { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
3835 { ISO-2022-KR csISO2022KR }
3836 { EUC-KR csEUCKR }
3837 { ISO-2022-JP csISO2022JP }
3838 { ISO-2022-JP-2 csISO2022JP2 }
3839 { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
3840 csISO13JISC6220jp }
3841 { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
3842 { IT iso-ir-15 ISO646-IT csISO15Italian }
3843 { PT iso-ir-16 ISO646-PT csISO16Portuguese }
3844 { ES iso-ir-17 ISO646-ES csISO17Spanish }
3845 { greek7-old iso-ir-18 csISO18Greek7Old }
3846 { latin-greek iso-ir-19 csISO19LatinGreek }
3847 { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
3848 { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
3849 { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
3850 { ISO_5427 iso-ir-37 csISO5427Cyrillic }
3851 { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
3852 { BS_viewdata iso-ir-47 csISO47BSViewdata }
3853 { INIS iso-ir-49 csISO49INIS }
3854 { INIS-8 iso-ir-50 csISO50INIS8 }
3855 { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
3856 { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
3857 { ISO_5428:1980 iso-ir-55 csISO5428Greek }
3858 { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
3859 { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
3860 { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
3861 csISO60Norwegian1 }
3862 { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
3863 { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
3864 { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
3865 { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
3866 { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
3867 { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
3868 { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
3869 { greek7 iso-ir-88 csISO88Greek7 }
3870 { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
3871 { iso-ir-90 csISO90 }
3872 { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
3873 { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
3874 csISO92JISC62991984b }
3875 { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
3876 { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
3877 { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
3878 csISO95JIS62291984handadd }
3879 { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
3880 { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
3881 { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
3882 { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
3883 CP819 csISOLatin1 }
3884 { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
3885 { T.61-7bit iso-ir-102 csISO102T617bit }
3886 { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
3887 { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
3888 { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
3889 { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
3890 { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
3891 { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
3892 { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
3893 { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
3894 arabic csISOLatinArabic }
3895 { ISO_8859-6-E csISO88596E ISO-8859-6-E }
3896 { ISO_8859-6-I csISO88596I ISO-8859-6-I }
3897 { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
3898 greek greek8 csISOLatinGreek }
3899 { T.101-G2 iso-ir-128 csISO128T101G2 }
3900 { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
3901 csISOLatinHebrew }
3902 { ISO_8859-8-E csISO88598E ISO-8859-8-E }
3903 { ISO_8859-8-I csISO88598I ISO-8859-8-I }
3904 { CSN_369103 iso-ir-139 csISO139CSN369103 }
3905 { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
3906 { ISO_6937-2-add iso-ir-142 csISOTextComm }
3907 { IEC_P27-1 iso-ir-143 csISO143IECP271 }
3908 { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
3909 csISOLatinCyrillic }
3910 { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
3911 { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
3912 { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
3913 { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
3914 { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
3915 { ISO_6937-2-25 iso-ir-152 csISO6937Add }
3916 { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
3917 { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
3918 { ISO_10367-box iso-ir-155 csISO10367Box }
3919 { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
3920 { latin-lap lap iso-ir-158 csISO158Lap }
3921 { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
3922 { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
3923 { us-dk csUSDK }
3924 { dk-us csDKUS }
3925 { JIS_X0201 X0201 csHalfWidthKatakana }
3926 { KSC5636 ISO646-KR csKSC5636 }
3927 { ISO-10646-UCS-2 csUnicode }
3928 { ISO-10646-UCS-4 csUCS4 }
3929 { DEC-MCS dec csDECMCS }
3930 { hp-roman8 roman8 r8 csHPRoman8 }
3931 { macintosh mac csMacintosh }
3932 { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
3933 csIBM037 }
3934 { IBM038 EBCDIC-INT cp038 csIBM038 }
3935 { IBM273 CP273 csIBM273 }
3936 { IBM274 EBCDIC-BE CP274 csIBM274 }
3937 { IBM275 EBCDIC-BR cp275 csIBM275 }
3938 { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
3939 { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
3940 { IBM280 CP280 ebcdic-cp-it csIBM280 }
3941 { IBM281 EBCDIC-JP-E cp281 csIBM281 }
3942 { IBM284 CP284 ebcdic-cp-es csIBM284 }
3943 { IBM285 CP285 ebcdic-cp-gb csIBM285 }
3944 { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
3945 { IBM297 cp297 ebcdic-cp-fr csIBM297 }
3946 { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
3947 { IBM423 cp423 ebcdic-cp-gr csIBM423 }
3948 { IBM424 cp424 ebcdic-cp-he csIBM424 }
3949 { IBM437 cp437 437 csPC8CodePage437 }
3950 { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
3951 { IBM775 cp775 csPC775Baltic }
3952 { IBM850 cp850 850 csPC850Multilingual }
3953 { IBM851 cp851 851 csIBM851 }
3954 { IBM852 cp852 852 csPCp852 }
3955 { IBM855 cp855 855 csIBM855 }
3956 { IBM857 cp857 857 csIBM857 }
3957 { IBM860 cp860 860 csIBM860 }
3958 { IBM861 cp861 861 cp-is csIBM861 }
3959 { IBM862 cp862 862 csPC862LatinHebrew }
3960 { IBM863 cp863 863 csIBM863 }
3961 { IBM864 cp864 csIBM864 }
3962 { IBM865 cp865 865 csIBM865 }
3963 { IBM866 cp866 866 csIBM866 }
3964 { IBM868 CP868 cp-ar csIBM868 }
3965 { IBM869 cp869 869 cp-gr csIBM869 }
3966 { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
3967 { IBM871 CP871 ebcdic-cp-is csIBM871 }
3968 { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
3969 { IBM891 cp891 csIBM891 }
3970 { IBM903 cp903 csIBM903 }
3971 { IBM904 cp904 904 csIBBM904 }
3972 { IBM905 CP905 ebcdic-cp-tr csIBM905 }
3973 { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
3974 { IBM1026 CP1026 csIBM1026 }
3975 { EBCDIC-AT-DE csIBMEBCDICATDE }
3976 { EBCDIC-AT-DE-A csEBCDICATDEA }
3977 { EBCDIC-CA-FR csEBCDICCAFR }
3978 { EBCDIC-DK-NO csEBCDICDKNO }
3979 { EBCDIC-DK-NO-A csEBCDICDKNOA }
3980 { EBCDIC-FI-SE csEBCDICFISE }
3981 { EBCDIC-FI-SE-A csEBCDICFISEA }
3982 { EBCDIC-FR csEBCDICFR }
3983 { EBCDIC-IT csEBCDICIT }
3984 { EBCDIC-PT csEBCDICPT }
3985 { EBCDIC-ES csEBCDICES }
3986 { EBCDIC-ES-A csEBCDICESA }
3987 { EBCDIC-ES-S csEBCDICESS }
3988 { EBCDIC-UK csEBCDICUK }
3989 { EBCDIC-US csEBCDICUS }
3990 { UNKNOWN-8BIT csUnknown8BiT }
3991 { MNEMONIC csMnemonic }
3992 { MNEM csMnem }
3993 { VISCII csVISCII }
3994 { VIQR csVIQR }
3995 { KOI8-R csKOI8R }
3996 { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
3997 { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
3998 { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
3999 { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
4000 { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
4001 { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
4002 { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
4003 { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
4004 { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
4005 { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
4006 { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
4007 { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
4008 { IBM1047 IBM-1047 }
4009 { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
4010 { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
4011 { UNICODE-1-1 csUnicode11 }
4012 { CESU-8 csCESU-8 }
4013 { BOCU-1 csBOCU-1 }
4014 { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
4015 { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
4016 l8 }
4017 { ISO-8859-15 ISO_8859-15 Latin-9 }
4018 { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
4019 { GBK CP936 MS936 windows-936 }
4020 { JIS_Encoding csJISEncoding }
4021 { Shift_JIS MS_Kanji csShiftJIS }
4022 { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
4023 EUC-JP }
4024 { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
4025 { ISO-10646-UCS-Basic csUnicodeASCII }
4026 { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
4027 { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
4028 { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
4029 { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
4030 { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
4031 { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
4032 { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
4033 { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
4034 { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
4035 { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
4036 { Adobe-Standard-Encoding csAdobeStandardEncoding }
4037 { Ventura-US csVenturaUS }
4038 { Ventura-International csVenturaInternational }
4039 { PC8-Danish-Norwegian csPC8DanishNorwegian }
4040 { PC8-Turkish csPC8Turkish }
4041 { IBM-Symbols csIBMSymbols }
4042 { IBM-Thai csIBMThai }
4043 { HP-Legal csHPLegal }
4044 { HP-Pi-font csHPPiFont }
4045 { HP-Math8 csHPMath8 }
4046 { Adobe-Symbol-Encoding csHPPSMath }
4047 { HP-DeskTop csHPDesktop }
4048 { Ventura-Math csVenturaMath }
4049 { Microsoft-Publishing csMicrosoftPublishing }
4050 { Windows-31J csWindows31J }
4051 { GB2312 csGB2312 }
4052 { Big5 csBig5 }
4055 proc tcl_encoding {enc} {
4056 global encoding_aliases
4057 set names [encoding names]
4058 set lcnames [string tolower $names]
4059 set enc [string tolower $enc]
4060 set i [lsearch -exact $lcnames $enc]
4061 if {$i < 0} {
4062 # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
4063 if {[regsub {^iso[-_]} $enc iso encx]} {
4064 set i [lsearch -exact $lcnames $encx]
4067 if {$i < 0} {
4068 foreach l $encoding_aliases {
4069 set ll [string tolower $l]
4070 if {[lsearch -exact $ll $enc] < 0} continue
4071 # look through the aliases for one that tcl knows about
4072 foreach e $ll {
4073 set i [lsearch -exact $lcnames $e]
4074 if {$i < 0} {
4075 if {[regsub {^iso[-_]} $e iso ex]} {
4076 set i [lsearch -exact $lcnames $ex]
4079 if {$i >= 0} break
4081 break
4084 if {$i >= 0} {
4085 return [lindex $names $i]
4087 return {}
4090 # defaults...
4091 set datemode 0
4092 set diffopts "-U 5 -p"
4093 set wrcomcmd "git-diff-tree --stdin -p --pretty"
4095 set gitencoding {}
4096 catch {
4097 set gitencoding [exec git-repo-config --get i18n.commitencoding]
4099 if {$gitencoding == ""} {
4100 set gitencoding "utf-8"
4102 set tclencoding [tcl_encoding $gitencoding]
4103 if {$tclencoding == {}} {
4104 puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
4107 set mainfont {Helvetica 9}
4108 set textfont {Courier 9}
4109 set findmergefiles 0
4110 set maxgraphpct 50
4111 set maxwidth 16
4112 set revlistorder 0
4113 set fastdate 0
4115 set colors {green red blue magenta darkgrey brown orange}
4117 catch {source ~/.gitk}
4119 set namefont $mainfont
4121 font create optionfont -family sans-serif -size -12
4123 set revtreeargs {}
4124 foreach arg $argv {
4125 switch -regexp -- $arg {
4126 "^$" { }
4127 "^-d" { set datemode 1 }
4128 "^-r" { set revlistorder 1 }
4129 default {
4130 lappend revtreeargs $arg
4135 set history {}
4136 set historyindex 0
4138 set stopped 0
4139 set redisplaying 0
4140 set stuffsaved 0
4141 set patchnum 0
4142 setcoords
4143 makewindow $revtreeargs
4144 readrefs
4145 getcommits $revtreeargs