Code

gitk: Use the UI font for the diff/old version/new version radio buttons
[git.git] / gitk
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "$@"
5 # Copyright (C) 2005-2006 Paul Mackerras.  All rights reserved.
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
10 proc gitdir {} {
11     global env
12     if {[info exists env(GIT_DIR)]} {
13         return $env(GIT_DIR)
14     } else {
15         return [exec git rev-parse --git-dir]
16     }
17 }
19 # A simple scheduler for compute-intensive stuff.
20 # The aim is to make sure that event handlers for GUI actions can
21 # run at least every 50-100 ms.  Unfortunately fileevent handlers are
22 # run before X event handlers, so reading from a fast source can
23 # make the GUI completely unresponsive.
24 proc run args {
25     global isonrunq runq
27     set script $args
28     if {[info exists isonrunq($script)]} return
29     if {$runq eq {}} {
30         after idle dorunq
31     }
32     lappend runq [list {} $script]
33     set isonrunq($script) 1
34 }
36 proc filerun {fd script} {
37     fileevent $fd readable [list filereadable $fd $script]
38 }
40 proc filereadable {fd script} {
41     global runq
43     fileevent $fd readable {}
44     if {$runq eq {}} {
45         after idle dorunq
46     }
47     lappend runq [list $fd $script]
48 }
50 proc dorunq {} {
51     global isonrunq runq
53     set tstart [clock clicks -milliseconds]
54     set t0 $tstart
55     while {$runq ne {}} {
56         set fd [lindex $runq 0 0]
57         set script [lindex $runq 0 1]
58         set repeat [eval $script]
59         set t1 [clock clicks -milliseconds]
60         set t [expr {$t1 - $t0}]
61         set runq [lrange $runq 1 end]
62         if {$repeat ne {} && $repeat} {
63             if {$fd eq {} || $repeat == 2} {
64                 # script returns 1 if it wants to be readded
65                 # file readers return 2 if they could do more straight away
66                 lappend runq [list $fd $script]
67             } else {
68                 fileevent $fd readable [list filereadable $fd $script]
69             }
70         } elseif {$fd eq {}} {
71             unset isonrunq($script)
72         }
73         set t0 $t1
74         if {$t1 - $tstart >= 80} break
75     }
76     if {$runq ne {}} {
77         after idle dorunq
78     }
79 }
81 # Start off a git rev-list process and arrange to read its output
82 proc start_rev_list {view} {
83     global startmsecs
84     global commfd leftover tclencoding datemode
85     global viewargs viewfiles commitidx viewcomplete vnextroot
86     global showlocalchanges commitinterest mainheadid
87     global progressdirn progresscoords proglastnc curview
89     set startmsecs [clock clicks -milliseconds]
90     set commitidx($view) 0
91     set viewcomplete($view) 0
92     set vnextroot($view) 0
93     set order "--topo-order"
94     if {$datemode} {
95         set order "--date-order"
96     }
97     if {[catch {
98         set fd [open [concat | git log --no-color -z --pretty=raw $order --parents \
99                          --boundary $viewargs($view) "--" $viewfiles($view)] r]
100     } err]} {
101         error_popup "Error executing git rev-list: $err"
102         exit 1
103     }
104     set commfd($view) $fd
105     set leftover($view) {}
106     if {$showlocalchanges} {
107         lappend commitinterest($mainheadid) {dodiffindex}
108     }
109     fconfigure $fd -blocking 0 -translation lf -eofchar {}
110     if {$tclencoding != {}} {
111         fconfigure $fd -encoding $tclencoding
112     }
113     filerun $fd [list getcommitlines $fd $view]
114     nowbusy $view "Reading"
115     if {$view == $curview} {
116         set progressdirn 1
117         set progresscoords {0 0}
118         set proglastnc 0
119     }
122 proc stop_rev_list {} {
123     global commfd curview
125     if {![info exists commfd($curview)]} return
126     set fd $commfd($curview)
127     catch {
128         set pid [pid $fd]
129         exec kill $pid
130     }
131     catch {close $fd}
132     unset commfd($curview)
135 proc getcommits {} {
136     global phase canv curview
138     set phase getcommits
139     initlayout
140     start_rev_list $curview
141     show_status "Reading commits..."
144 # This makes a string representation of a positive integer which
145 # sorts as a string in numerical order
146 proc strrep {n} {
147     if {$n < 16} {
148         return [format "%x" $n]
149     } elseif {$n < 256} {
150         return [format "x%.2x" $n]
151     } elseif {$n < 65536} {
152         return [format "y%.4x" $n]
153     }
154     return [format "z%.8x" $n]
157 proc getcommitlines {fd view}  {
158     global commitlisted commitinterest
159     global leftover commfd
160     global displayorder commitidx viewcomplete commitrow commitdata
161     global parentlist children curview hlview
162     global vparentlist vdisporder vcmitlisted
163     global ordertok vnextroot idpending
165     set stuff [read $fd 500000]
166     # git log doesn't terminate the last commit with a null...
167     if {$stuff == {} && $leftover($view) ne {} && [eof $fd]} {
168         set stuff "\0"
169     }
170     if {$stuff == {}} {
171         if {![eof $fd]} {
172             return 1
173         }
174         # Check if we have seen any ids listed as parents that haven't
175         # appeared in the list
176         foreach vid [array names idpending "$view,*"] {
177             # should only get here if git log is buggy
178             set id [lindex [split $vid ","] 1]
179             set commitrow($vid) $commitidx($view)
180             incr commitidx($view)
181             if {$view == $curview} {
182                 lappend parentlist {}
183                 lappend displayorder $id
184                 lappend commitlisted 0
185             } else {
186                 lappend vparentlist($view) {}
187                 lappend vdisporder($view) $id
188                 lappend vcmitlisted($view) 0
189             }
190         }
191         set viewcomplete($view) 1
192         global viewname progresscoords
193         unset commfd($view)
194         notbusy $view
195         set progresscoords {0 0}
196         adjustprogress
197         # set it blocking so we wait for the process to terminate
198         fconfigure $fd -blocking 1
199         if {[catch {close $fd} err]} {
200             set fv {}
201             if {$view != $curview} {
202                 set fv " for the \"$viewname($view)\" view"
203             }
204             if {[string range $err 0 4] == "usage"} {
205                 set err "Gitk: error reading commits$fv:\
206                         bad arguments to git rev-list."
207                 if {$viewname($view) eq "Command line"} {
208                     append err \
209                         "  (Note: arguments to gitk are passed to git rev-list\
210                          to allow selection of commits to be displayed.)"
211                 }
212             } else {
213                 set err "Error reading commits$fv: $err"
214             }
215             error_popup $err
216         }
217         if {$view == $curview} {
218             run chewcommits $view
219         }
220         return 0
221     }
222     set start 0
223     set gotsome 0
224     while 1 {
225         set i [string first "\0" $stuff $start]
226         if {$i < 0} {
227             append leftover($view) [string range $stuff $start end]
228             break
229         }
230         if {$start == 0} {
231             set cmit $leftover($view)
232             append cmit [string range $stuff 0 [expr {$i - 1}]]
233             set leftover($view) {}
234         } else {
235             set cmit [string range $stuff $start [expr {$i - 1}]]
236         }
237         set start [expr {$i + 1}]
238         set j [string first "\n" $cmit]
239         set ok 0
240         set listed 1
241         if {$j >= 0 && [string match "commit *" $cmit]} {
242             set ids [string range $cmit 7 [expr {$j - 1}]]
243             if {[string match {[-<>]*} $ids]} {
244                 switch -- [string index $ids 0] {
245                     "-" {set listed 0}
246                     "<" {set listed 2}
247                     ">" {set listed 3}
248                 }
249                 set ids [string range $ids 1 end]
250             }
251             set ok 1
252             foreach id $ids {
253                 if {[string length $id] != 40} {
254                     set ok 0
255                     break
256                 }
257             }
258         }
259         if {!$ok} {
260             set shortcmit $cmit
261             if {[string length $shortcmit] > 80} {
262                 set shortcmit "[string range $shortcmit 0 80]..."
263             }
264             error_popup "Can't parse git log output: {$shortcmit}"
265             exit 1
266         }
267         set id [lindex $ids 0]
268         if {![info exists ordertok($view,$id)]} {
269             set otok "o[strrep $vnextroot($view)]"
270             incr vnextroot($view)
271             set ordertok($view,$id) $otok
272         } else {
273             set otok $ordertok($view,$id)
274             unset idpending($view,$id)
275         }
276         if {$listed} {
277             set olds [lrange $ids 1 end]
278             if {[llength $olds] == 1} {
279                 set p [lindex $olds 0]
280                 lappend children($view,$p) $id
281                 if {![info exists ordertok($view,$p)]} {
282                     set ordertok($view,$p) $ordertok($view,$id)
283                     set idpending($view,$p) 1
284                 }
285             } else {
286                 set i 0
287                 foreach p $olds {
288                     if {$i == 0 || [lsearch -exact $olds $p] >= $i} {
289                         lappend children($view,$p) $id
290                     }
291                     if {![info exists ordertok($view,$p)]} {
292                         set ordertok($view,$p) "$otok[strrep $i]]"
293                         set idpending($view,$p) 1
294                     }
295                     incr i
296                 }
297             }
298         } else {
299             set olds {}
300         }
301         if {![info exists children($view,$id)]} {
302             set children($view,$id) {}
303         }
304         set commitdata($id) [string range $cmit [expr {$j + 1}] end]
305         set commitrow($view,$id) $commitidx($view)
306         incr commitidx($view)
307         if {$view == $curview} {
308             lappend parentlist $olds
309             lappend displayorder $id
310             lappend commitlisted $listed
311         } else {
312             lappend vparentlist($view) $olds
313             lappend vdisporder($view) $id
314             lappend vcmitlisted($view) $listed
315         }
316         if {[info exists commitinterest($id)]} {
317             foreach script $commitinterest($id) {
318                 eval [string map [list "%I" $id] $script]
319             }
320             unset commitinterest($id)
321         }
322         set gotsome 1
323     }
324     if {$gotsome} {
325         run chewcommits $view
326         if {$view == $curview} {
327             # update progress bar
328             global progressdirn progresscoords proglastnc
329             set inc [expr {($commitidx($view) - $proglastnc) * 0.0002}]
330             set proglastnc $commitidx($view)
331             set l [lindex $progresscoords 0]
332             set r [lindex $progresscoords 1]
333             if {$progressdirn} {
334                 set r [expr {$r + $inc}]
335                 if {$r >= 1.0} {
336                     set r 1.0
337                     set progressdirn 0
338                 }
339                 if {$r > 0.2} {
340                     set l [expr {$r - 0.2}]
341                 }
342             } else {
343                 set l [expr {$l - $inc}]
344                 if {$l <= 0.0} {
345                     set l 0.0
346                     set progressdirn 1
347                 }
348                 set r [expr {$l + 0.2}]
349             }
350             set progresscoords [list $l $r]
351             adjustprogress
352         }
353     }
354     return 2
357 proc chewcommits {view} {
358     global curview hlview viewcomplete
359     global selectedline pending_select
361     if {$view == $curview} {
362         layoutmore
363         if {$viewcomplete($view)} {
364             global displayorder commitidx phase
365             global numcommits startmsecs
367             if {[info exists pending_select]} {
368                 set row [first_real_row]
369                 selectline $row 1
370             }
371             if {$commitidx($curview) > 0} {
372                 #set ms [expr {[clock clicks -milliseconds] - $startmsecs}]
373                 #puts "overall $ms ms for $numcommits commits"
374             } else {
375                 show_status "No commits selected"
376             }
377             notbusy layout
378             set phase {}
379         }
380     }
381     if {[info exists hlview] && $view == $hlview} {
382         vhighlightmore
383     }
384     return 0
387 proc readcommit {id} {
388     if {[catch {set contents [exec git cat-file commit $id]}]} return
389     parsecommit $id $contents 0
392 proc updatecommits {} {
393     global viewdata curview phase displayorder ordertok idpending
394     global children commitrow selectedline thickerline showneartags
396     if {$phase ne {}} {
397         stop_rev_list
398         set phase {}
399     }
400     set n $curview
401     foreach id $displayorder {
402         catch {unset children($n,$id)}
403         catch {unset commitrow($n,$id)}
404         catch {unset ordertok($n,$id)}
405     }
406     foreach vid [array names idpending "$n,*"] {
407         unset idpending($vid)
408     }
409     set curview -1
410     catch {unset selectedline}
411     catch {unset thickerline}
412     catch {unset viewdata($n)}
413     readrefs
414     changedrefs
415     if {$showneartags} {
416         getallcommits
417     }
418     showview $n
421 proc parsecommit {id contents listed} {
422     global commitinfo cdate
424     set inhdr 1
425     set comment {}
426     set headline {}
427     set auname {}
428     set audate {}
429     set comname {}
430     set comdate {}
431     set hdrend [string first "\n\n" $contents]
432     if {$hdrend < 0} {
433         # should never happen...
434         set hdrend [string length $contents]
435     }
436     set header [string range $contents 0 [expr {$hdrend - 1}]]
437     set comment [string range $contents [expr {$hdrend + 2}] end]
438     foreach line [split $header "\n"] {
439         set tag [lindex $line 0]
440         if {$tag == "author"} {
441             set audate [lindex $line end-1]
442             set auname [lrange $line 1 end-2]
443         } elseif {$tag == "committer"} {
444             set comdate [lindex $line end-1]
445             set comname [lrange $line 1 end-2]
446         }
447     }
448     set headline {}
449     # take the first non-blank line of the comment as the headline
450     set headline [string trimleft $comment]
451     set i [string first "\n" $headline]
452     if {$i >= 0} {
453         set headline [string range $headline 0 $i]
454     }
455     set headline [string trimright $headline]
456     set i [string first "\r" $headline]
457     if {$i >= 0} {
458         set headline [string trimright [string range $headline 0 $i]]
459     }
460     if {!$listed} {
461         # git rev-list indents the comment by 4 spaces;
462         # if we got this via git cat-file, add the indentation
463         set newcomment {}
464         foreach line [split $comment "\n"] {
465             append newcomment "    "
466             append newcomment $line
467             append newcomment "\n"
468         }
469         set comment $newcomment
470     }
471     if {$comdate != {}} {
472         set cdate($id) $comdate
473     }
474     set commitinfo($id) [list $headline $auname $audate \
475                              $comname $comdate $comment]
478 proc getcommit {id} {
479     global commitdata commitinfo
481     if {[info exists commitdata($id)]} {
482         parsecommit $id $commitdata($id) 1
483     } else {
484         readcommit $id
485         if {![info exists commitinfo($id)]} {
486             set commitinfo($id) {"No commit information available"}
487         }
488     }
489     return 1
492 proc readrefs {} {
493     global tagids idtags headids idheads tagobjid
494     global otherrefids idotherrefs mainhead mainheadid
496     foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
497         catch {unset $v}
498     }
499     set refd [open [list | git show-ref -d] r]
500     while {[gets $refd line] >= 0} {
501         if {[string index $line 40] ne " "} continue
502         set id [string range $line 0 39]
503         set ref [string range $line 41 end]
504         if {![string match "refs/*" $ref]} continue
505         set name [string range $ref 5 end]
506         if {[string match "remotes/*" $name]} {
507             if {![string match "*/HEAD" $name]} {
508                 set headids($name) $id
509                 lappend idheads($id) $name
510             }
511         } elseif {[string match "heads/*" $name]} {
512             set name [string range $name 6 end]
513             set headids($name) $id
514             lappend idheads($id) $name
515         } elseif {[string match "tags/*" $name]} {
516             # this lets refs/tags/foo^{} overwrite refs/tags/foo,
517             # which is what we want since the former is the commit ID
518             set name [string range $name 5 end]
519             if {[string match "*^{}" $name]} {
520                 set name [string range $name 0 end-3]
521             } else {
522                 set tagobjid($name) $id
523             }
524             set tagids($name) $id
525             lappend idtags($id) $name
526         } else {
527             set otherrefids($name) $id
528             lappend idotherrefs($id) $name
529         }
530     }
531     catch {close $refd}
532     set mainhead {}
533     set mainheadid {}
534     catch {
535         set thehead [exec git symbolic-ref HEAD]
536         if {[string match "refs/heads/*" $thehead]} {
537             set mainhead [string range $thehead 11 end]
538             if {[info exists headids($mainhead)]} {
539                 set mainheadid $headids($mainhead)
540             }
541         }
542     }
545 # skip over fake commits
546 proc first_real_row {} {
547     global nullid nullid2 displayorder numcommits
549     for {set row 0} {$row < $numcommits} {incr row} {
550         set id [lindex $displayorder $row]
551         if {$id ne $nullid && $id ne $nullid2} {
552             break
553         }
554     }
555     return $row
558 # update things for a head moved to a child of its previous location
559 proc movehead {id name} {
560     global headids idheads
562     removehead $headids($name) $name
563     set headids($name) $id
564     lappend idheads($id) $name
567 # update things when a head has been removed
568 proc removehead {id name} {
569     global headids idheads
571     if {$idheads($id) eq $name} {
572         unset idheads($id)
573     } else {
574         set i [lsearch -exact $idheads($id) $name]
575         if {$i >= 0} {
576             set idheads($id) [lreplace $idheads($id) $i $i]
577         }
578     }
579     unset headids($name)
582 proc show_error {w top msg} {
583     message $w.m -text $msg -justify center -aspect 400
584     pack $w.m -side top -fill x -padx 20 -pady 20
585     button $w.ok -text OK -command "destroy $top"
586     pack $w.ok -side bottom -fill x
587     bind $top <Visibility> "grab $top; focus $top"
588     bind $top <Key-Return> "destroy $top"
589     tkwait window $top
592 proc error_popup msg {
593     set w .error
594     toplevel $w
595     wm transient $w .
596     show_error $w $w $msg
599 proc confirm_popup msg {
600     global confirm_ok
601     set confirm_ok 0
602     set w .confirm
603     toplevel $w
604     wm transient $w .
605     message $w.m -text $msg -justify center -aspect 400
606     pack $w.m -side top -fill x -padx 20 -pady 20
607     button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
608     pack $w.ok -side left -fill x
609     button $w.cancel -text Cancel -command "destroy $w"
610     pack $w.cancel -side right -fill x
611     bind $w <Visibility> "grab $w; focus $w"
612     tkwait window $w
613     return $confirm_ok
616 proc makewindow {} {
617     global canv canv2 canv3 linespc charspc ctext cflist
618     global tabstop
619     global findtype findtypemenu findloc findstring fstring geometry
620     global entries sha1entry sha1string sha1but
621     global diffcontextstring diffcontext
622     global maincursor textcursor curtextcursor
623     global rowctxmenu fakerowmenu mergemax wrapcomment
624     global highlight_files gdttype
625     global searchstring sstring
626     global bgcolor fgcolor bglist fglist diffcolors selectbgcolor
627     global headctxmenu progresscanv progressitem progresscoords statusw
628     global fprogitem fprogcoord lastprogupdate progupdatepending
629     global rprogitem rprogcoord
630     global have_tk85
632     menu .bar
633     .bar add cascade -label "File" -menu .bar.file
634     .bar configure -font uifont
635     menu .bar.file
636     .bar.file add command -label "Update" -command updatecommits
637     .bar.file add command -label "Reread references" -command rereadrefs
638     .bar.file add command -label "List references" -command showrefs
639     .bar.file add command -label "Quit" -command doquit
640     .bar.file configure -font uifont
641     menu .bar.edit
642     .bar add cascade -label "Edit" -menu .bar.edit
643     .bar.edit add command -label "Preferences" -command doprefs
644     .bar.edit configure -font uifont
646     menu .bar.view -font uifont
647     .bar add cascade -label "View" -menu .bar.view
648     .bar.view add command -label "New view..." -command {newview 0}
649     .bar.view add command -label "Edit view..." -command editview \
650         -state disabled
651     .bar.view add command -label "Delete view" -command delview -state disabled
652     .bar.view add separator
653     .bar.view add radiobutton -label "All files" -command {showview 0} \
654         -variable selectedview -value 0
656     menu .bar.help
657     .bar add cascade -label "Help" -menu .bar.help
658     .bar.help add command -label "About gitk" -command about
659     .bar.help add command -label "Key bindings" -command keys
660     .bar.help configure -font uifont
661     . configure -menu .bar
663     # the gui has upper and lower half, parts of a paned window.
664     panedwindow .ctop -orient vertical
666     # possibly use assumed geometry
667     if {![info exists geometry(pwsash0)]} {
668         set geometry(topheight) [expr {15 * $linespc}]
669         set geometry(topwidth) [expr {80 * $charspc}]
670         set geometry(botheight) [expr {15 * $linespc}]
671         set geometry(botwidth) [expr {50 * $charspc}]
672         set geometry(pwsash0) "[expr {40 * $charspc}] 2"
673         set geometry(pwsash1) "[expr {60 * $charspc}] 2"
674     }
676     # the upper half will have a paned window, a scroll bar to the right, and some stuff below
677     frame .tf -height $geometry(topheight) -width $geometry(topwidth)
678     frame .tf.histframe
679     panedwindow .tf.histframe.pwclist -orient horizontal -sashpad 0 -handlesize 4
681     # create three canvases
682     set cscroll .tf.histframe.csb
683     set canv .tf.histframe.pwclist.canv
684     canvas $canv \
685         -selectbackground $selectbgcolor \
686         -background $bgcolor -bd 0 \
687         -yscrollincr $linespc -yscrollcommand "scrollcanv $cscroll"
688     .tf.histframe.pwclist add $canv
689     set canv2 .tf.histframe.pwclist.canv2
690     canvas $canv2 \
691         -selectbackground $selectbgcolor \
692         -background $bgcolor -bd 0 -yscrollincr $linespc
693     .tf.histframe.pwclist add $canv2
694     set canv3 .tf.histframe.pwclist.canv3
695     canvas $canv3 \
696         -selectbackground $selectbgcolor \
697         -background $bgcolor -bd 0 -yscrollincr $linespc
698     .tf.histframe.pwclist add $canv3
699     eval .tf.histframe.pwclist sash place 0 $geometry(pwsash0)
700     eval .tf.histframe.pwclist sash place 1 $geometry(pwsash1)
702     # a scroll bar to rule them
703     scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
704     pack $cscroll -side right -fill y
705     bind .tf.histframe.pwclist <Configure> {resizeclistpanes %W %w}
706     lappend bglist $canv $canv2 $canv3
707     pack .tf.histframe.pwclist -fill both -expand 1 -side left
709     # we have two button bars at bottom of top frame. Bar 1
710     frame .tf.bar
711     frame .tf.lbar -height 15
713     set sha1entry .tf.bar.sha1
714     set entries $sha1entry
715     set sha1but .tf.bar.sha1label
716     button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
717         -command gotocommit -width 8 -font uifont
718     $sha1but conf -disabledforeground [$sha1but cget -foreground]
719     pack .tf.bar.sha1label -side left
720     entry $sha1entry -width 40 -font textfont -textvariable sha1string
721     trace add variable sha1string write sha1change
722     pack $sha1entry -side left -pady 2
724     image create bitmap bm-left -data {
725         #define left_width 16
726         #define left_height 16
727         static unsigned char left_bits[] = {
728         0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
729         0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
730         0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
731     }
732     image create bitmap bm-right -data {
733         #define right_width 16
734         #define right_height 16
735         static unsigned char right_bits[] = {
736         0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
737         0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
738         0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
739     }
740     button .tf.bar.leftbut -image bm-left -command goback \
741         -state disabled -width 26
742     pack .tf.bar.leftbut -side left -fill y
743     button .tf.bar.rightbut -image bm-right -command goforw \
744         -state disabled -width 26
745     pack .tf.bar.rightbut -side left -fill y
747     # Status label and progress bar
748     set statusw .tf.bar.status
749     label $statusw -width 15 -relief sunken -font uifont
750     pack $statusw -side left -padx 5
751     set h [expr {[font metrics uifont -linespace] + 2}]
752     set progresscanv .tf.bar.progress
753     canvas $progresscanv -relief sunken -height $h -borderwidth 2
754     set progressitem [$progresscanv create rect -1 0 0 $h -fill green]
755     set fprogitem [$progresscanv create rect -1 0 0 $h -fill yellow]
756     set rprogitem [$progresscanv create rect -1 0 0 $h -fill red]
757     pack $progresscanv -side right -expand 1 -fill x
758     set progresscoords {0 0}
759     set fprogcoord 0
760     set rprogcoord 0
761     bind $progresscanv <Configure> adjustprogress
762     set lastprogupdate [clock clicks -milliseconds]
763     set progupdatepending 0
765     # build up the bottom bar of upper window
766     label .tf.lbar.flabel -text "Find " -font uifont
767     button .tf.lbar.fnext -text "next" -command {dofind 1 1} -font uifont
768     button .tf.lbar.fprev -text "prev" -command {dofind -1 1} -font uifont
769     label .tf.lbar.flab2 -text " commit " -font uifont
770     pack .tf.lbar.flabel .tf.lbar.fnext .tf.lbar.fprev .tf.lbar.flab2 \
771         -side left -fill y
772     set gdttype "containing:"
773     set gm [tk_optionMenu .tf.lbar.gdttype gdttype \
774                 "containing:" \
775                 "touching paths:" \
776                 "adding/removing string:"]
777     trace add variable gdttype write gdttype_change
778     $gm conf -font uifont
779     .tf.lbar.gdttype conf -font uifont
780     pack .tf.lbar.gdttype -side left -fill y
782     set findstring {}
783     set fstring .tf.lbar.findstring
784     lappend entries $fstring
785     entry $fstring -width 30 -font textfont -textvariable findstring
786     trace add variable findstring write find_change
787     set findtype Exact
788     set findtypemenu [tk_optionMenu .tf.lbar.findtype \
789                       findtype Exact IgnCase Regexp]
790     trace add variable findtype write findcom_change
791     .tf.lbar.findtype configure -font uifont
792     .tf.lbar.findtype.menu configure -font uifont
793     set findloc "All fields"
794     tk_optionMenu .tf.lbar.findloc findloc "All fields" Headline \
795         Comments Author Committer
796     trace add variable findloc write find_change
797     .tf.lbar.findloc configure -font uifont
798     .tf.lbar.findloc.menu configure -font uifont
799     pack .tf.lbar.findloc -side right
800     pack .tf.lbar.findtype -side right
801     pack $fstring -side left -expand 1 -fill x
803     # Finish putting the upper half of the viewer together
804     pack .tf.lbar -in .tf -side bottom -fill x
805     pack .tf.bar -in .tf -side bottom -fill x
806     pack .tf.histframe -fill both -side top -expand 1
807     .ctop add .tf
808     .ctop paneconfigure .tf -height $geometry(topheight)
809     .ctop paneconfigure .tf -width $geometry(topwidth)
811     # now build up the bottom
812     panedwindow .pwbottom -orient horizontal
814     # lower left, a text box over search bar, scroll bar to the right
815     # if we know window height, then that will set the lower text height, otherwise
816     # we set lower text height which will drive window height
817     if {[info exists geometry(main)]} {
818         frame .bleft -width $geometry(botwidth)
819     } else {
820         frame .bleft -width $geometry(botwidth) -height $geometry(botheight)
821     }
822     frame .bleft.top
823     frame .bleft.mid
825     button .bleft.top.search -text "Search" -command dosearch \
826         -font uifont
827     pack .bleft.top.search -side left -padx 5
828     set sstring .bleft.top.sstring
829     entry $sstring -width 20 -font textfont -textvariable searchstring
830     lappend entries $sstring
831     trace add variable searchstring write incrsearch
832     pack $sstring -side left -expand 1 -fill x
833     radiobutton .bleft.mid.diff -text "Diff" -font uifont \
834         -command changediffdisp -variable diffelide -value {0 0}
835     radiobutton .bleft.mid.old -text "Old version" -font uifont \
836         -command changediffdisp -variable diffelide -value {0 1}
837     radiobutton .bleft.mid.new -text "New version" -font uifont \
838         -command changediffdisp -variable diffelide -value {1 0}
839     label .bleft.mid.labeldiffcontext -text "      Lines of context: " \
840         -font uifont
841     pack .bleft.mid.diff .bleft.mid.old .bleft.mid.new -side left
842     spinbox .bleft.mid.diffcontext -width 5 -font textfont \
843         -from 1 -increment 1 -to 10000000 \
844         -validate all -validatecommand "diffcontextvalidate %P" \
845         -textvariable diffcontextstring
846     .bleft.mid.diffcontext set $diffcontext
847     trace add variable diffcontextstring write diffcontextchange
848     lappend entries .bleft.mid.diffcontext
849     pack .bleft.mid.labeldiffcontext .bleft.mid.diffcontext -side left
850     set ctext .bleft.ctext
851     text $ctext -background $bgcolor -foreground $fgcolor \
852         -state disabled -font textfont \
853         -yscrollcommand scrolltext -wrap none
854     if {$have_tk85} {
855         $ctext conf -tabstyle wordprocessor
856     }
857     scrollbar .bleft.sb -command "$ctext yview"
858     pack .bleft.top -side top -fill x
859     pack .bleft.mid -side top -fill x
860     pack .bleft.sb -side right -fill y
861     pack $ctext -side left -fill both -expand 1
862     lappend bglist $ctext
863     lappend fglist $ctext
865     $ctext tag conf comment -wrap $wrapcomment
866     $ctext tag conf filesep -font textfontbold -back "#aaaaaa"
867     $ctext tag conf hunksep -fore [lindex $diffcolors 2]
868     $ctext tag conf d0 -fore [lindex $diffcolors 0]
869     $ctext tag conf d1 -fore [lindex $diffcolors 1]
870     $ctext tag conf m0 -fore red
871     $ctext tag conf m1 -fore blue
872     $ctext tag conf m2 -fore green
873     $ctext tag conf m3 -fore purple
874     $ctext tag conf m4 -fore brown
875     $ctext tag conf m5 -fore "#009090"
876     $ctext tag conf m6 -fore magenta
877     $ctext tag conf m7 -fore "#808000"
878     $ctext tag conf m8 -fore "#009000"
879     $ctext tag conf m9 -fore "#ff0080"
880     $ctext tag conf m10 -fore cyan
881     $ctext tag conf m11 -fore "#b07070"
882     $ctext tag conf m12 -fore "#70b0f0"
883     $ctext tag conf m13 -fore "#70f0b0"
884     $ctext tag conf m14 -fore "#f0b070"
885     $ctext tag conf m15 -fore "#ff70b0"
886     $ctext tag conf mmax -fore darkgrey
887     set mergemax 16
888     $ctext tag conf mresult -font textfontbold
889     $ctext tag conf msep -font textfontbold
890     $ctext tag conf found -back yellow
892     .pwbottom add .bleft
893     .pwbottom paneconfigure .bleft -width $geometry(botwidth)
895     # lower right
896     frame .bright
897     frame .bright.mode
898     radiobutton .bright.mode.patch -text "Patch" \
899         -command reselectline -variable cmitmode -value "patch"
900     .bright.mode.patch configure -font uifont
901     radiobutton .bright.mode.tree -text "Tree" \
902         -command reselectline -variable cmitmode -value "tree"
903     .bright.mode.tree configure -font uifont
904     grid .bright.mode.patch .bright.mode.tree -sticky ew
905     pack .bright.mode -side top -fill x
906     set cflist .bright.cfiles
907     set indent [font measure mainfont "nn"]
908     text $cflist \
909         -selectbackground $selectbgcolor \
910         -background $bgcolor -foreground $fgcolor \
911         -font mainfont \
912         -tabs [list $indent [expr {2 * $indent}]] \
913         -yscrollcommand ".bright.sb set" \
914         -cursor [. cget -cursor] \
915         -spacing1 1 -spacing3 1
916     lappend bglist $cflist
917     lappend fglist $cflist
918     scrollbar .bright.sb -command "$cflist yview"
919     pack .bright.sb -side right -fill y
920     pack $cflist -side left -fill both -expand 1
921     $cflist tag configure highlight \
922         -background [$cflist cget -selectbackground]
923     $cflist tag configure bold -font mainfontbold
925     .pwbottom add .bright
926     .ctop add .pwbottom
928     # restore window position if known
929     if {[info exists geometry(main)]} {
930         wm geometry . "$geometry(main)"
931     }
933     if {[tk windowingsystem] eq {aqua}} {
934         set M1B M1
935     } else {
936         set M1B Control
937     }
939     bind .pwbottom <Configure> {resizecdetpanes %W %w}
940     pack .ctop -fill both -expand 1
941     bindall <1> {selcanvline %W %x %y}
942     #bindall <B1-Motion> {selcanvline %W %x %y}
943     if {[tk windowingsystem] == "win32"} {
944         bind . <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D }
945         bind $ctext <MouseWheel> { windows_mousewheel_redirector %W %X %Y %D ; break }
946     } else {
947         bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
948         bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
949         if {[tk windowingsystem] eq "aqua"} {
950             bindall <MouseWheel> {
951                 set delta [expr {- (%D)}]
952                 allcanvs yview scroll $delta units
953             }
954         }
955     }
956     bindall <2> "canvscan mark %W %x %y"
957     bindall <B2-Motion> "canvscan dragto %W %x %y"
958     bindkey <Home> selfirstline
959     bindkey <End> sellastline
960     bind . <Key-Up> "selnextline -1"
961     bind . <Key-Down> "selnextline 1"
962     bind . <Shift-Key-Up> "dofind -1 0"
963     bind . <Shift-Key-Down> "dofind 1 0"
964     bindkey <Key-Right> "goforw"
965     bindkey <Key-Left> "goback"
966     bind . <Key-Prior> "selnextpage -1"
967     bind . <Key-Next> "selnextpage 1"
968     bind . <$M1B-Home> "allcanvs yview moveto 0.0"
969     bind . <$M1B-End> "allcanvs yview moveto 1.0"
970     bind . <$M1B-Key-Up> "allcanvs yview scroll -1 units"
971     bind . <$M1B-Key-Down> "allcanvs yview scroll 1 units"
972     bind . <$M1B-Key-Prior> "allcanvs yview scroll -1 pages"
973     bind . <$M1B-Key-Next> "allcanvs yview scroll 1 pages"
974     bindkey <Key-Delete> "$ctext yview scroll -1 pages"
975     bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
976     bindkey <Key-space> "$ctext yview scroll 1 pages"
977     bindkey p "selnextline -1"
978     bindkey n "selnextline 1"
979     bindkey z "goback"
980     bindkey x "goforw"
981     bindkey i "selnextline -1"
982     bindkey k "selnextline 1"
983     bindkey j "goback"
984     bindkey l "goforw"
985     bindkey b "$ctext yview scroll -1 pages"
986     bindkey d "$ctext yview scroll 18 units"
987     bindkey u "$ctext yview scroll -18 units"
988     bindkey / {dofind 1 1}
989     bindkey <Key-Return> {dofind 1 1}
990     bindkey ? {dofind -1 1}
991     bindkey f nextfile
992     bindkey <F5> updatecommits
993     bind . <$M1B-q> doquit
994     bind . <$M1B-f> {dofind 1 1}
995     bind . <$M1B-g> {dofind 1 0}
996     bind . <$M1B-r> dosearchback
997     bind . <$M1B-s> dosearch
998     bind . <$M1B-equal> {incrfont 1}
999     bind . <$M1B-KP_Add> {incrfont 1}
1000     bind . <$M1B-minus> {incrfont -1}
1001     bind . <$M1B-KP_Subtract> {incrfont -1}
1002     wm protocol . WM_DELETE_WINDOW doquit
1003     bind . <Button-1> "click %W"
1004     bind $fstring <Key-Return> {dofind 1 1}
1005     bind $sha1entry <Key-Return> gotocommit
1006     bind $sha1entry <<PasteSelection>> clearsha1
1007     bind $cflist <1> {sel_flist %W %x %y; break}
1008     bind $cflist <B1-Motion> {sel_flist %W %x %y; break}
1009     bind $cflist <ButtonRelease-1> {treeclick %W %x %y}
1010     bind $cflist <Button-3> {pop_flist_menu %W %X %Y %x %y}
1012     set maincursor [. cget -cursor]
1013     set textcursor [$ctext cget -cursor]
1014     set curtextcursor $textcursor
1016     set rowctxmenu .rowctxmenu
1017     menu $rowctxmenu -tearoff 0
1018     $rowctxmenu add command -label "Diff this -> selected" \
1019         -command {diffvssel 0}
1020     $rowctxmenu add command -label "Diff selected -> this" \
1021         -command {diffvssel 1}
1022     $rowctxmenu add command -label "Make patch" -command mkpatch
1023     $rowctxmenu add command -label "Create tag" -command mktag
1024     $rowctxmenu add command -label "Write commit to file" -command writecommit
1025     $rowctxmenu add command -label "Create new branch" -command mkbranch
1026     $rowctxmenu add command -label "Cherry-pick this commit" \
1027         -command cherrypick
1028     $rowctxmenu add command -label "Reset HEAD branch to here" \
1029         -command resethead
1031     set fakerowmenu .fakerowmenu
1032     menu $fakerowmenu -tearoff 0
1033     $fakerowmenu add command -label "Diff this -> selected" \
1034         -command {diffvssel 0}
1035     $fakerowmenu add command -label "Diff selected -> this" \
1036         -command {diffvssel 1}
1037     $fakerowmenu add command -label "Make patch" -command mkpatch
1038 #    $fakerowmenu add command -label "Commit" -command {mkcommit 0}
1039 #    $fakerowmenu add command -label "Commit all" -command {mkcommit 1}
1040 #    $fakerowmenu add command -label "Revert local changes" -command revertlocal
1042     set headctxmenu .headctxmenu
1043     menu $headctxmenu -tearoff 0
1044     $headctxmenu add command -label "Check out this branch" \
1045         -command cobranch
1046     $headctxmenu add command -label "Remove this branch" \
1047         -command rmbranch
1049     global flist_menu
1050     set flist_menu .flistctxmenu
1051     menu $flist_menu -tearoff 0
1052     $flist_menu add command -label "Highlight this too" \
1053         -command {flist_hl 0}
1054     $flist_menu add command -label "Highlight this only" \
1055         -command {flist_hl 1}
1058 # Windows sends all mouse wheel events to the current focused window, not
1059 # the one where the mouse hovers, so bind those events here and redirect
1060 # to the correct window
1061 proc windows_mousewheel_redirector {W X Y D} {
1062     global canv canv2 canv3
1063     set w [winfo containing -displayof $W $X $Y]
1064     if {$w ne ""} {
1065         set u [expr {$D < 0 ? 5 : -5}]
1066         if {$w == $canv || $w == $canv2 || $w == $canv3} {
1067             allcanvs yview scroll $u units
1068         } else {
1069             catch {
1070                 $w yview scroll $u units
1071             }
1072         }
1073     }
1076 # mouse-2 makes all windows scan vertically, but only the one
1077 # the cursor is in scans horizontally
1078 proc canvscan {op w x y} {
1079     global canv canv2 canv3
1080     foreach c [list $canv $canv2 $canv3] {
1081         if {$c == $w} {
1082             $c scan $op $x $y
1083         } else {
1084             $c scan $op 0 $y
1085         }
1086     }
1089 proc scrollcanv {cscroll f0 f1} {
1090     $cscroll set $f0 $f1
1091     drawfrac $f0 $f1
1092     flushhighlights
1095 # when we make a key binding for the toplevel, make sure
1096 # it doesn't get triggered when that key is pressed in the
1097 # find string entry widget.
1098 proc bindkey {ev script} {
1099     global entries
1100     bind . $ev $script
1101     set escript [bind Entry $ev]
1102     if {$escript == {}} {
1103         set escript [bind Entry <Key>]
1104     }
1105     foreach e $entries {
1106         bind $e $ev "$escript; break"
1107     }
1110 # set the focus back to the toplevel for any click outside
1111 # the entry widgets
1112 proc click {w} {
1113     global ctext entries
1114     foreach e [concat $entries $ctext] {
1115         if {$w == $e} return
1116     }
1117     focus .
1120 # Adjust the progress bar for a change in requested extent or canvas size
1121 proc adjustprogress {} {
1122     global progresscanv progressitem progresscoords
1123     global fprogitem fprogcoord lastprogupdate progupdatepending
1124     global rprogitem rprogcoord
1126     set w [expr {[winfo width $progresscanv] - 4}]
1127     set x0 [expr {$w * [lindex $progresscoords 0]}]
1128     set x1 [expr {$w * [lindex $progresscoords 1]}]
1129     set h [winfo height $progresscanv]
1130     $progresscanv coords $progressitem $x0 0 $x1 $h
1131     $progresscanv coords $fprogitem 0 0 [expr {$w * $fprogcoord}] $h
1132     $progresscanv coords $rprogitem 0 0 [expr {$w * $rprogcoord}] $h
1133     set now [clock clicks -milliseconds]
1134     if {$now >= $lastprogupdate + 100} {
1135         set progupdatepending 0
1136         update
1137     } elseif {!$progupdatepending} {
1138         set progupdatepending 1
1139         after [expr {$lastprogupdate + 100 - $now}] doprogupdate
1140     }
1143 proc doprogupdate {} {
1144     global lastprogupdate progupdatepending
1146     if {$progupdatepending} {
1147         set progupdatepending 0
1148         set lastprogupdate [clock clicks -milliseconds]
1149         update
1150     }
1153 proc savestuff {w} {
1154     global canv canv2 canv3 mainfont textfont uifont tabstop
1155     global stuffsaved findmergefiles maxgraphpct
1156     global maxwidth showneartags showlocalchanges
1157     global viewname viewfiles viewargs viewperm nextviewnum
1158     global cmitmode wrapcomment datetimeformat limitdiffs
1159     global colors bgcolor fgcolor diffcolors diffcontext selectbgcolor
1161     if {$stuffsaved} return
1162     if {![winfo viewable .]} return
1163     catch {
1164         set f [open "~/.gitk-new" w]
1165         puts $f [list set mainfont $mainfont]
1166         puts $f [list set textfont $textfont]
1167         puts $f [list set uifont $uifont]
1168         puts $f [list set tabstop $tabstop]
1169         puts $f [list set findmergefiles $findmergefiles]
1170         puts $f [list set maxgraphpct $maxgraphpct]
1171         puts $f [list set maxwidth $maxwidth]
1172         puts $f [list set cmitmode $cmitmode]
1173         puts $f [list set wrapcomment $wrapcomment]
1174         puts $f [list set showneartags $showneartags]
1175         puts $f [list set showlocalchanges $showlocalchanges]
1176         puts $f [list set datetimeformat $datetimeformat]
1177         puts $f [list set limitdiffs $limitdiffs]
1178         puts $f [list set bgcolor $bgcolor]
1179         puts $f [list set fgcolor $fgcolor]
1180         puts $f [list set colors $colors]
1181         puts $f [list set diffcolors $diffcolors]
1182         puts $f [list set diffcontext $diffcontext]
1183         puts $f [list set selectbgcolor $selectbgcolor]
1185         puts $f "set geometry(main) [wm geometry .]"
1186         puts $f "set geometry(topwidth) [winfo width .tf]"
1187         puts $f "set geometry(topheight) [winfo height .tf]"
1188         puts $f "set geometry(pwsash0) \"[.tf.histframe.pwclist sash coord 0]\""
1189         puts $f "set geometry(pwsash1) \"[.tf.histframe.pwclist sash coord 1]\""
1190         puts $f "set geometry(botwidth) [winfo width .bleft]"
1191         puts $f "set geometry(botheight) [winfo height .bleft]"
1193         puts -nonewline $f "set permviews {"
1194         for {set v 0} {$v < $nextviewnum} {incr v} {
1195             if {$viewperm($v)} {
1196                 puts $f "{[list $viewname($v) $viewfiles($v) $viewargs($v)]}"
1197             }
1198         }
1199         puts $f "}"
1200         close $f
1201         file rename -force "~/.gitk-new" "~/.gitk"
1202     }
1203     set stuffsaved 1
1206 proc resizeclistpanes {win w} {
1207     global oldwidth
1208     if {[info exists oldwidth($win)]} {
1209         set s0 [$win sash coord 0]
1210         set s1 [$win sash coord 1]
1211         if {$w < 60} {
1212             set sash0 [expr {int($w/2 - 2)}]
1213             set sash1 [expr {int($w*5/6 - 2)}]
1214         } else {
1215             set factor [expr {1.0 * $w / $oldwidth($win)}]
1216             set sash0 [expr {int($factor * [lindex $s0 0])}]
1217             set sash1 [expr {int($factor * [lindex $s1 0])}]
1218             if {$sash0 < 30} {
1219                 set sash0 30
1220             }
1221             if {$sash1 < $sash0 + 20} {
1222                 set sash1 [expr {$sash0 + 20}]
1223             }
1224             if {$sash1 > $w - 10} {
1225                 set sash1 [expr {$w - 10}]
1226                 if {$sash0 > $sash1 - 20} {
1227                     set sash0 [expr {$sash1 - 20}]
1228                 }
1229             }
1230         }
1231         $win sash place 0 $sash0 [lindex $s0 1]
1232         $win sash place 1 $sash1 [lindex $s1 1]
1233     }
1234     set oldwidth($win) $w
1237 proc resizecdetpanes {win w} {
1238     global oldwidth
1239     if {[info exists oldwidth($win)]} {
1240         set s0 [$win sash coord 0]
1241         if {$w < 60} {
1242             set sash0 [expr {int($w*3/4 - 2)}]
1243         } else {
1244             set factor [expr {1.0 * $w / $oldwidth($win)}]
1245             set sash0 [expr {int($factor * [lindex $s0 0])}]
1246             if {$sash0 < 45} {
1247                 set sash0 45
1248             }
1249             if {$sash0 > $w - 15} {
1250                 set sash0 [expr {$w - 15}]
1251             }
1252         }
1253         $win sash place 0 $sash0 [lindex $s0 1]
1254     }
1255     set oldwidth($win) $w
1258 proc allcanvs args {
1259     global canv canv2 canv3
1260     eval $canv $args
1261     eval $canv2 $args
1262     eval $canv3 $args
1265 proc bindall {event action} {
1266     global canv canv2 canv3
1267     bind $canv $event $action
1268     bind $canv2 $event $action
1269     bind $canv3 $event $action
1272 proc about {} {
1273     global uifont
1274     set w .about
1275     if {[winfo exists $w]} {
1276         raise $w
1277         return
1278     }
1279     toplevel $w
1280     wm title $w "About gitk"
1281     message $w.m -text {
1282 Gitk - a commit viewer for git
1284 Copyright Â© 2005-2006 Paul Mackerras
1286 Use and redistribute under the terms of the GNU General Public License} \
1287             -justify center -aspect 400 -border 2 -bg white -relief groove
1288     pack $w.m -side top -fill x -padx 2 -pady 2
1289     $w.m configure -font uifont
1290     button $w.ok -text Close -command "destroy $w" -default active
1291     pack $w.ok -side bottom
1292     $w.ok configure -font uifont
1293     bind $w <Visibility> "focus $w.ok"
1294     bind $w <Key-Escape> "destroy $w"
1295     bind $w <Key-Return> "destroy $w"
1298 proc keys {} {
1299     global uifont
1300     set w .keys
1301     if {[winfo exists $w]} {
1302         raise $w
1303         return
1304     }
1305     if {[tk windowingsystem] eq {aqua}} {
1306         set M1T Cmd
1307     } else {
1308         set M1T Ctrl
1309     }
1310     toplevel $w
1311     wm title $w "Gitk key bindings"
1312     message $w.m -text "
1313 Gitk key bindings:
1315 <$M1T-Q>                Quit
1316 <Home>          Move to first commit
1317 <End>           Move to last commit
1318 <Up>, p, i      Move up one commit
1319 <Down>, n, k    Move down one commit
1320 <Left>, z, j    Go back in history list
1321 <Right>, x, l   Go forward in history list
1322 <PageUp>        Move up one page in commit list
1323 <PageDown>      Move down one page in commit list
1324 <$M1T-Home>     Scroll to top of commit list
1325 <$M1T-End>      Scroll to bottom of commit list
1326 <$M1T-Up>       Scroll commit list up one line
1327 <$M1T-Down>     Scroll commit list down one line
1328 <$M1T-PageUp>   Scroll commit list up one page
1329 <$M1T-PageDown> Scroll commit list down one page
1330 <Shift-Up>      Find backwards (upwards, later commits)
1331 <Shift-Down>    Find forwards (downwards, earlier commits)
1332 <Delete>, b     Scroll diff view up one page
1333 <Backspace>     Scroll diff view up one page
1334 <Space>         Scroll diff view down one page
1335 u               Scroll diff view up 18 lines
1336 d               Scroll diff view down 18 lines
1337 <$M1T-F>                Find
1338 <$M1T-G>                Move to next find hit
1339 <Return>        Move to next find hit
1340 /               Move to next find hit, or redo find
1341 ?               Move to previous find hit
1342 f               Scroll diff view to next file
1343 <$M1T-S>                Search for next hit in diff view
1344 <$M1T-R>                Search for previous hit in diff view
1345 <$M1T-KP+>      Increase font size
1346 <$M1T-plus>     Increase font size
1347 <$M1T-KP->      Decrease font size
1348 <$M1T-minus>    Decrease font size
1349 <F5>            Update
1350 " \
1351             -justify left -bg white -border 2 -relief groove
1352     pack $w.m -side top -fill both -padx 2 -pady 2
1353     $w.m configure -font uifont
1354     button $w.ok -text Close -command "destroy $w" -default active
1355     pack $w.ok -side bottom
1356     $w.ok configure -font uifont
1357     bind $w <Visibility> "focus $w.ok"
1358     bind $w <Key-Escape> "destroy $w"
1359     bind $w <Key-Return> "destroy $w"
1362 # Procedures for manipulating the file list window at the
1363 # bottom right of the overall window.
1365 proc treeview {w l openlevs} {
1366     global treecontents treediropen treeheight treeparent treeindex
1368     set ix 0
1369     set treeindex() 0
1370     set lev 0
1371     set prefix {}
1372     set prefixend -1
1373     set prefendstack {}
1374     set htstack {}
1375     set ht 0
1376     set treecontents() {}
1377     $w conf -state normal
1378     foreach f $l {
1379         while {[string range $f 0 $prefixend] ne $prefix} {
1380             if {$lev <= $openlevs} {
1381                 $w mark set e:$treeindex($prefix) "end -1c"
1382                 $w mark gravity e:$treeindex($prefix) left
1383             }
1384             set treeheight($prefix) $ht
1385             incr ht [lindex $htstack end]
1386             set htstack [lreplace $htstack end end]
1387             set prefixend [lindex $prefendstack end]
1388             set prefendstack [lreplace $prefendstack end end]
1389             set prefix [string range $prefix 0 $prefixend]
1390             incr lev -1
1391         }
1392         set tail [string range $f [expr {$prefixend+1}] end]
1393         while {[set slash [string first "/" $tail]] >= 0} {
1394             lappend htstack $ht
1395             set ht 0
1396             lappend prefendstack $prefixend
1397             incr prefixend [expr {$slash + 1}]
1398             set d [string range $tail 0 $slash]
1399             lappend treecontents($prefix) $d
1400             set oldprefix $prefix
1401             append prefix $d
1402             set treecontents($prefix) {}
1403             set treeindex($prefix) [incr ix]
1404             set treeparent($prefix) $oldprefix
1405             set tail [string range $tail [expr {$slash+1}] end]
1406             if {$lev <= $openlevs} {
1407                 set ht 1
1408                 set treediropen($prefix) [expr {$lev < $openlevs}]
1409                 set bm [expr {$lev == $openlevs? "tri-rt": "tri-dn"}]
1410                 $w mark set d:$ix "end -1c"
1411                 $w mark gravity d:$ix left
1412                 set str "\n"
1413                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1414                 $w insert end $str
1415                 $w image create end -align center -image $bm -padx 1 \
1416                     -name a:$ix
1417                 $w insert end $d [highlight_tag $prefix]
1418                 $w mark set s:$ix "end -1c"
1419                 $w mark gravity s:$ix left
1420             }
1421             incr lev
1422         }
1423         if {$tail ne {}} {
1424             if {$lev <= $openlevs} {
1425                 incr ht
1426                 set str "\n"
1427                 for {set i 0} {$i < $lev} {incr i} {append str "\t"}
1428                 $w insert end $str
1429                 $w insert end $tail [highlight_tag $f]
1430             }
1431             lappend treecontents($prefix) $tail
1432         }
1433     }
1434     while {$htstack ne {}} {
1435         set treeheight($prefix) $ht
1436         incr ht [lindex $htstack end]
1437         set htstack [lreplace $htstack end end]
1438         set prefixend [lindex $prefendstack end]
1439         set prefendstack [lreplace $prefendstack end end]
1440         set prefix [string range $prefix 0 $prefixend]
1441     }
1442     $w conf -state disabled
1445 proc linetoelt {l} {
1446     global treeheight treecontents
1448     set y 2
1449     set prefix {}
1450     while {1} {
1451         foreach e $treecontents($prefix) {
1452             if {$y == $l} {
1453                 return "$prefix$e"
1454             }
1455             set n 1
1456             if {[string index $e end] eq "/"} {
1457                 set n $treeheight($prefix$e)
1458                 if {$y + $n > $l} {
1459                     append prefix $e
1460                     incr y
1461                     break
1462                 }
1463             }
1464             incr y $n
1465         }
1466     }
1469 proc highlight_tree {y prefix} {
1470     global treeheight treecontents cflist
1472     foreach e $treecontents($prefix) {
1473         set path $prefix$e
1474         if {[highlight_tag $path] ne {}} {
1475             $cflist tag add bold $y.0 "$y.0 lineend"
1476         }
1477         incr y
1478         if {[string index $e end] eq "/" && $treeheight($path) > 1} {
1479             set y [highlight_tree $y $path]
1480         }
1481     }
1482     return $y
1485 proc treeclosedir {w dir} {
1486     global treediropen treeheight treeparent treeindex
1488     set ix $treeindex($dir)
1489     $w conf -state normal
1490     $w delete s:$ix e:$ix
1491     set treediropen($dir) 0
1492     $w image configure a:$ix -image tri-rt
1493     $w conf -state disabled
1494     set n [expr {1 - $treeheight($dir)}]
1495     while {$dir ne {}} {
1496         incr treeheight($dir) $n
1497         set dir $treeparent($dir)
1498     }
1501 proc treeopendir {w dir} {
1502     global treediropen treeheight treeparent treecontents treeindex
1504     set ix $treeindex($dir)
1505     $w conf -state normal
1506     $w image configure a:$ix -image tri-dn
1507     $w mark set e:$ix s:$ix
1508     $w mark gravity e:$ix right
1509     set lev 0
1510     set str "\n"
1511     set n [llength $treecontents($dir)]
1512     for {set x $dir} {$x ne {}} {set x $treeparent($x)} {
1513         incr lev
1514         append str "\t"
1515         incr treeheight($x) $n
1516     }
1517     foreach e $treecontents($dir) {
1518         set de $dir$e
1519         if {[string index $e end] eq "/"} {
1520             set iy $treeindex($de)
1521             $w mark set d:$iy e:$ix
1522             $w mark gravity d:$iy left
1523             $w insert e:$ix $str
1524             set treediropen($de) 0
1525             $w image create e:$ix -align center -image tri-rt -padx 1 \
1526                 -name a:$iy
1527             $w insert e:$ix $e [highlight_tag $de]
1528             $w mark set s:$iy e:$ix
1529             $w mark gravity s:$iy left
1530             set treeheight($de) 1
1531         } else {
1532             $w insert e:$ix $str
1533             $w insert e:$ix $e [highlight_tag $de]
1534         }
1535     }
1536     $w mark gravity e:$ix left
1537     $w conf -state disabled
1538     set treediropen($dir) 1
1539     set top [lindex [split [$w index @0,0] .] 0]
1540     set ht [$w cget -height]
1541     set l [lindex [split [$w index s:$ix] .] 0]
1542     if {$l < $top} {
1543         $w yview $l.0
1544     } elseif {$l + $n + 1 > $top + $ht} {
1545         set top [expr {$l + $n + 2 - $ht}]
1546         if {$l < $top} {
1547             set top $l
1548         }
1549         $w yview $top.0
1550     }
1553 proc treeclick {w x y} {
1554     global treediropen cmitmode ctext cflist cflist_top
1556     if {$cmitmode ne "tree"} return
1557     if {![info exists cflist_top]} return
1558     set l [lindex [split [$w index "@$x,$y"] "."] 0]
1559     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1560     $cflist tag add highlight $l.0 "$l.0 lineend"
1561     set cflist_top $l
1562     if {$l == 1} {
1563         $ctext yview 1.0
1564         return
1565     }
1566     set e [linetoelt $l]
1567     if {[string index $e end] ne "/"} {
1568         showfile $e
1569     } elseif {$treediropen($e)} {
1570         treeclosedir $w $e
1571     } else {
1572         treeopendir $w $e
1573     }
1576 proc setfilelist {id} {
1577     global treefilelist cflist
1579     treeview $cflist $treefilelist($id) 0
1582 image create bitmap tri-rt -background black -foreground blue -data {
1583     #define tri-rt_width 13
1584     #define tri-rt_height 13
1585     static unsigned char tri-rt_bits[] = {
1586        0x00, 0x00, 0x00, 0x00, 0x10, 0x00, 0x30, 0x00, 0x70, 0x00, 0xf0, 0x00,
1587        0xf0, 0x01, 0xf0, 0x00, 0x70, 0x00, 0x30, 0x00, 0x10, 0x00, 0x00, 0x00,
1588        0x00, 0x00};
1589 } -maskdata {
1590     #define tri-rt-mask_width 13
1591     #define tri-rt-mask_height 13
1592     static unsigned char tri-rt-mask_bits[] = {
1593        0x08, 0x00, 0x18, 0x00, 0x38, 0x00, 0x78, 0x00, 0xf8, 0x00, 0xf8, 0x01,
1594        0xf8, 0x03, 0xf8, 0x01, 0xf8, 0x00, 0x78, 0x00, 0x38, 0x00, 0x18, 0x00,
1595        0x08, 0x00};
1597 image create bitmap tri-dn -background black -foreground blue -data {
1598     #define tri-dn_width 13
1599     #define tri-dn_height 13
1600     static unsigned char tri-dn_bits[] = {
1601        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfc, 0x07, 0xf8, 0x03,
1602        0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
1603        0x00, 0x00};
1604 } -maskdata {
1605     #define tri-dn-mask_width 13
1606     #define tri-dn-mask_height 13
1607     static unsigned char tri-dn-mask_bits[] = {
1608        0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xff, 0x1f, 0xfe, 0x0f, 0xfc, 0x07,
1609        0xf8, 0x03, 0xf0, 0x01, 0xe0, 0x00, 0x40, 0x00, 0x00, 0x00, 0x00, 0x00,
1610        0x00, 0x00};
1613 image create bitmap reficon-T -background black -foreground yellow -data {
1614     #define tagicon_width 13
1615     #define tagicon_height 9
1616     static unsigned char tagicon_bits[] = {
1617        0x00, 0x00, 0x00, 0x00, 0xf0, 0x07, 0xf8, 0x07,
1618        0xfc, 0x07, 0xf8, 0x07, 0xf0, 0x07, 0x00, 0x00, 0x00, 0x00};
1619 } -maskdata {
1620     #define tagicon-mask_width 13
1621     #define tagicon-mask_height 9
1622     static unsigned char tagicon-mask_bits[] = {
1623        0x00, 0x00, 0xf0, 0x0f, 0xf8, 0x0f, 0xfc, 0x0f,
1624        0xfe, 0x0f, 0xfc, 0x0f, 0xf8, 0x0f, 0xf0, 0x0f, 0x00, 0x00};
1626 set rectdata {
1627     #define headicon_width 13
1628     #define headicon_height 9
1629     static unsigned char headicon_bits[] = {
1630        0x00, 0x00, 0x00, 0x00, 0xf8, 0x07, 0xf8, 0x07,
1631        0xf8, 0x07, 0xf8, 0x07, 0xf8, 0x07, 0x00, 0x00, 0x00, 0x00};
1633 set rectmask {
1634     #define headicon-mask_width 13
1635     #define headicon-mask_height 9
1636     static unsigned char headicon-mask_bits[] = {
1637        0x00, 0x00, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f,
1638        0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0xfc, 0x0f, 0x00, 0x00};
1640 image create bitmap reficon-H -background black -foreground green \
1641     -data $rectdata -maskdata $rectmask
1642 image create bitmap reficon-o -background black -foreground "#ddddff" \
1643     -data $rectdata -maskdata $rectmask
1645 proc init_flist {first} {
1646     global cflist cflist_top selectedline difffilestart
1648     $cflist conf -state normal
1649     $cflist delete 0.0 end
1650     if {$first ne {}} {
1651         $cflist insert end $first
1652         set cflist_top 1
1653         $cflist tag add highlight 1.0 "1.0 lineend"
1654     } else {
1655         catch {unset cflist_top}
1656     }
1657     $cflist conf -state disabled
1658     set difffilestart {}
1661 proc highlight_tag {f} {
1662     global highlight_paths
1664     foreach p $highlight_paths {
1665         if {[string match $p $f]} {
1666             return "bold"
1667         }
1668     }
1669     return {}
1672 proc highlight_filelist {} {
1673     global cmitmode cflist
1675     $cflist conf -state normal
1676     if {$cmitmode ne "tree"} {
1677         set end [lindex [split [$cflist index end] .] 0]
1678         for {set l 2} {$l < $end} {incr l} {
1679             set line [$cflist get $l.0 "$l.0 lineend"]
1680             if {[highlight_tag $line] ne {}} {
1681                 $cflist tag add bold $l.0 "$l.0 lineend"
1682             }
1683         }
1684     } else {
1685         highlight_tree 2 {}
1686     }
1687     $cflist conf -state disabled
1690 proc unhighlight_filelist {} {
1691     global cflist
1693     $cflist conf -state normal
1694     $cflist tag remove bold 1.0 end
1695     $cflist conf -state disabled
1698 proc add_flist {fl} {
1699     global cflist
1701     $cflist conf -state normal
1702     foreach f $fl {
1703         $cflist insert end "\n"
1704         $cflist insert end $f [highlight_tag $f]
1705     }
1706     $cflist conf -state disabled
1709 proc sel_flist {w x y} {
1710     global ctext difffilestart cflist cflist_top cmitmode
1712     if {$cmitmode eq "tree"} return
1713     if {![info exists cflist_top]} return
1714     set l [lindex [split [$w index "@$x,$y"] "."] 0]
1715     $cflist tag remove highlight $cflist_top.0 "$cflist_top.0 lineend"
1716     $cflist tag add highlight $l.0 "$l.0 lineend"
1717     set cflist_top $l
1718     if {$l == 1} {
1719         $ctext yview 1.0
1720     } else {
1721         catch {$ctext yview [lindex $difffilestart [expr {$l - 2}]]}
1722     }
1725 proc pop_flist_menu {w X Y x y} {
1726     global ctext cflist cmitmode flist_menu flist_menu_file
1727     global treediffs diffids
1729     stopfinding
1730     set l [lindex [split [$w index "@$x,$y"] "."] 0]
1731     if {$l <= 1} return
1732     if {$cmitmode eq "tree"} {
1733         set e [linetoelt $l]
1734         if {[string index $e end] eq "/"} return
1735     } else {
1736         set e [lindex $treediffs($diffids) [expr {$l-2}]]
1737     }
1738     set flist_menu_file $e
1739     tk_popup $flist_menu $X $Y
1742 proc flist_hl {only} {
1743     global flist_menu_file findstring gdttype
1745     set x [shellquote $flist_menu_file]
1746     if {$only || $findstring eq {} || $gdttype ne "touching paths:"} {
1747         set findstring $x
1748     } else {
1749         append findstring " " $x
1750     }
1751     set gdttype "touching paths:"
1754 # Functions for adding and removing shell-type quoting
1756 proc shellquote {str} {
1757     if {![string match "*\['\"\\ \t]*" $str]} {
1758         return $str
1759     }
1760     if {![string match "*\['\"\\]*" $str]} {
1761         return "\"$str\""
1762     }
1763     if {![string match "*'*" $str]} {
1764         return "'$str'"
1765     }
1766     return "\"[string map {\" \\\" \\ \\\\} $str]\""
1769 proc shellarglist {l} {
1770     set str {}
1771     foreach a $l {
1772         if {$str ne {}} {
1773             append str " "
1774         }
1775         append str [shellquote $a]
1776     }
1777     return $str
1780 proc shelldequote {str} {
1781     set ret {}
1782     set used -1
1783     while {1} {
1784         incr used
1785         if {![regexp -start $used -indices "\['\"\\\\ \t]" $str first]} {
1786             append ret [string range $str $used end]
1787             set used [string length $str]
1788             break
1789         }
1790         set first [lindex $first 0]
1791         set ch [string index $str $first]
1792         if {$first > $used} {
1793             append ret [string range $str $used [expr {$first - 1}]]
1794             set used $first
1795         }
1796         if {$ch eq " " || $ch eq "\t"} break
1797         incr used
1798         if {$ch eq "'"} {
1799             set first [string first "'" $str $used]
1800             if {$first < 0} {
1801                 error "unmatched single-quote"
1802             }
1803             append ret [string range $str $used [expr {$first - 1}]]
1804             set used $first
1805             continue
1806         }
1807         if {$ch eq "\\"} {
1808             if {$used >= [string length $str]} {
1809                 error "trailing backslash"
1810             }
1811             append ret [string index $str $used]
1812             continue
1813         }
1814         # here ch == "\""
1815         while {1} {
1816             if {![regexp -start $used -indices "\[\"\\\\]" $str first]} {
1817                 error "unmatched double-quote"
1818             }
1819             set first [lindex $first 0]
1820             set ch [string index $str $first]
1821             if {$first > $used} {
1822                 append ret [string range $str $used [expr {$first - 1}]]
1823                 set used $first
1824             }
1825             if {$ch eq "\""} break
1826             incr used
1827             append ret [string index $str $used]
1828             incr used
1829         }
1830     }
1831     return [list $used $ret]
1834 proc shellsplit {str} {
1835     set l {}
1836     while {1} {
1837         set str [string trimleft $str]
1838         if {$str eq {}} break
1839         set dq [shelldequote $str]
1840         set n [lindex $dq 0]
1841         set word [lindex $dq 1]
1842         set str [string range $str $n end]
1843         lappend l $word
1844     }
1845     return $l
1848 # Code to implement multiple views
1850 proc newview {ishighlight} {
1851     global nextviewnum newviewname newviewperm uifont newishighlight
1852     global newviewargs revtreeargs
1854     set newishighlight $ishighlight
1855     set top .gitkview
1856     if {[winfo exists $top]} {
1857         raise $top
1858         return
1859     }
1860     set newviewname($nextviewnum) "View $nextviewnum"
1861     set newviewperm($nextviewnum) 0
1862     set newviewargs($nextviewnum) [shellarglist $revtreeargs]
1863     vieweditor $top $nextviewnum "Gitk view definition"
1866 proc editview {} {
1867     global curview
1868     global viewname viewperm newviewname newviewperm
1869     global viewargs newviewargs
1871     set top .gitkvedit-$curview
1872     if {[winfo exists $top]} {
1873         raise $top
1874         return
1875     }
1876     set newviewname($curview) $viewname($curview)
1877     set newviewperm($curview) $viewperm($curview)
1878     set newviewargs($curview) [shellarglist $viewargs($curview)]
1879     vieweditor $top $curview "Gitk: edit view $viewname($curview)"
1882 proc vieweditor {top n title} {
1883     global newviewname newviewperm viewfiles
1884     global uifont
1886     toplevel $top
1887     wm title $top $title
1888     label $top.nl -text "Name" -font uifont
1889     entry $top.name -width 20 -textvariable newviewname($n) -font uifont
1890     grid $top.nl $top.name -sticky w -pady 5
1891     checkbutton $top.perm -text "Remember this view" -variable newviewperm($n) \
1892         -font uifont
1893     grid $top.perm - -pady 5 -sticky w
1894     message $top.al -aspect 1000 -font uifont \
1895         -text "Commits to include (arguments to git rev-list):"
1896     grid $top.al - -sticky w -pady 5
1897     entry $top.args -width 50 -textvariable newviewargs($n) \
1898         -background white -font uifont
1899     grid $top.args - -sticky ew -padx 5
1900     message $top.l -aspect 1000 -font uifont \
1901         -text "Enter files and directories to include, one per line:"
1902     grid $top.l - -sticky w
1903     text $top.t -width 40 -height 10 -background white -font uifont
1904     if {[info exists viewfiles($n)]} {
1905         foreach f $viewfiles($n) {
1906             $top.t insert end $f
1907             $top.t insert end "\n"
1908         }
1909         $top.t delete {end - 1c} end
1910         $top.t mark set insert 0.0
1911     }
1912     grid $top.t - -sticky ew -padx 5
1913     frame $top.buts
1914     button $top.buts.ok -text "OK" -command [list newviewok $top $n] \
1915         -font uifont
1916     button $top.buts.can -text "Cancel" -command [list destroy $top] \
1917         -font uifont
1918     grid $top.buts.ok $top.buts.can
1919     grid columnconfigure $top.buts 0 -weight 1 -uniform a
1920     grid columnconfigure $top.buts 1 -weight 1 -uniform a
1921     grid $top.buts - -pady 10 -sticky ew
1922     focus $top.t
1925 proc doviewmenu {m first cmd op argv} {
1926     set nmenu [$m index end]
1927     for {set i $first} {$i <= $nmenu} {incr i} {
1928         if {[$m entrycget $i -command] eq $cmd} {
1929             eval $m $op $i $argv
1930             break
1931         }
1932     }
1935 proc allviewmenus {n op args} {
1936     # global viewhlmenu
1938     doviewmenu .bar.view 5 [list showview $n] $op $args
1939     # doviewmenu $viewhlmenu 1 [list addvhighlight $n] $op $args
1942 proc newviewok {top n} {
1943     global nextviewnum newviewperm newviewname newishighlight
1944     global viewname viewfiles viewperm selectedview curview
1945     global viewargs newviewargs viewhlmenu
1947     if {[catch {
1948         set newargs [shellsplit $newviewargs($n)]
1949     } err]} {
1950         error_popup "Error in commit selection arguments: $err"
1951         wm raise $top
1952         focus $top
1953         return
1954     }
1955     set files {}
1956     foreach f [split [$top.t get 0.0 end] "\n"] {
1957         set ft [string trim $f]
1958         if {$ft ne {}} {
1959             lappend files $ft
1960         }
1961     }
1962     if {![info exists viewfiles($n)]} {
1963         # creating a new view
1964         incr nextviewnum
1965         set viewname($n) $newviewname($n)
1966         set viewperm($n) $newviewperm($n)
1967         set viewfiles($n) $files
1968         set viewargs($n) $newargs
1969         addviewmenu $n
1970         if {!$newishighlight} {
1971             run showview $n
1972         } else {
1973             run addvhighlight $n
1974         }
1975     } else {
1976         # editing an existing view
1977         set viewperm($n) $newviewperm($n)
1978         if {$newviewname($n) ne $viewname($n)} {
1979             set viewname($n) $newviewname($n)
1980             doviewmenu .bar.view 5 [list showview $n] \
1981                 entryconf [list -label $viewname($n)]
1982             # doviewmenu $viewhlmenu 1 [list addvhighlight $n] \
1983                 # entryconf [list -label $viewname($n) -value $viewname($n)]
1984         }
1985         if {$files ne $viewfiles($n) || $newargs ne $viewargs($n)} {
1986             set viewfiles($n) $files
1987             set viewargs($n) $newargs
1988             if {$curview == $n} {
1989                 run updatecommits
1990             }
1991         }
1992     }
1993     catch {destroy $top}
1996 proc delview {} {
1997     global curview viewdata viewperm hlview selectedhlview
1999     if {$curview == 0} return
2000     if {[info exists hlview] && $hlview == $curview} {
2001         set selectedhlview None
2002         unset hlview
2003     }
2004     allviewmenus $curview delete
2005     set viewdata($curview) {}
2006     set viewperm($curview) 0
2007     showview 0
2010 proc addviewmenu {n} {
2011     global viewname viewhlmenu
2013     .bar.view add radiobutton -label $viewname($n) \
2014         -command [list showview $n] -variable selectedview -value $n
2015     #$viewhlmenu add radiobutton -label $viewname($n) \
2016     #   -command [list addvhighlight $n] -variable selectedhlview
2019 proc flatten {var} {
2020     global $var
2022     set ret {}
2023     foreach i [array names $var] {
2024         lappend ret $i [set $var\($i\)]
2025     }
2026     return $ret
2029 proc unflatten {var l} {
2030     global $var
2032     catch {unset $var}
2033     foreach {i v} $l {
2034         set $var\($i\) $v
2035     }
2038 proc showview {n} {
2039     global curview viewdata viewfiles
2040     global displayorder parentlist rowidlist rowisopt rowfinal
2041     global colormap rowtextx commitrow nextcolor canvxmax
2042     global numcommits commitlisted
2043     global selectedline currentid canv canvy0
2044     global treediffs
2045     global pending_select phase
2046     global commitidx
2047     global commfd
2048     global selectedview selectfirst
2049     global vparentlist vdisporder vcmitlisted
2050     global hlview selectedhlview commitinterest
2052     if {$n == $curview} return
2053     set selid {}
2054     if {[info exists selectedline]} {
2055         set selid $currentid
2056         set y [yc $selectedline]
2057         set ymax [lindex [$canv cget -scrollregion] 3]
2058         set span [$canv yview]
2059         set ytop [expr {[lindex $span 0] * $ymax}]
2060         set ybot [expr {[lindex $span 1] * $ymax}]
2061         if {$ytop < $y && $y < $ybot} {
2062             set yscreen [expr {$y - $ytop}]
2063         } else {
2064             set yscreen [expr {($ybot - $ytop) / 2}]
2065         }
2066     } elseif {[info exists pending_select]} {
2067         set selid $pending_select
2068         unset pending_select
2069     }
2070     unselectline
2071     normalline
2072     if {$curview >= 0} {
2073         set vparentlist($curview) $parentlist
2074         set vdisporder($curview) $displayorder
2075         set vcmitlisted($curview) $commitlisted
2076         if {$phase ne {} ||
2077             ![info exists viewdata($curview)] ||
2078             [lindex $viewdata($curview) 0] ne {}} {
2079             set viewdata($curview) \
2080                 [list $phase $rowidlist $rowisopt $rowfinal]
2081         }
2082     }
2083     catch {unset treediffs}
2084     clear_display
2085     if {[info exists hlview] && $hlview == $n} {
2086         unset hlview
2087         set selectedhlview None
2088     }
2089     catch {unset commitinterest}
2091     set curview $n
2092     set selectedview $n
2093     .bar.view entryconf Edit* -state [expr {$n == 0? "disabled": "normal"}]
2094     .bar.view entryconf Delete* -state [expr {$n == 0? "disabled": "normal"}]
2096     run refill_reflist
2097     if {![info exists viewdata($n)]} {
2098         if {$selid ne {}} {
2099             set pending_select $selid
2100         }
2101         getcommits
2102         return
2103     }
2105     set v $viewdata($n)
2106     set phase [lindex $v 0]
2107     set displayorder $vdisporder($n)
2108     set parentlist $vparentlist($n)
2109     set commitlisted $vcmitlisted($n)
2110     set rowidlist [lindex $v 1]
2111     set rowisopt [lindex $v 2]
2112     set rowfinal [lindex $v 3]
2113     set numcommits $commitidx($n)
2115     catch {unset colormap}
2116     catch {unset rowtextx}
2117     set nextcolor 0
2118     set canvxmax [$canv cget -width]
2119     set curview $n
2120     set row 0
2121     setcanvscroll
2122     set yf 0
2123     set row {}
2124     set selectfirst 0
2125     if {$selid ne {} && [info exists commitrow($n,$selid)]} {
2126         set row $commitrow($n,$selid)
2127         # try to get the selected row in the same position on the screen
2128         set ymax [lindex [$canv cget -scrollregion] 3]
2129         set ytop [expr {[yc $row] - $yscreen}]
2130         if {$ytop < 0} {
2131             set ytop 0
2132         }
2133         set yf [expr {$ytop * 1.0 / $ymax}]
2134     }
2135     allcanvs yview moveto $yf
2136     drawvisible
2137     if {$row ne {}} {
2138         selectline $row 0
2139     } elseif {$selid ne {}} {
2140         set pending_select $selid
2141     } else {
2142         set row [first_real_row]
2143         if {$row < $numcommits} {
2144             selectline $row 0
2145         } else {
2146             set selectfirst 1
2147         }
2148     }
2149     if {$phase ne {}} {
2150         if {$phase eq "getcommits"} {
2151             show_status "Reading commits..."
2152         }
2153         run chewcommits $n
2154     } elseif {$numcommits == 0} {
2155         show_status "No commits selected"
2156     }
2159 # Stuff relating to the highlighting facility
2161 proc ishighlighted {row} {
2162     global vhighlights fhighlights nhighlights rhighlights
2164     if {[info exists nhighlights($row)] && $nhighlights($row) > 0} {
2165         return $nhighlights($row)
2166     }
2167     if {[info exists vhighlights($row)] && $vhighlights($row) > 0} {
2168         return $vhighlights($row)
2169     }
2170     if {[info exists fhighlights($row)] && $fhighlights($row) > 0} {
2171         return $fhighlights($row)
2172     }
2173     if {[info exists rhighlights($row)] && $rhighlights($row) > 0} {
2174         return $rhighlights($row)
2175     }
2176     return 0
2179 proc bolden {row font} {
2180     global canv linehtag selectedline boldrows
2182     lappend boldrows $row
2183     $canv itemconf $linehtag($row) -font $font
2184     if {[info exists selectedline] && $row == $selectedline} {
2185         $canv delete secsel
2186         set t [eval $canv create rect [$canv bbox $linehtag($row)] \
2187                    -outline {{}} -tags secsel \
2188                    -fill [$canv cget -selectbackground]]
2189         $canv lower $t
2190     }
2193 proc bolden_name {row font} {
2194     global canv2 linentag selectedline boldnamerows
2196     lappend boldnamerows $row
2197     $canv2 itemconf $linentag($row) -font $font
2198     if {[info exists selectedline] && $row == $selectedline} {
2199         $canv2 delete secsel
2200         set t [eval $canv2 create rect [$canv2 bbox $linentag($row)] \
2201                    -outline {{}} -tags secsel \
2202                    -fill [$canv2 cget -selectbackground]]
2203         $canv2 lower $t
2204     }
2207 proc unbolden {} {
2208     global boldrows
2210     set stillbold {}
2211     foreach row $boldrows {
2212         if {![ishighlighted $row]} {
2213             bolden $row mainfont
2214         } else {
2215             lappend stillbold $row
2216         }
2217     }
2218     set boldrows $stillbold
2221 proc addvhighlight {n} {
2222     global hlview curview viewdata vhl_done vhighlights commitidx
2224     if {[info exists hlview]} {
2225         delvhighlight
2226     }
2227     set hlview $n
2228     if {$n != $curview && ![info exists viewdata($n)]} {
2229         set viewdata($n) [list getcommits {{}} 0 0 0]
2230         set vparentlist($n) {}
2231         set vdisporder($n) {}
2232         set vcmitlisted($n) {}
2233         start_rev_list $n
2234     }
2235     set vhl_done $commitidx($hlview)
2236     if {$vhl_done > 0} {
2237         drawvisible
2238     }
2241 proc delvhighlight {} {
2242     global hlview vhighlights
2244     if {![info exists hlview]} return
2245     unset hlview
2246     catch {unset vhighlights}
2247     unbolden
2250 proc vhighlightmore {} {
2251     global hlview vhl_done commitidx vhighlights
2252     global displayorder vdisporder curview
2254     set max $commitidx($hlview)
2255     if {$hlview == $curview} {
2256         set disp $displayorder
2257     } else {
2258         set disp $vdisporder($hlview)
2259     }
2260     set vr [visiblerows]
2261     set r0 [lindex $vr 0]
2262     set r1 [lindex $vr 1]
2263     for {set i $vhl_done} {$i < $max} {incr i} {
2264         set id [lindex $disp $i]
2265         if {[info exists commitrow($curview,$id)]} {
2266             set row $commitrow($curview,$id)
2267             if {$r0 <= $row && $row <= $r1} {
2268                 if {![highlighted $row]} {
2269                     bolden $row mainfontbold
2270                 }
2271                 set vhighlights($row) 1
2272             }
2273         }
2274     }
2275     set vhl_done $max
2278 proc askvhighlight {row id} {
2279     global hlview vhighlights commitrow iddrawn
2281     if {[info exists commitrow($hlview,$id)]} {
2282         if {[info exists iddrawn($id)] && ![ishighlighted $row]} {
2283             bolden $row mainfontbold
2284         }
2285         set vhighlights($row) 1
2286     } else {
2287         set vhighlights($row) 0
2288     }
2291 proc hfiles_change {} {
2292     global highlight_files filehighlight fhighlights fh_serial
2293     global highlight_paths gdttype
2295     if {[info exists filehighlight]} {
2296         # delete previous highlights
2297         catch {close $filehighlight}
2298         unset filehighlight
2299         catch {unset fhighlights}
2300         unbolden
2301         unhighlight_filelist
2302     }
2303     set highlight_paths {}
2304     after cancel do_file_hl $fh_serial
2305     incr fh_serial
2306     if {$highlight_files ne {}} {
2307         after 300 do_file_hl $fh_serial
2308     }
2311 proc gdttype_change {name ix op} {
2312     global gdttype highlight_files findstring findpattern
2314     stopfinding
2315     if {$findstring ne {}} {
2316         if {$gdttype eq "containing:"} {
2317             if {$highlight_files ne {}} {
2318                 set highlight_files {}
2319                 hfiles_change
2320             }
2321             findcom_change
2322         } else {
2323             if {$findpattern ne {}} {
2324                 set findpattern {}
2325                 findcom_change
2326             }
2327             set highlight_files $findstring
2328             hfiles_change
2329         }
2330         drawvisible
2331     }
2332     # enable/disable findtype/findloc menus too
2335 proc find_change {name ix op} {
2336     global gdttype findstring highlight_files
2338     stopfinding
2339     if {$gdttype eq "containing:"} {
2340         findcom_change
2341     } else {
2342         if {$highlight_files ne $findstring} {
2343             set highlight_files $findstring
2344             hfiles_change
2345         }
2346     }
2347     drawvisible
2350 proc findcom_change args {
2351     global nhighlights boldnamerows
2352     global findpattern findtype findstring gdttype
2354     stopfinding
2355     # delete previous highlights, if any
2356     foreach row $boldnamerows {
2357         bolden_name $row mainfont
2358     }
2359     set boldnamerows {}
2360     catch {unset nhighlights}
2361     unbolden
2362     unmarkmatches
2363     if {$gdttype ne "containing:" || $findstring eq {}} {
2364         set findpattern {}
2365     } elseif {$findtype eq "Regexp"} {
2366         set findpattern $findstring
2367     } else {
2368         set e [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} \
2369                    $findstring]
2370         set findpattern "*$e*"
2371     }
2374 proc makepatterns {l} {
2375     set ret {}
2376     foreach e $l {
2377         set ee [string map {"*" "\\*" "?" "\\?" "\[" "\\\[" "\\" "\\\\"} $e]
2378         if {[string index $ee end] eq "/"} {
2379             lappend ret "$ee*"
2380         } else {
2381             lappend ret $ee
2382             lappend ret "$ee/*"
2383         }
2384     }
2385     return $ret
2388 proc do_file_hl {serial} {
2389     global highlight_files filehighlight highlight_paths gdttype fhl_list
2391     if {$gdttype eq "touching paths:"} {
2392         if {[catch {set paths [shellsplit $highlight_files]}]} return
2393         set highlight_paths [makepatterns $paths]
2394         highlight_filelist
2395         set gdtargs [concat -- $paths]
2396     } elseif {$gdttype eq "adding/removing string:"} {
2397         set gdtargs [list "-S$highlight_files"]
2398     } else {
2399         # must be "containing:", i.e. we're searching commit info
2400         return
2401     }
2402     set cmd [concat | git diff-tree -r -s --stdin $gdtargs]
2403     set filehighlight [open $cmd r+]
2404     fconfigure $filehighlight -blocking 0
2405     filerun $filehighlight readfhighlight
2406     set fhl_list {}
2407     drawvisible
2408     flushhighlights
2411 proc flushhighlights {} {
2412     global filehighlight fhl_list
2414     if {[info exists filehighlight]} {
2415         lappend fhl_list {}
2416         puts $filehighlight ""
2417         flush $filehighlight
2418     }
2421 proc askfilehighlight {row id} {
2422     global filehighlight fhighlights fhl_list
2424     lappend fhl_list $id
2425     set fhighlights($row) -1
2426     puts $filehighlight $id
2429 proc readfhighlight {} {
2430     global filehighlight fhighlights commitrow curview iddrawn
2431     global fhl_list find_dirn
2433     if {![info exists filehighlight]} {
2434         return 0
2435     }
2436     set nr 0
2437     while {[incr nr] <= 100 && [gets $filehighlight line] >= 0} {
2438         set line [string trim $line]
2439         set i [lsearch -exact $fhl_list $line]
2440         if {$i < 0} continue
2441         for {set j 0} {$j < $i} {incr j} {
2442             set id [lindex $fhl_list $j]
2443             if {[info exists commitrow($curview,$id)]} {
2444                 set fhighlights($commitrow($curview,$id)) 0
2445             }
2446         }
2447         set fhl_list [lrange $fhl_list [expr {$i+1}] end]
2448         if {$line eq {}} continue
2449         if {![info exists commitrow($curview,$line)]} continue
2450         set row $commitrow($curview,$line)
2451         if {[info exists iddrawn($line)] && ![ishighlighted $row]} {
2452             bolden $row mainfontbold
2453         }
2454         set fhighlights($row) 1
2455     }
2456     if {[eof $filehighlight]} {
2457         # strange...
2458         puts "oops, git diff-tree died"
2459         catch {close $filehighlight}
2460         unset filehighlight
2461         return 0
2462     }
2463     if {[info exists find_dirn]} {
2464         run findmore
2465     }
2466     return 1
2469 proc doesmatch {f} {
2470     global findtype findpattern
2472     if {$findtype eq "Regexp"} {
2473         return [regexp $findpattern $f]
2474     } elseif {$findtype eq "IgnCase"} {
2475         return [string match -nocase $findpattern $f]
2476     } else {
2477         return [string match $findpattern $f]
2478     }
2481 proc askfindhighlight {row id} {
2482     global nhighlights commitinfo iddrawn
2483     global findloc
2484     global markingmatches
2486     if {![info exists commitinfo($id)]} {
2487         getcommit $id
2488     }
2489     set info $commitinfo($id)
2490     set isbold 0
2491     set fldtypes {Headline Author Date Committer CDate Comments}
2492     foreach f $info ty $fldtypes {
2493         if {($findloc eq "All fields" || $findloc eq $ty) &&
2494             [doesmatch $f]} {
2495             if {$ty eq "Author"} {
2496                 set isbold 2
2497                 break
2498             }
2499             set isbold 1
2500         }
2501     }
2502     if {$isbold && [info exists iddrawn($id)]} {
2503         if {![ishighlighted $row]} {
2504             bolden $row mainfontbold
2505             if {$isbold > 1} {
2506                 bolden_name $row mainfontbold
2507             }
2508         }
2509         if {$markingmatches} {
2510             markrowmatches $row $id
2511         }
2512     }
2513     set nhighlights($row) $isbold
2516 proc markrowmatches {row id} {
2517     global canv canv2 linehtag linentag commitinfo findloc
2519     set headline [lindex $commitinfo($id) 0]
2520     set author [lindex $commitinfo($id) 1]
2521     $canv delete match$row
2522     $canv2 delete match$row
2523     if {$findloc eq "All fields" || $findloc eq "Headline"} {
2524         set m [findmatches $headline]
2525         if {$m ne {}} {
2526             markmatches $canv $row $headline $linehtag($row) $m \
2527                 [$canv itemcget $linehtag($row) -font] $row
2528         }
2529     }
2530     if {$findloc eq "All fields" || $findloc eq "Author"} {
2531         set m [findmatches $author]
2532         if {$m ne {}} {
2533             markmatches $canv2 $row $author $linentag($row) $m \
2534                 [$canv2 itemcget $linentag($row) -font] $row
2535         }
2536     }
2539 proc vrel_change {name ix op} {
2540     global highlight_related
2542     rhighlight_none
2543     if {$highlight_related ne "None"} {
2544         run drawvisible
2545     }
2548 # prepare for testing whether commits are descendents or ancestors of a
2549 proc rhighlight_sel {a} {
2550     global descendent desc_todo ancestor anc_todo
2551     global highlight_related rhighlights
2553     catch {unset descendent}
2554     set desc_todo [list $a]
2555     catch {unset ancestor}
2556     set anc_todo [list $a]
2557     if {$highlight_related ne "None"} {
2558         rhighlight_none
2559         run drawvisible
2560     }
2563 proc rhighlight_none {} {
2564     global rhighlights
2566     catch {unset rhighlights}
2567     unbolden
2570 proc is_descendent {a} {
2571     global curview children commitrow descendent desc_todo
2573     set v $curview
2574     set la $commitrow($v,$a)
2575     set todo $desc_todo
2576     set leftover {}
2577     set done 0
2578     for {set i 0} {$i < [llength $todo]} {incr i} {
2579         set do [lindex $todo $i]
2580         if {$commitrow($v,$do) < $la} {
2581             lappend leftover $do
2582             continue
2583         }
2584         foreach nk $children($v,$do) {
2585             if {![info exists descendent($nk)]} {
2586                 set descendent($nk) 1
2587                 lappend todo $nk
2588                 if {$nk eq $a} {
2589                     set done 1
2590                 }
2591             }
2592         }
2593         if {$done} {
2594             set desc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2595             return
2596         }
2597     }
2598     set descendent($a) 0
2599     set desc_todo $leftover
2602 proc is_ancestor {a} {
2603     global curview parentlist commitrow ancestor anc_todo
2605     set v $curview
2606     set la $commitrow($v,$a)
2607     set todo $anc_todo
2608     set leftover {}
2609     set done 0
2610     for {set i 0} {$i < [llength $todo]} {incr i} {
2611         set do [lindex $todo $i]
2612         if {![info exists commitrow($v,$do)] || $commitrow($v,$do) > $la} {
2613             lappend leftover $do
2614             continue
2615         }
2616         foreach np [lindex $parentlist $commitrow($v,$do)] {
2617             if {![info exists ancestor($np)]} {
2618                 set ancestor($np) 1
2619                 lappend todo $np
2620                 if {$np eq $a} {
2621                     set done 1
2622                 }
2623             }
2624         }
2625         if {$done} {
2626             set anc_todo [concat $leftover [lrange $todo [expr {$i+1}] end]]
2627             return
2628         }
2629     }
2630     set ancestor($a) 0
2631     set anc_todo $leftover
2634 proc askrelhighlight {row id} {
2635     global descendent highlight_related iddrawn rhighlights
2636     global selectedline ancestor
2638     if {![info exists selectedline]} return
2639     set isbold 0
2640     if {$highlight_related eq "Descendent" ||
2641         $highlight_related eq "Not descendent"} {
2642         if {![info exists descendent($id)]} {
2643             is_descendent $id
2644         }
2645         if {$descendent($id) == ($highlight_related eq "Descendent")} {
2646             set isbold 1
2647         }
2648     } elseif {$highlight_related eq "Ancestor" ||
2649               $highlight_related eq "Not ancestor"} {
2650         if {![info exists ancestor($id)]} {
2651             is_ancestor $id
2652         }
2653         if {$ancestor($id) == ($highlight_related eq "Ancestor")} {
2654             set isbold 1
2655         }
2656     }
2657     if {[info exists iddrawn($id)]} {
2658         if {$isbold && ![ishighlighted $row]} {
2659             bolden $row mainfontbold
2660         }
2661     }
2662     set rhighlights($row) $isbold
2665 # Graph layout functions
2667 proc shortids {ids} {
2668     set res {}
2669     foreach id $ids {
2670         if {[llength $id] > 1} {
2671             lappend res [shortids $id]
2672         } elseif {[regexp {^[0-9a-f]{40}$} $id]} {
2673             lappend res [string range $id 0 7]
2674         } else {
2675             lappend res $id
2676         }
2677     }
2678     return $res
2681 proc ntimes {n o} {
2682     set ret {}
2683     set o [list $o]
2684     for {set mask 1} {$mask <= $n} {incr mask $mask} {
2685         if {($n & $mask) != 0} {
2686             set ret [concat $ret $o]
2687         }
2688         set o [concat $o $o]
2689     }
2690     return $ret
2693 # Work out where id should go in idlist so that order-token
2694 # values increase from left to right
2695 proc idcol {idlist id {i 0}} {
2696     global ordertok curview
2698     set t $ordertok($curview,$id)
2699     if {$i >= [llength $idlist] ||
2700         $t < $ordertok($curview,[lindex $idlist $i])} {
2701         if {$i > [llength $idlist]} {
2702             set i [llength $idlist]
2703         }
2704         while {[incr i -1] >= 0 &&
2705                $t < $ordertok($curview,[lindex $idlist $i])} {}
2706         incr i
2707     } else {
2708         if {$t > $ordertok($curview,[lindex $idlist $i])} {
2709             while {[incr i] < [llength $idlist] &&
2710                    $t >= $ordertok($curview,[lindex $idlist $i])} {}
2711         }
2712     }
2713     return $i
2716 proc initlayout {} {
2717     global rowidlist rowisopt rowfinal displayorder commitlisted
2718     global numcommits canvxmax canv
2719     global nextcolor
2720     global parentlist
2721     global colormap rowtextx
2722     global selectfirst
2724     set numcommits 0
2725     set displayorder {}
2726     set commitlisted {}
2727     set parentlist {}
2728     set nextcolor 0
2729     set rowidlist {}
2730     set rowisopt {}
2731     set rowfinal {}
2732     set canvxmax [$canv cget -width]
2733     catch {unset colormap}
2734     catch {unset rowtextx}
2735     set selectfirst 1
2738 proc setcanvscroll {} {
2739     global canv canv2 canv3 numcommits linespc canvxmax canvy0
2741     set ymax [expr {$canvy0 + ($numcommits - 0.5) * $linespc + 2}]
2742     $canv conf -scrollregion [list 0 0 $canvxmax $ymax]
2743     $canv2 conf -scrollregion [list 0 0 0 $ymax]
2744     $canv3 conf -scrollregion [list 0 0 0 $ymax]
2747 proc visiblerows {} {
2748     global canv numcommits linespc
2750     set ymax [lindex [$canv cget -scrollregion] 3]
2751     if {$ymax eq {} || $ymax == 0} return
2752     set f [$canv yview]
2753     set y0 [expr {int([lindex $f 0] * $ymax)}]
2754     set r0 [expr {int(($y0 - 3) / $linespc) - 1}]
2755     if {$r0 < 0} {
2756         set r0 0
2757     }
2758     set y1 [expr {int([lindex $f 1] * $ymax)}]
2759     set r1 [expr {int(($y1 - 3) / $linespc) + 1}]
2760     if {$r1 >= $numcommits} {
2761         set r1 [expr {$numcommits - 1}]
2762     }
2763     return [list $r0 $r1]
2766 proc layoutmore {} {
2767     global commitidx viewcomplete numcommits
2768     global uparrowlen downarrowlen mingaplen curview
2770     set show $commitidx($curview)
2771     if {$show > $numcommits || $viewcomplete($curview)} {
2772         showstuff $show $viewcomplete($curview)
2773     }
2776 proc showstuff {canshow last} {
2777     global numcommits commitrow pending_select selectedline curview
2778     global mainheadid displayorder selectfirst
2779     global lastscrollset commitinterest
2781     if {$numcommits == 0} {
2782         global phase
2783         set phase "incrdraw"
2784         allcanvs delete all
2785     }
2786     set r0 $numcommits
2787     set prev $numcommits
2788     set numcommits $canshow
2789     set t [clock clicks -milliseconds]
2790     if {$prev < 100 || $last || $t - $lastscrollset > 500} {
2791         set lastscrollset $t
2792         setcanvscroll
2793     }
2794     set rows [visiblerows]
2795     set r1 [lindex $rows 1]
2796     if {$r1 >= $canshow} {
2797         set r1 [expr {$canshow - 1}]
2798     }
2799     if {$r0 <= $r1} {
2800         drawcommits $r0 $r1
2801     }
2802     if {[info exists pending_select] &&
2803         [info exists commitrow($curview,$pending_select)] &&
2804         $commitrow($curview,$pending_select) < $numcommits} {
2805         selectline $commitrow($curview,$pending_select) 1
2806     }
2807     if {$selectfirst} {
2808         if {[info exists selectedline] || [info exists pending_select]} {
2809             set selectfirst 0
2810         } else {
2811             set l [first_real_row]
2812             selectline $l 1
2813             set selectfirst 0
2814         }
2815     }
2818 proc doshowlocalchanges {} {
2819     global curview mainheadid phase commitrow
2821     if {[info exists commitrow($curview,$mainheadid)] &&
2822         ($phase eq {} || $commitrow($curview,$mainheadid) < $numcommits - 1)} {
2823         dodiffindex
2824     } elseif {$phase ne {}} {
2825         lappend commitinterest($mainheadid) {}
2826     }
2829 proc dohidelocalchanges {} {
2830     global localfrow localirow lserial
2832     if {$localfrow >= 0} {
2833         removerow $localfrow
2834         set localfrow -1
2835         if {$localirow > 0} {
2836             incr localirow -1
2837         }
2838     }
2839     if {$localirow >= 0} {
2840         removerow $localirow
2841         set localirow -1
2842     }
2843     incr lserial
2846 # spawn off a process to do git diff-index --cached HEAD
2847 proc dodiffindex {} {
2848     global localirow localfrow lserial showlocalchanges
2850     if {!$showlocalchanges} return
2851     incr lserial
2852     set localfrow -1
2853     set localirow -1
2854     set fd [open "|git diff-index --cached HEAD" r]
2855     fconfigure $fd -blocking 0
2856     filerun $fd [list readdiffindex $fd $lserial]
2859 proc readdiffindex {fd serial} {
2860     global localirow commitrow mainheadid nullid2 curview
2861     global commitinfo commitdata lserial
2863     set isdiff 1
2864     if {[gets $fd line] < 0} {
2865         if {![eof $fd]} {
2866             return 1
2867         }
2868         set isdiff 0
2869     }
2870     # we only need to see one line and we don't really care what it says...
2871     close $fd
2873     # now see if there are any local changes not checked in to the index
2874     if {$serial == $lserial} {
2875         set fd [open "|git diff-files" r]
2876         fconfigure $fd -blocking 0
2877         filerun $fd [list readdifffiles $fd $serial]
2878     }
2880     if {$isdiff && $serial == $lserial && $localirow == -1} {
2881         # add the line for the changes in the index to the graph
2882         set localirow $commitrow($curview,$mainheadid)
2883         set hl "Local changes checked in to index but not committed"
2884         set commitinfo($nullid2) [list  $hl {} {} {} {} "    $hl\n"]
2885         set commitdata($nullid2) "\n    $hl\n"
2886         insertrow $localirow $nullid2
2887     }
2888     return 0
2891 proc readdifffiles {fd serial} {
2892     global localirow localfrow commitrow mainheadid nullid curview
2893     global commitinfo commitdata lserial
2895     set isdiff 1
2896     if {[gets $fd line] < 0} {
2897         if {![eof $fd]} {
2898             return 1
2899         }
2900         set isdiff 0
2901     }
2902     # we only need to see one line and we don't really care what it says...
2903     close $fd
2905     if {$isdiff && $serial == $lserial && $localfrow == -1} {
2906         # add the line for the local diff to the graph
2907         if {$localirow >= 0} {
2908             set localfrow $localirow
2909             incr localirow
2910         } else {
2911             set localfrow $commitrow($curview,$mainheadid)
2912         }
2913         set hl "Local uncommitted changes, not checked in to index"
2914         set commitinfo($nullid) [list  $hl {} {} {} {} "    $hl\n"]
2915         set commitdata($nullid) "\n    $hl\n"
2916         insertrow $localfrow $nullid
2917     }
2918     return 0
2921 proc nextuse {id row} {
2922     global commitrow curview children
2924     if {[info exists children($curview,$id)]} {
2925         foreach kid $children($curview,$id) {
2926             if {![info exists commitrow($curview,$kid)]} {
2927                 return -1
2928             }
2929             if {$commitrow($curview,$kid) > $row} {
2930                 return $commitrow($curview,$kid)
2931             }
2932         }
2933     }
2934     if {[info exists commitrow($curview,$id)]} {
2935         return $commitrow($curview,$id)
2936     }
2937     return -1
2940 proc prevuse {id row} {
2941     global commitrow curview children
2943     set ret -1
2944     if {[info exists children($curview,$id)]} {
2945         foreach kid $children($curview,$id) {
2946             if {![info exists commitrow($curview,$kid)]} break
2947             if {$commitrow($curview,$kid) < $row} {
2948                 set ret $commitrow($curview,$kid)
2949             }
2950         }
2951     }
2952     return $ret
2955 proc make_idlist {row} {
2956     global displayorder parentlist uparrowlen downarrowlen mingaplen
2957     global commitidx curview ordertok children commitrow
2959     set r [expr {$row - $mingaplen - $downarrowlen - 1}]
2960     if {$r < 0} {
2961         set r 0
2962     }
2963     set ra [expr {$row - $downarrowlen}]
2964     if {$ra < 0} {
2965         set ra 0
2966     }
2967     set rb [expr {$row + $uparrowlen}]
2968     if {$rb > $commitidx($curview)} {
2969         set rb $commitidx($curview)
2970     }
2971     set ids {}
2972     for {} {$r < $ra} {incr r} {
2973         set nextid [lindex $displayorder [expr {$r + 1}]]
2974         foreach p [lindex $parentlist $r] {
2975             if {$p eq $nextid} continue
2976             set rn [nextuse $p $r]
2977             if {$rn >= $row &&
2978                 $rn <= $r + $downarrowlen + $mingaplen + $uparrowlen} {
2979                 lappend ids [list $ordertok($curview,$p) $p]
2980             }
2981         }
2982     }
2983     for {} {$r < $row} {incr r} {
2984         set nextid [lindex $displayorder [expr {$r + 1}]]
2985         foreach p [lindex $parentlist $r] {
2986             if {$p eq $nextid} continue
2987             set rn [nextuse $p $r]
2988             if {$rn < 0 || $rn >= $row} {
2989                 lappend ids [list $ordertok($curview,$p) $p]
2990             }
2991         }
2992     }
2993     set id [lindex $displayorder $row]
2994     lappend ids [list $ordertok($curview,$id) $id]
2995     while {$r < $rb} {
2996         foreach p [lindex $parentlist $r] {
2997             set firstkid [lindex $children($curview,$p) 0]
2998             if {$commitrow($curview,$firstkid) < $row} {
2999                 lappend ids [list $ordertok($curview,$p) $p]
3000             }
3001         }
3002         incr r
3003         set id [lindex $displayorder $r]
3004         if {$id ne {}} {
3005             set firstkid [lindex $children($curview,$id) 0]
3006             if {$firstkid ne {} && $commitrow($curview,$firstkid) < $row} {
3007                 lappend ids [list $ordertok($curview,$id) $id]
3008             }
3009         }
3010     }
3011     set idlist {}
3012     foreach idx [lsort -unique $ids] {
3013         lappend idlist [lindex $idx 1]
3014     }
3015     return $idlist
3018 proc rowsequal {a b} {
3019     while {[set i [lsearch -exact $a {}]] >= 0} {
3020         set a [lreplace $a $i $i]
3021     }
3022     while {[set i [lsearch -exact $b {}]] >= 0} {
3023         set b [lreplace $b $i $i]
3024     }
3025     return [expr {$a eq $b}]
3028 proc makeupline {id row rend col} {
3029     global rowidlist uparrowlen downarrowlen mingaplen
3031     for {set r $rend} {1} {set r $rstart} {
3032         set rstart [prevuse $id $r]
3033         if {$rstart < 0} return
3034         if {$rstart < $row} break
3035     }
3036     if {$rstart + $uparrowlen + $mingaplen + $downarrowlen < $rend} {
3037         set rstart [expr {$rend - $uparrowlen - 1}]
3038     }
3039     for {set r $rstart} {[incr r] <= $row} {} {
3040         set idlist [lindex $rowidlist $r]
3041         if {$idlist ne {} && [lsearch -exact $idlist $id] < 0} {
3042             set col [idcol $idlist $id $col]
3043             lset rowidlist $r [linsert $idlist $col $id]
3044             changedrow $r
3045         }
3046     }
3049 proc layoutrows {row endrow} {
3050     global rowidlist rowisopt rowfinal displayorder
3051     global uparrowlen downarrowlen maxwidth mingaplen
3052     global children parentlist
3053     global commitidx viewcomplete curview commitrow
3055     set idlist {}
3056     if {$row > 0} {
3057         set rm1 [expr {$row - 1}]
3058         foreach id [lindex $rowidlist $rm1] {
3059             if {$id ne {}} {
3060                 lappend idlist $id
3061             }
3062         }
3063         set final [lindex $rowfinal $rm1]
3064     }
3065     for {} {$row < $endrow} {incr row} {
3066         set rm1 [expr {$row - 1}]
3067         if {$rm1 < 0 || $idlist eq {}} {
3068             set idlist [make_idlist $row]
3069             set final 1
3070         } else {
3071             set id [lindex $displayorder $rm1]
3072             set col [lsearch -exact $idlist $id]
3073             set idlist [lreplace $idlist $col $col]
3074             foreach p [lindex $parentlist $rm1] {
3075                 if {[lsearch -exact $idlist $p] < 0} {
3076                     set col [idcol $idlist $p $col]
3077                     set idlist [linsert $idlist $col $p]
3078                     # if not the first child, we have to insert a line going up
3079                     if {$id ne [lindex $children($curview,$p) 0]} {
3080                         makeupline $p $rm1 $row $col
3081                     }
3082                 }
3083             }
3084             set id [lindex $displayorder $row]
3085             if {$row > $downarrowlen} {
3086                 set termrow [expr {$row - $downarrowlen - 1}]
3087                 foreach p [lindex $parentlist $termrow] {
3088                     set i [lsearch -exact $idlist $p]
3089                     if {$i < 0} continue
3090                     set nr [nextuse $p $termrow]
3091                     if {$nr < 0 || $nr >= $row + $mingaplen + $uparrowlen} {
3092                         set idlist [lreplace $idlist $i $i]
3093                     }
3094                 }
3095             }
3096             set col [lsearch -exact $idlist $id]
3097             if {$col < 0} {
3098                 set col [idcol $idlist $id]
3099                 set idlist [linsert $idlist $col $id]
3100                 if {$children($curview,$id) ne {}} {
3101                     makeupline $id $rm1 $row $col
3102                 }
3103             }
3104             set r [expr {$row + $uparrowlen - 1}]
3105             if {$r < $commitidx($curview)} {
3106                 set x $col
3107                 foreach p [lindex $parentlist $r] {
3108                     if {[lsearch -exact $idlist $p] >= 0} continue
3109                     set fk [lindex $children($curview,$p) 0]
3110                     if {$commitrow($curview,$fk) < $row} {
3111                         set x [idcol $idlist $p $x]
3112                         set idlist [linsert $idlist $x $p]
3113                     }
3114                 }
3115                 if {[incr r] < $commitidx($curview)} {
3116                     set p [lindex $displayorder $r]
3117                     if {[lsearch -exact $idlist $p] < 0} {
3118                         set fk [lindex $children($curview,$p) 0]
3119                         if {$fk ne {} && $commitrow($curview,$fk) < $row} {
3120                             set x [idcol $idlist $p $x]
3121                             set idlist [linsert $idlist $x $p]
3122                         }
3123                     }
3124                 }
3125             }
3126         }
3127         if {$final && !$viewcomplete($curview) &&
3128             $row + $uparrowlen + $mingaplen + $downarrowlen
3129                 >= $commitidx($curview)} {
3130             set final 0
3131         }
3132         set l [llength $rowidlist]
3133         if {$row == $l} {
3134             lappend rowidlist $idlist
3135             lappend rowisopt 0
3136             lappend rowfinal $final
3137         } elseif {$row < $l} {
3138             if {![rowsequal $idlist [lindex $rowidlist $row]]} {
3139                 lset rowidlist $row $idlist
3140                 changedrow $row
3141             }
3142             lset rowfinal $row $final
3143         } else {
3144             set pad [ntimes [expr {$row - $l}] {}]
3145             set rowidlist [concat $rowidlist $pad]
3146             lappend rowidlist $idlist
3147             set rowfinal [concat $rowfinal $pad]
3148             lappend rowfinal $final
3149             set rowisopt [concat $rowisopt [ntimes [expr {$row - $l + 1}] 0]]
3150         }
3151     }
3152     return $row
3155 proc changedrow {row} {
3156     global displayorder iddrawn rowisopt need_redisplay
3158     set l [llength $rowisopt]
3159     if {$row < $l} {
3160         lset rowisopt $row 0
3161         if {$row + 1 < $l} {
3162             lset rowisopt [expr {$row + 1}] 0
3163             if {$row + 2 < $l} {
3164                 lset rowisopt [expr {$row + 2}] 0
3165             }
3166         }
3167     }
3168     set id [lindex $displayorder $row]
3169     if {[info exists iddrawn($id)]} {
3170         set need_redisplay 1
3171     }
3174 proc insert_pad {row col npad} {
3175     global rowidlist
3177     set pad [ntimes $npad {}]
3178     set idlist [lindex $rowidlist $row]
3179     set bef [lrange $idlist 0 [expr {$col - 1}]]
3180     set aft [lrange $idlist $col end]
3181     set i [lsearch -exact $aft {}]
3182     if {$i > 0} {
3183         set aft [lreplace $aft $i $i]
3184     }
3185     lset rowidlist $row [concat $bef $pad $aft]
3186     changedrow $row
3189 proc optimize_rows {row col endrow} {
3190     global rowidlist rowisopt displayorder curview children
3192     if {$row < 1} {
3193         set row 1
3194     }
3195     for {} {$row < $endrow} {incr row; set col 0} {
3196         if {[lindex $rowisopt $row]} continue
3197         set haspad 0
3198         set y0 [expr {$row - 1}]
3199         set ym [expr {$row - 2}]
3200         set idlist [lindex $rowidlist $row]
3201         set previdlist [lindex $rowidlist $y0]
3202         if {$idlist eq {} || $previdlist eq {}} continue
3203         if {$ym >= 0} {
3204             set pprevidlist [lindex $rowidlist $ym]
3205             if {$pprevidlist eq {}} continue
3206         } else {
3207             set pprevidlist {}
3208         }
3209         set x0 -1
3210         set xm -1
3211         for {} {$col < [llength $idlist]} {incr col} {
3212             set id [lindex $idlist $col]
3213             if {[lindex $previdlist $col] eq $id} continue
3214             if {$id eq {}} {
3215                 set haspad 1
3216                 continue
3217             }
3218             set x0 [lsearch -exact $previdlist $id]
3219             if {$x0 < 0} continue
3220             set z [expr {$x0 - $col}]
3221             set isarrow 0
3222             set z0 {}
3223             if {$ym >= 0} {
3224                 set xm [lsearch -exact $pprevidlist $id]
3225                 if {$xm >= 0} {
3226                     set z0 [expr {$xm - $x0}]
3227                 }
3228             }
3229             if {$z0 eq {}} {
3230                 # if row y0 is the first child of $id then it's not an arrow
3231                 if {[lindex $children($curview,$id) 0] ne
3232                     [lindex $displayorder $y0]} {
3233                     set isarrow 1
3234                 }
3235             }
3236             if {!$isarrow && $id ne [lindex $displayorder $row] &&
3237                 [lsearch -exact [lindex $rowidlist [expr {$row+1}]] $id] < 0} {
3238                 set isarrow 1
3239             }
3240             # Looking at lines from this row to the previous row,
3241             # make them go straight up if they end in an arrow on
3242             # the previous row; otherwise make them go straight up
3243             # or at 45 degrees.
3244             if {$z < -1 || ($z < 0 && $isarrow)} {
3245                 # Line currently goes left too much;
3246                 # insert pads in the previous row, then optimize it
3247                 set npad [expr {-1 - $z + $isarrow}]
3248                 insert_pad $y0 $x0 $npad
3249                 if {$y0 > 0} {
3250                     optimize_rows $y0 $x0 $row
3251                 }
3252                 set previdlist [lindex $rowidlist $y0]
3253                 set x0 [lsearch -exact $previdlist $id]
3254                 set z [expr {$x0 - $col}]
3255                 if {$z0 ne {}} {
3256                     set pprevidlist [lindex $rowidlist $ym]
3257                     set xm [lsearch -exact $pprevidlist $id]
3258                     set z0 [expr {$xm - $x0}]
3259                 }
3260             } elseif {$z > 1 || ($z > 0 && $isarrow)} {
3261                 # Line currently goes right too much;
3262                 # insert pads in this line
3263                 set npad [expr {$z - 1 + $isarrow}]
3264                 insert_pad $row $col $npad
3265                 set idlist [lindex $rowidlist $row]
3266                 incr col $npad
3267                 set z [expr {$x0 - $col}]
3268                 set haspad 1
3269             }
3270             if {$z0 eq {} && !$isarrow && $ym >= 0} {
3271                 # this line links to its first child on row $row-2
3272                 set id [lindex $displayorder $ym]
3273                 set xc [lsearch -exact $pprevidlist $id]
3274                 if {$xc >= 0} {
3275                     set z0 [expr {$xc - $x0}]
3276                 }
3277             }
3278             # avoid lines jigging left then immediately right
3279             if {$z0 ne {} && $z < 0 && $z0 > 0} {
3280                 insert_pad $y0 $x0 1
3281                 incr x0
3282                 optimize_rows $y0 $x0 $row
3283                 set previdlist [lindex $rowidlist $y0]
3284             }
3285         }
3286         if {!$haspad} {
3287             # Find the first column that doesn't have a line going right
3288             for {set col [llength $idlist]} {[incr col -1] >= 0} {} {
3289                 set id [lindex $idlist $col]
3290                 if {$id eq {}} break
3291                 set x0 [lsearch -exact $previdlist $id]
3292                 if {$x0 < 0} {
3293                     # check if this is the link to the first child
3294                     set kid [lindex $displayorder $y0]
3295                     if {[lindex $children($curview,$id) 0] eq $kid} {
3296                         # it is, work out offset to child
3297                         set x0 [lsearch -exact $previdlist $kid]
3298                     }
3299                 }
3300                 if {$x0 <= $col} break
3301             }
3302             # Insert a pad at that column as long as it has a line and
3303             # isn't the last column
3304             if {$x0 >= 0 && [incr col] < [llength $idlist]} {
3305                 set idlist [linsert $idlist $col {}]
3306                 lset rowidlist $row $idlist
3307                 changedrow $row
3308             }
3309         }
3310     }
3313 proc xc {row col} {
3314     global canvx0 linespc
3315     return [expr {$canvx0 + $col * $linespc}]
3318 proc yc {row} {
3319     global canvy0 linespc
3320     return [expr {$canvy0 + $row * $linespc}]
3323 proc linewidth {id} {
3324     global thickerline lthickness
3326     set wid $lthickness
3327     if {[info exists thickerline] && $id eq $thickerline} {
3328         set wid [expr {2 * $lthickness}]
3329     }
3330     return $wid
3333 proc rowranges {id} {
3334     global commitrow curview children uparrowlen downarrowlen
3335     global rowidlist
3337     set kids $children($curview,$id)
3338     if {$kids eq {}} {
3339         return {}
3340     }
3341     set ret {}
3342     lappend kids $id
3343     foreach child $kids {
3344         if {![info exists commitrow($curview,$child)]} break
3345         set row $commitrow($curview,$child)
3346         if {![info exists prev]} {
3347             lappend ret [expr {$row + 1}]
3348         } else {
3349             if {$row <= $prevrow} {
3350                 puts "oops children out of order [shortids $id] $row < [shortids $prev] $prevrow"
3351             }
3352             # see if the line extends the whole way from prevrow to row
3353             if {$row > $prevrow + $uparrowlen + $downarrowlen &&
3354                 [lsearch -exact [lindex $rowidlist \
3355                             [expr {int(($row + $prevrow) / 2)}]] $id] < 0} {
3356                 # it doesn't, see where it ends
3357                 set r [expr {$prevrow + $downarrowlen}]
3358                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3359                     while {[incr r -1] > $prevrow &&
3360                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3361                 } else {
3362                     while {[incr r] <= $row &&
3363                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3364                     incr r -1
3365                 }
3366                 lappend ret $r
3367                 # see where it starts up again
3368                 set r [expr {$row - $uparrowlen}]
3369                 if {[lsearch -exact [lindex $rowidlist $r] $id] < 0} {
3370                     while {[incr r] < $row &&
3371                            [lsearch -exact [lindex $rowidlist $r] $id] < 0} {}
3372                 } else {
3373                     while {[incr r -1] >= $prevrow &&
3374                            [lsearch -exact [lindex $rowidlist $r] $id] >= 0} {}
3375                     incr r
3376                 }
3377                 lappend ret $r
3378             }
3379         }
3380         if {$child eq $id} {
3381             lappend ret $row
3382         }
3383         set prev $id
3384         set prevrow $row
3385     }
3386     return $ret
3389 proc drawlineseg {id row endrow arrowlow} {
3390     global rowidlist displayorder iddrawn linesegs
3391     global canv colormap linespc curview maxlinelen parentlist
3393     set cols [list [lsearch -exact [lindex $rowidlist $row] $id]]
3394     set le [expr {$row + 1}]
3395     set arrowhigh 1
3396     while {1} {
3397         set c [lsearch -exact [lindex $rowidlist $le] $id]
3398         if {$c < 0} {
3399             incr le -1
3400             break
3401         }
3402         lappend cols $c
3403         set x [lindex $displayorder $le]
3404         if {$x eq $id} {
3405             set arrowhigh 0
3406             break
3407         }
3408         if {[info exists iddrawn($x)] || $le == $endrow} {
3409             set c [lsearch -exact [lindex $rowidlist [expr {$le+1}]] $id]
3410             if {$c >= 0} {
3411                 lappend cols $c
3412                 set arrowhigh 0
3413             }
3414             break
3415         }
3416         incr le
3417     }
3418     if {$le <= $row} {
3419         return $row
3420     }
3422     set lines {}
3423     set i 0
3424     set joinhigh 0
3425     if {[info exists linesegs($id)]} {
3426         set lines $linesegs($id)
3427         foreach li $lines {
3428             set r0 [lindex $li 0]
3429             if {$r0 > $row} {
3430                 if {$r0 == $le && [lindex $li 1] - $row <= $maxlinelen} {
3431                     set joinhigh 1
3432                 }
3433                 break
3434             }
3435             incr i
3436         }
3437     }
3438     set joinlow 0
3439     if {$i > 0} {
3440         set li [lindex $lines [expr {$i-1}]]
3441         set r1 [lindex $li 1]
3442         if {$r1 == $row && $le - [lindex $li 0] <= $maxlinelen} {
3443             set joinlow 1
3444         }
3445     }
3447     set x [lindex $cols [expr {$le - $row}]]
3448     set xp [lindex $cols [expr {$le - 1 - $row}]]
3449     set dir [expr {$xp - $x}]
3450     if {$joinhigh} {
3451         set ith [lindex $lines $i 2]
3452         set coords [$canv coords $ith]
3453         set ah [$canv itemcget $ith -arrow]
3454         set arrowhigh [expr {$ah eq "first" || $ah eq "both"}]
3455         set x2 [lindex $cols [expr {$le + 1 - $row}]]
3456         if {$x2 ne {} && $x - $x2 == $dir} {
3457             set coords [lrange $coords 0 end-2]
3458         }
3459     } else {
3460         set coords [list [xc $le $x] [yc $le]]
3461     }
3462     if {$joinlow} {
3463         set itl [lindex $lines [expr {$i-1}] 2]
3464         set al [$canv itemcget $itl -arrow]
3465         set arrowlow [expr {$al eq "last" || $al eq "both"}]
3466     } elseif {$arrowlow} {
3467         if {[lsearch -exact [lindex $rowidlist [expr {$row-1}]] $id] >= 0 ||
3468             [lsearch -exact [lindex $parentlist [expr {$row-1}]] $id] >= 0} {
3469             set arrowlow 0
3470         }
3471     }
3472     set arrow [lindex {none first last both} [expr {$arrowhigh + 2*$arrowlow}]]
3473     for {set y $le} {[incr y -1] > $row} {} {
3474         set x $xp
3475         set xp [lindex $cols [expr {$y - 1 - $row}]]
3476         set ndir [expr {$xp - $x}]
3477         if {$dir != $ndir || $xp < 0} {
3478             lappend coords [xc $y $x] [yc $y]
3479         }
3480         set dir $ndir
3481     }
3482     if {!$joinlow} {
3483         if {$xp < 0} {
3484             # join parent line to first child
3485             set ch [lindex $displayorder $row]
3486             set xc [lsearch -exact [lindex $rowidlist $row] $ch]
3487             if {$xc < 0} {
3488                 puts "oops: drawlineseg: child $ch not on row $row"
3489             } elseif {$xc != $x} {
3490                 if {($arrowhigh && $le == $row + 1) || $dir == 0} {
3491                     set d [expr {int(0.5 * $linespc)}]
3492                     set x1 [xc $row $x]
3493                     if {$xc < $x} {
3494                         set x2 [expr {$x1 - $d}]
3495                     } else {
3496                         set x2 [expr {$x1 + $d}]
3497                     }
3498                     set y2 [yc $row]
3499                     set y1 [expr {$y2 + $d}]
3500                     lappend coords $x1 $y1 $x2 $y2
3501                 } elseif {$xc < $x - 1} {
3502                     lappend coords [xc $row [expr {$x-1}]] [yc $row]
3503                 } elseif {$xc > $x + 1} {
3504                     lappend coords [xc $row [expr {$x+1}]] [yc $row]
3505                 }
3506                 set x $xc
3507             }
3508             lappend coords [xc $row $x] [yc $row]
3509         } else {
3510             set xn [xc $row $xp]
3511             set yn [yc $row]
3512             lappend coords $xn $yn
3513         }
3514         if {!$joinhigh} {
3515             assigncolor $id
3516             set t [$canv create line $coords -width [linewidth $id] \
3517                        -fill $colormap($id) -tags lines.$id -arrow $arrow]
3518             $canv lower $t
3519             bindline $t $id
3520             set lines [linsert $lines $i [list $row $le $t]]
3521         } else {
3522             $canv coords $ith $coords
3523             if {$arrow ne $ah} {
3524                 $canv itemconf $ith -arrow $arrow
3525             }
3526             lset lines $i 0 $row
3527         }
3528     } else {
3529         set xo [lsearch -exact [lindex $rowidlist [expr {$row - 1}]] $id]
3530         set ndir [expr {$xo - $xp}]
3531         set clow [$canv coords $itl]
3532         if {$dir == $ndir} {
3533             set clow [lrange $clow 2 end]
3534         }
3535         set coords [concat $coords $clow]
3536         if {!$joinhigh} {
3537             lset lines [expr {$i-1}] 1 $le
3538         } else {
3539             # coalesce two pieces
3540             $canv delete $ith
3541             set b [lindex $lines [expr {$i-1}] 0]
3542             set e [lindex $lines $i 1]
3543             set lines [lreplace $lines [expr {$i-1}] $i [list $b $e $itl]]
3544         }
3545         $canv coords $itl $coords
3546         if {$arrow ne $al} {
3547             $canv itemconf $itl -arrow $arrow
3548         }
3549     }
3551     set linesegs($id) $lines
3552     return $le
3555 proc drawparentlinks {id row} {
3556     global rowidlist canv colormap curview parentlist
3557     global idpos linespc
3559     set rowids [lindex $rowidlist $row]
3560     set col [lsearch -exact $rowids $id]
3561     if {$col < 0} return
3562     set olds [lindex $parentlist $row]
3563     set row2 [expr {$row + 1}]
3564     set x [xc $row $col]
3565     set y [yc $row]
3566     set y2 [yc $row2]
3567     set d [expr {int(0.5 * $linespc)}]
3568     set ymid [expr {$y + $d}]
3569     set ids [lindex $rowidlist $row2]
3570     # rmx = right-most X coord used
3571     set rmx 0
3572     foreach p $olds {
3573         set i [lsearch -exact $ids $p]
3574         if {$i < 0} {
3575             puts "oops, parent $p of $id not in list"
3576             continue
3577         }
3578         set x2 [xc $row2 $i]
3579         if {$x2 > $rmx} {
3580             set rmx $x2
3581         }
3582         set j [lsearch -exact $rowids $p]
3583         if {$j < 0} {
3584             # drawlineseg will do this one for us
3585             continue
3586         }
3587         assigncolor $p
3588         # should handle duplicated parents here...
3589         set coords [list $x $y]
3590         if {$i != $col} {
3591             # if attaching to a vertical segment, draw a smaller
3592             # slant for visual distinctness
3593             if {$i == $j} {
3594                 if {$i < $col} {
3595                     lappend coords [expr {$x2 + $d}] $y $x2 $ymid
3596                 } else {
3597                     lappend coords [expr {$x2 - $d}] $y $x2 $ymid
3598                 }
3599             } elseif {$i < $col && $i < $j} {
3600                 # segment slants towards us already
3601                 lappend coords [xc $row $j] $y
3602             } else {
3603                 if {$i < $col - 1} {
3604                     lappend coords [expr {$x2 + $linespc}] $y
3605                 } elseif {$i > $col + 1} {
3606                     lappend coords [expr {$x2 - $linespc}] $y
3607                 }
3608                 lappend coords $x2 $y2
3609             }
3610         } else {
3611             lappend coords $x2 $y2
3612         }
3613         set t [$canv create line $coords -width [linewidth $p] \
3614                    -fill $colormap($p) -tags lines.$p]
3615         $canv lower $t
3616         bindline $t $p
3617     }
3618     if {$rmx > [lindex $idpos($id) 1]} {
3619         lset idpos($id) 1 $rmx
3620         redrawtags $id
3621     }
3624 proc drawlines {id} {
3625     global canv
3627     $canv itemconf lines.$id -width [linewidth $id]
3630 proc drawcmittext {id row col} {
3631     global linespc canv canv2 canv3 canvy0 fgcolor curview
3632     global commitlisted commitinfo rowidlist parentlist
3633     global rowtextx idpos idtags idheads idotherrefs
3634     global linehtag linentag linedtag selectedline
3635     global canvxmax boldrows boldnamerows fgcolor nullid nullid2
3637     # listed is 0 for boundary, 1 for normal, 2 for left, 3 for right
3638     set listed [lindex $commitlisted $row]
3639     if {$id eq $nullid} {
3640         set ofill red
3641     } elseif {$id eq $nullid2} {
3642         set ofill green
3643     } else {
3644         set ofill [expr {$listed != 0? "blue": "white"}]
3645     }
3646     set x [xc $row $col]
3647     set y [yc $row]
3648     set orad [expr {$linespc / 3}]
3649     if {$listed <= 1} {
3650         set t [$canv create oval [expr {$x - $orad}] [expr {$y - $orad}] \
3651                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3652                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
3653     } elseif {$listed == 2} {
3654         # triangle pointing left for left-side commits
3655         set t [$canv create polygon \
3656                    [expr {$x - $orad}] $y \
3657                    [expr {$x + $orad - 1}] [expr {$y - $orad}] \
3658                    [expr {$x + $orad - 1}] [expr {$y + $orad - 1}] \
3659                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
3660     } else {
3661         # triangle pointing right for right-side commits
3662         set t [$canv create polygon \
3663                    [expr {$x + $orad - 1}] $y \
3664                    [expr {$x - $orad}] [expr {$y - $orad}] \
3665                    [expr {$x - $orad}] [expr {$y + $orad - 1}] \
3666                    -fill $ofill -outline $fgcolor -width 1 -tags circle]
3667     }
3668     $canv raise $t
3669     $canv bind $t <1> {selcanvline {} %x %y}
3670     set rmx [llength [lindex $rowidlist $row]]
3671     set olds [lindex $parentlist $row]
3672     if {$olds ne {}} {
3673         set nextids [lindex $rowidlist [expr {$row + 1}]]
3674         foreach p $olds {
3675             set i [lsearch -exact $nextids $p]
3676             if {$i > $rmx} {
3677                 set rmx $i
3678             }
3679         }
3680     }
3681     set xt [xc $row $rmx]
3682     set rowtextx($row) $xt
3683     set idpos($id) [list $x $xt $y]
3684     if {[info exists idtags($id)] || [info exists idheads($id)]
3685         || [info exists idotherrefs($id)]} {
3686         set xt [drawtags $id $x $xt $y]
3687     }
3688     set headline [lindex $commitinfo($id) 0]
3689     set name [lindex $commitinfo($id) 1]
3690     set date [lindex $commitinfo($id) 2]
3691     set date [formatdate $date]
3692     set font mainfont
3693     set nfont mainfont
3694     set isbold [ishighlighted $row]
3695     if {$isbold > 0} {
3696         lappend boldrows $row
3697         set font mainfontbold
3698         if {$isbold > 1} {
3699             lappend boldnamerows $row
3700             set nfont mainfontbold
3701         }
3702     }
3703     set linehtag($row) [$canv create text $xt $y -anchor w -fill $fgcolor \
3704                             -text $headline -font $font -tags text]
3705     $canv bind $linehtag($row) <Button-3> "rowmenu %X %Y $id"
3706     set linentag($row) [$canv2 create text 3 $y -anchor w -fill $fgcolor \
3707                             -text $name -font $nfont -tags text]
3708     set linedtag($row) [$canv3 create text 3 $y -anchor w -fill $fgcolor \
3709                             -text $date -font mainfont -tags text]
3710     if {[info exists selectedline] && $selectedline == $row} {
3711         make_secsel $row
3712     }
3713     set xr [expr {$xt + [font measure $font $headline]}]
3714     if {$xr > $canvxmax} {
3715         set canvxmax $xr
3716         setcanvscroll
3717     }
3720 proc drawcmitrow {row} {
3721     global displayorder rowidlist nrows_drawn
3722     global iddrawn markingmatches
3723     global commitinfo parentlist numcommits
3724     global filehighlight fhighlights findpattern nhighlights
3725     global hlview vhighlights
3726     global highlight_related rhighlights
3728     if {$row >= $numcommits} return
3730     set id [lindex $displayorder $row]
3731     if {[info exists hlview] && ![info exists vhighlights($row)]} {
3732         askvhighlight $row $id
3733     }
3734     if {[info exists filehighlight] && ![info exists fhighlights($row)]} {
3735         askfilehighlight $row $id
3736     }
3737     if {$findpattern ne {} && ![info exists nhighlights($row)]} {
3738         askfindhighlight $row $id
3739     }
3740     if {$highlight_related ne "None" && ![info exists rhighlights($row)]} {
3741         askrelhighlight $row $id
3742     }
3743     if {![info exists iddrawn($id)]} {
3744         set col [lsearch -exact [lindex $rowidlist $row] $id]
3745         if {$col < 0} {
3746             puts "oops, row $row id $id not in list"
3747             return
3748         }
3749         if {![info exists commitinfo($id)]} {
3750             getcommit $id
3751         }
3752         assigncolor $id
3753         drawcmittext $id $row $col
3754         set iddrawn($id) 1
3755         incr nrows_drawn
3756     }
3757     if {$markingmatches} {
3758         markrowmatches $row $id
3759     }
3762 proc drawcommits {row {endrow {}}} {
3763     global numcommits iddrawn displayorder curview need_redisplay
3764     global parentlist rowidlist rowfinal uparrowlen downarrowlen nrows_drawn
3766     if {$row < 0} {
3767         set row 0
3768     }
3769     if {$endrow eq {}} {
3770         set endrow $row
3771     }
3772     if {$endrow >= $numcommits} {
3773         set endrow [expr {$numcommits - 1}]
3774     }
3776     set rl1 [expr {$row - $downarrowlen - 3}]
3777     if {$rl1 < 0} {
3778         set rl1 0
3779     }
3780     set ro1 [expr {$row - 3}]
3781     if {$ro1 < 0} {
3782         set ro1 0
3783     }
3784     set r2 [expr {$endrow + $uparrowlen + 3}]
3785     if {$r2 > $numcommits} {
3786         set r2 $numcommits
3787     }
3788     for {set r $rl1} {$r < $r2} {incr r} {
3789         if {[lindex $rowidlist $r] ne {} && [lindex $rowfinal $r]} {
3790             if {$rl1 < $r} {
3791                 layoutrows $rl1 $r
3792             }
3793             set rl1 [expr {$r + 1}]
3794         }
3795     }
3796     if {$rl1 < $r} {
3797         layoutrows $rl1 $r
3798     }
3799     optimize_rows $ro1 0 $r2
3800     if {$need_redisplay || $nrows_drawn > 2000} {
3801         clear_display
3802         drawvisible
3803     }
3805     # make the lines join to already-drawn rows either side
3806     set r [expr {$row - 1}]
3807     if {$r < 0 || ![info exists iddrawn([lindex $displayorder $r])]} {
3808         set r $row
3809     }
3810     set er [expr {$endrow + 1}]
3811     if {$er >= $numcommits ||
3812         ![info exists iddrawn([lindex $displayorder $er])]} {
3813         set er $endrow
3814     }
3815     for {} {$r <= $er} {incr r} {
3816         set id [lindex $displayorder $r]
3817         set wasdrawn [info exists iddrawn($id)]
3818         drawcmitrow $r
3819         if {$r == $er} break
3820         set nextid [lindex $displayorder [expr {$r + 1}]]
3821         if {$wasdrawn && [info exists iddrawn($nextid)]} continue
3822         drawparentlinks $id $r
3824         set rowids [lindex $rowidlist $r]
3825         foreach lid $rowids {
3826             if {$lid eq {}} continue
3827             if {[info exists lineend($lid)] && $lineend($lid) > $r} continue
3828             if {$lid eq $id} {
3829                 # see if this is the first child of any of its parents
3830                 foreach p [lindex $parentlist $r] {
3831                     if {[lsearch -exact $rowids $p] < 0} {
3832                         # make this line extend up to the child
3833                         set lineend($p) [drawlineseg $p $r $er 0]
3834                     }
3835                 }
3836             } else {
3837                 set lineend($lid) [drawlineseg $lid $r $er 1]
3838             }
3839         }
3840     }
3843 proc drawfrac {f0 f1} {
3844     global canv linespc
3846     set ymax [lindex [$canv cget -scrollregion] 3]
3847     if {$ymax eq {} || $ymax == 0} return
3848     set y0 [expr {int($f0 * $ymax)}]
3849     set row [expr {int(($y0 - 3) / $linespc) - 1}]
3850     set y1 [expr {int($f1 * $ymax)}]
3851     set endrow [expr {int(($y1 - 3) / $linespc) + 1}]
3852     drawcommits $row $endrow
3855 proc drawvisible {} {
3856     global canv
3857     eval drawfrac [$canv yview]
3860 proc clear_display {} {
3861     global iddrawn linesegs need_redisplay nrows_drawn
3862     global vhighlights fhighlights nhighlights rhighlights
3864     allcanvs delete all
3865     catch {unset iddrawn}
3866     catch {unset linesegs}
3867     catch {unset vhighlights}
3868     catch {unset fhighlights}
3869     catch {unset nhighlights}
3870     catch {unset rhighlights}
3871     set need_redisplay 0
3872     set nrows_drawn 0
3875 proc findcrossings {id} {
3876     global rowidlist parentlist numcommits displayorder
3878     set cross {}
3879     set ccross {}
3880     foreach {s e} [rowranges $id] {
3881         if {$e >= $numcommits} {
3882             set e [expr {$numcommits - 1}]
3883         }
3884         if {$e <= $s} continue
3885         for {set row $e} {[incr row -1] >= $s} {} {
3886             set x [lsearch -exact [lindex $rowidlist $row] $id]
3887             if {$x < 0} break
3888             set olds [lindex $parentlist $row]
3889             set kid [lindex $displayorder $row]
3890             set kidx [lsearch -exact [lindex $rowidlist $row] $kid]
3891             if {$kidx < 0} continue
3892             set nextrow [lindex $rowidlist [expr {$row + 1}]]
3893             foreach p $olds {
3894                 set px [lsearch -exact $nextrow $p]
3895                 if {$px < 0} continue
3896                 if {($kidx < $x && $x < $px) || ($px < $x && $x < $kidx)} {
3897                     if {[lsearch -exact $ccross $p] >= 0} continue
3898                     if {$x == $px + ($kidx < $px? -1: 1)} {
3899                         lappend ccross $p
3900                     } elseif {[lsearch -exact $cross $p] < 0} {
3901                         lappend cross $p
3902                     }
3903                 }
3904             }
3905         }
3906     }
3907     return [concat $ccross {{}} $cross]
3910 proc assigncolor {id} {
3911     global colormap colors nextcolor
3912     global commitrow parentlist children children curview
3914     if {[info exists colormap($id)]} return
3915     set ncolors [llength $colors]
3916     if {[info exists children($curview,$id)]} {
3917         set kids $children($curview,$id)
3918     } else {
3919         set kids {}
3920     }
3921     if {[llength $kids] == 1} {
3922         set child [lindex $kids 0]
3923         if {[info exists colormap($child)]
3924             && [llength [lindex $parentlist $commitrow($curview,$child)]] == 1} {
3925             set colormap($id) $colormap($child)
3926             return
3927         }
3928     }
3929     set badcolors {}
3930     set origbad {}
3931     foreach x [findcrossings $id] {
3932         if {$x eq {}} {
3933             # delimiter between corner crossings and other crossings
3934             if {[llength $badcolors] >= $ncolors - 1} break
3935             set origbad $badcolors
3936         }
3937         if {[info exists colormap($x)]
3938             && [lsearch -exact $badcolors $colormap($x)] < 0} {
3939             lappend badcolors $colormap($x)
3940         }
3941     }
3942     if {[llength $badcolors] >= $ncolors} {
3943         set badcolors $origbad
3944     }
3945     set origbad $badcolors
3946     if {[llength $badcolors] < $ncolors - 1} {
3947         foreach child $kids {
3948             if {[info exists colormap($child)]
3949                 && [lsearch -exact $badcolors $colormap($child)] < 0} {
3950                 lappend badcolors $colormap($child)
3951             }
3952             foreach p [lindex $parentlist $commitrow($curview,$child)] {
3953                 if {[info exists colormap($p)]
3954                     && [lsearch -exact $badcolors $colormap($p)] < 0} {
3955                     lappend badcolors $colormap($p)
3956                 }
3957             }
3958         }
3959         if {[llength $badcolors] >= $ncolors} {
3960             set badcolors $origbad
3961         }
3962     }
3963     for {set i 0} {$i <= $ncolors} {incr i} {
3964         set c [lindex $colors $nextcolor]
3965         if {[incr nextcolor] >= $ncolors} {
3966             set nextcolor 0
3967         }
3968         if {[lsearch -exact $badcolors $c]} break
3969     }
3970     set colormap($id) $c
3973 proc bindline {t id} {
3974     global canv
3976     $canv bind $t <Enter> "lineenter %x %y $id"
3977     $canv bind $t <Motion> "linemotion %x %y $id"
3978     $canv bind $t <Leave> "lineleave $id"
3979     $canv bind $t <Button-1> "lineclick %x %y $id 1"
3982 proc drawtags {id x xt y1} {
3983     global idtags idheads idotherrefs mainhead
3984     global linespc lthickness
3985     global canv commitrow rowtextx curview fgcolor bgcolor
3987     set marks {}
3988     set ntags 0
3989     set nheads 0
3990     if {[info exists idtags($id)]} {
3991         set marks $idtags($id)
3992         set ntags [llength $marks]
3993     }
3994     if {[info exists idheads($id)]} {
3995         set marks [concat $marks $idheads($id)]
3996         set nheads [llength $idheads($id)]
3997     }
3998     if {[info exists idotherrefs($id)]} {
3999         set marks [concat $marks $idotherrefs($id)]
4000     }
4001     if {$marks eq {}} {
4002         return $xt
4003     }
4005     set delta [expr {int(0.5 * ($linespc - $lthickness))}]
4006     set yt [expr {$y1 - 0.5 * $linespc}]
4007     set yb [expr {$yt + $linespc - 1}]
4008     set xvals {}
4009     set wvals {}
4010     set i -1
4011     foreach tag $marks {
4012         incr i
4013         if {$i >= $ntags && $i < $ntags + $nheads && $tag eq $mainhead} {
4014             set wid [font measure mainfontbold $tag]
4015         } else {
4016             set wid [font measure mainfont $tag]
4017         }
4018         lappend xvals $xt
4019         lappend wvals $wid
4020         set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
4021     }
4022     set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
4023                -width $lthickness -fill black -tags tag.$id]
4024     $canv lower $t
4025     foreach tag $marks x $xvals wid $wvals {
4026         set xl [expr {$x + $delta}]
4027         set xr [expr {$x + $delta + $wid + $lthickness}]
4028         set font mainfont
4029         if {[incr ntags -1] >= 0} {
4030             # draw a tag
4031             set t [$canv create polygon $x [expr {$yt + $delta}] $xl $yt \
4032                        $xr $yt $xr $yb $xl $yb $x [expr {$yb - $delta}] \
4033                        -width 1 -outline black -fill yellow -tags tag.$id]
4034             $canv bind $t <1> [list showtag $tag 1]
4035             set rowtextx($commitrow($curview,$id)) [expr {$xr + $linespc}]
4036         } else {
4037             # draw a head or other ref
4038             if {[incr nheads -1] >= 0} {
4039                 set col green
4040                 if {$tag eq $mainhead} {
4041                     set font mainfontbold
4042                 }
4043             } else {
4044                 set col "#ddddff"
4045             }
4046             set xl [expr {$xl - $delta/2}]
4047             $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
4048                 -width 1 -outline black -fill $col -tags tag.$id
4049             if {[regexp {^(remotes/.*/|remotes/)} $tag match remoteprefix]} {
4050                 set rwid [font measure mainfont $remoteprefix]
4051                 set xi [expr {$x + 1}]
4052                 set yti [expr {$yt + 1}]
4053                 set xri [expr {$x + $rwid}]
4054                 $canv create polygon $xi $yti $xri $yti $xri $yb $xi $yb \
4055                         -width 0 -fill "#ffddaa" -tags tag.$id
4056             }
4057         }
4058         set t [$canv create text $xl $y1 -anchor w -text $tag -fill $fgcolor \
4059                    -font $font -tags [list tag.$id text]]
4060         if {$ntags >= 0} {
4061             $canv bind $t <1> [list showtag $tag 1]
4062         } elseif {$nheads >= 0} {
4063             $canv bind $t <Button-3> [list headmenu %X %Y $id $tag]
4064         }
4065     }
4066     return $xt
4069 proc xcoord {i level ln} {
4070     global canvx0 xspc1 xspc2
4072     set x [expr {$canvx0 + $i * $xspc1($ln)}]
4073     if {$i > 0 && $i == $level} {
4074         set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
4075     } elseif {$i > $level} {
4076         set x [expr {$x + $xspc2 - $xspc1($ln)}]
4077     }
4078     return $x
4081 proc show_status {msg} {
4082     global canv fgcolor
4084     clear_display
4085     $canv create text 3 3 -anchor nw -text $msg -font mainfont \
4086         -tags text -fill $fgcolor
4089 # Insert a new commit as the child of the commit on row $row.
4090 # The new commit will be displayed on row $row and the commits
4091 # on that row and below will move down one row.
4092 proc insertrow {row newcmit} {
4093     global displayorder parentlist commitlisted children
4094     global commitrow curview rowidlist rowisopt rowfinal numcommits
4095     global numcommits
4096     global selectedline commitidx ordertok
4098     if {$row >= $numcommits} {
4099         puts "oops, inserting new row $row but only have $numcommits rows"
4100         return
4101     }
4102     set p [lindex $displayorder $row]
4103     set displayorder [linsert $displayorder $row $newcmit]
4104     set parentlist [linsert $parentlist $row $p]
4105     set kids $children($curview,$p)
4106     lappend kids $newcmit
4107     set children($curview,$p) $kids
4108     set children($curview,$newcmit) {}
4109     set commitlisted [linsert $commitlisted $row 1]
4110     set l [llength $displayorder]
4111     for {set r $row} {$r < $l} {incr r} {
4112         set id [lindex $displayorder $r]
4113         set commitrow($curview,$id) $r
4114     }
4115     incr commitidx($curview)
4116     set ordertok($curview,$newcmit) $ordertok($curview,$p)
4118     if {$row < [llength $rowidlist]} {
4119         set idlist [lindex $rowidlist $row]
4120         if {$idlist ne {}} {
4121             if {[llength $kids] == 1} {
4122                 set col [lsearch -exact $idlist $p]
4123                 lset idlist $col $newcmit
4124             } else {
4125                 set col [llength $idlist]
4126                 lappend idlist $newcmit
4127             }
4128         }
4129         set rowidlist [linsert $rowidlist $row $idlist]
4130         set rowisopt [linsert $rowisopt $row 0]
4131         set rowfinal [linsert $rowfinal $row [lindex $rowfinal $row]]
4132     }
4134     incr numcommits
4136     if {[info exists selectedline] && $selectedline >= $row} {
4137         incr selectedline
4138     }
4139     redisplay
4142 # Remove a commit that was inserted with insertrow on row $row.
4143 proc removerow {row} {
4144     global displayorder parentlist commitlisted children
4145     global commitrow curview rowidlist rowisopt rowfinal numcommits
4146     global numcommits
4147     global linesegends selectedline commitidx
4149     if {$row >= $numcommits} {
4150         puts "oops, removing row $row but only have $numcommits rows"
4151         return
4152     }
4153     set rp1 [expr {$row + 1}]
4154     set id [lindex $displayorder $row]
4155     set p [lindex $parentlist $row]
4156     set displayorder [lreplace $displayorder $row $row]
4157     set parentlist [lreplace $parentlist $row $row]
4158     set commitlisted [lreplace $commitlisted $row $row]
4159     set kids $children($curview,$p)
4160     set i [lsearch -exact $kids $id]
4161     if {$i >= 0} {
4162         set kids [lreplace $kids $i $i]
4163         set children($curview,$p) $kids
4164     }
4165     set l [llength $displayorder]
4166     for {set r $row} {$r < $l} {incr r} {
4167         set id [lindex $displayorder $r]
4168         set commitrow($curview,$id) $r
4169     }
4170     incr commitidx($curview) -1
4172     if {$row < [llength $rowidlist]} {
4173         set rowidlist [lreplace $rowidlist $row $row]
4174         set rowisopt [lreplace $rowisopt $row $row]
4175         set rowfinal [lreplace $rowfinal $row $row]
4176     }
4178     incr numcommits -1
4180     if {[info exists selectedline] && $selectedline > $row} {
4181         incr selectedline -1
4182     }
4183     redisplay
4186 # Don't change the text pane cursor if it is currently the hand cursor,
4187 # showing that we are over a sha1 ID link.
4188 proc settextcursor {c} {
4189     global ctext curtextcursor
4191     if {[$ctext cget -cursor] == $curtextcursor} {
4192         $ctext config -cursor $c
4193     }
4194     set curtextcursor $c
4197 proc nowbusy {what {name {}}} {
4198     global isbusy busyname statusw
4200     if {[array names isbusy] eq {}} {
4201         . config -cursor watch
4202         settextcursor watch
4203     }
4204     set isbusy($what) 1
4205     set busyname($what) $name
4206     if {$name ne {}} {
4207         $statusw conf -text $name
4208     }
4211 proc notbusy {what} {
4212     global isbusy maincursor textcursor busyname statusw
4214     catch {
4215         unset isbusy($what)
4216         if {$busyname($what) ne {} &&
4217             [$statusw cget -text] eq $busyname($what)} {
4218             $statusw conf -text {}
4219         }
4220     }
4221     if {[array names isbusy] eq {}} {
4222         . config -cursor $maincursor
4223         settextcursor $textcursor
4224     }
4227 proc findmatches {f} {
4228     global findtype findstring
4229     if {$findtype == "Regexp"} {
4230         set matches [regexp -indices -all -inline $findstring $f]
4231     } else {
4232         set fs $findstring
4233         if {$findtype == "IgnCase"} {
4234             set f [string tolower $f]
4235             set fs [string tolower $fs]
4236         }
4237         set matches {}
4238         set i 0
4239         set l [string length $fs]
4240         while {[set j [string first $fs $f $i]] >= 0} {
4241             lappend matches [list $j [expr {$j+$l-1}]]
4242             set i [expr {$j + $l}]
4243         }
4244     }
4245     return $matches
4248 proc dofind {{dirn 1} {wrap 1}} {
4249     global findstring findstartline findcurline selectedline numcommits
4250     global gdttype filehighlight fh_serial find_dirn findallowwrap
4252     if {[info exists find_dirn]} {
4253         if {$find_dirn == $dirn} return
4254         stopfinding
4255     }
4256     focus .
4257     if {$findstring eq {} || $numcommits == 0} return
4258     if {![info exists selectedline]} {
4259         set findstartline [lindex [visiblerows] [expr {$dirn < 0}]]
4260     } else {
4261         set findstartline $selectedline
4262     }
4263     set findcurline $findstartline
4264     nowbusy finding "Searching"
4265     if {$gdttype ne "containing:" && ![info exists filehighlight]} {
4266         after cancel do_file_hl $fh_serial
4267         do_file_hl $fh_serial
4268     }
4269     set find_dirn $dirn
4270     set findallowwrap $wrap
4271     run findmore
4274 proc stopfinding {} {
4275     global find_dirn findcurline fprogcoord
4277     if {[info exists find_dirn]} {
4278         unset find_dirn
4279         unset findcurline
4280         notbusy finding
4281         set fprogcoord 0
4282         adjustprogress
4283     }
4286 proc findmore {} {
4287     global commitdata commitinfo numcommits findpattern findloc
4288     global findstartline findcurline displayorder
4289     global find_dirn gdttype fhighlights fprogcoord
4290     global findallowwrap
4292     if {![info exists find_dirn]} {
4293         return 0
4294     }
4295     set fldtypes {Headline Author Date Committer CDate Comments}
4296     set l $findcurline
4297     set moretodo 0
4298     if {$find_dirn > 0} {
4299         incr l
4300         if {$l >= $numcommits} {
4301             set l 0
4302         }
4303         if {$l <= $findstartline} {
4304             set lim [expr {$findstartline + 1}]
4305         } else {
4306             set lim $numcommits
4307             set moretodo $findallowwrap
4308         }
4309     } else {
4310         if {$l == 0} {
4311             set l $numcommits
4312         }
4313         incr l -1
4314         if {$l >= $findstartline} {
4315             set lim [expr {$findstartline - 1}]
4316         } else {
4317             set lim -1
4318             set moretodo $findallowwrap
4319         }
4320     }
4321     set n [expr {($lim - $l) * $find_dirn}]
4322     if {$n > 500} {
4323         set n 500
4324         set moretodo 1
4325     }
4326     set found 0
4327     set domore 1
4328     if {$gdttype eq "containing:"} {
4329         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4330             set id [lindex $displayorder $l]
4331             # shouldn't happen unless git log doesn't give all the commits...
4332             if {![info exists commitdata($id)]} continue
4333             if {![doesmatch $commitdata($id)]} continue
4334             if {![info exists commitinfo($id)]} {
4335                 getcommit $id
4336             }
4337             set info $commitinfo($id)
4338             foreach f $info ty $fldtypes {
4339                 if {($findloc eq "All fields" || $findloc eq $ty) &&
4340                     [doesmatch $f]} {
4341                     set found 1
4342                     break
4343                 }
4344             }
4345             if {$found} break
4346         }
4347     } else {
4348         for {} {$n > 0} {incr n -1; incr l $find_dirn} {
4349             set id [lindex $displayorder $l]
4350             if {![info exists fhighlights($l)]} {
4351                 askfilehighlight $l $id
4352                 if {$domore} {
4353                     set domore 0
4354                     set findcurline [expr {$l - $find_dirn}]
4355                 }
4356             } elseif {$fhighlights($l)} {
4357                 set found $domore
4358                 break
4359             }
4360         }
4361     }
4362     if {$found || ($domore && !$moretodo)} {
4363         unset findcurline
4364         unset find_dirn
4365         notbusy finding
4366         set fprogcoord 0
4367         adjustprogress
4368         if {$found} {
4369             findselectline $l
4370         } else {
4371             bell
4372         }
4373         return 0
4374     }
4375     if {!$domore} {
4376         flushhighlights
4377     } else {
4378         set findcurline [expr {$l - $find_dirn}]
4379     }
4380     set n [expr {($findcurline - $findstartline) * $find_dirn - 1}]
4381     if {$n < 0} {
4382         incr n $numcommits
4383     }
4384     set fprogcoord [expr {$n * 1.0 / $numcommits}]
4385     adjustprogress
4386     return $domore
4389 proc findselectline {l} {
4390     global findloc commentend ctext findcurline markingmatches gdttype
4392     set markingmatches 1
4393     set findcurline $l
4394     selectline $l 1
4395     if {$findloc == "All fields" || $findloc == "Comments"} {
4396         # highlight the matches in the comments
4397         set f [$ctext get 1.0 $commentend]
4398         set matches [findmatches $f]
4399         foreach match $matches {
4400             set start [lindex $match 0]
4401             set end [expr {[lindex $match 1] + 1}]
4402             $ctext tag add found "1.0 + $start c" "1.0 + $end c"
4403         }
4404     }
4405     drawvisible
4408 # mark the bits of a headline or author that match a find string
4409 proc markmatches {canv l str tag matches font row} {
4410     global selectedline
4412     set bbox [$canv bbox $tag]
4413     set x0 [lindex $bbox 0]
4414     set y0 [lindex $bbox 1]
4415     set y1 [lindex $bbox 3]
4416     foreach match $matches {
4417         set start [lindex $match 0]
4418         set end [lindex $match 1]
4419         if {$start > $end} continue
4420         set xoff [font measure $font [string range $str 0 [expr {$start-1}]]]
4421         set xlen [font measure $font [string range $str 0 [expr {$end}]]]
4422         set t [$canv create rect [expr {$x0+$xoff}] $y0 \
4423                    [expr {$x0+$xlen+2}] $y1 \
4424                    -outline {} -tags [list match$l matches] -fill yellow]
4425         $canv lower $t
4426         if {[info exists selectedline] && $row == $selectedline} {
4427             $canv raise $t secsel
4428         }
4429     }
4432 proc unmarkmatches {} {
4433     global markingmatches
4435     allcanvs delete matches
4436     set markingmatches 0
4437     stopfinding
4440 proc selcanvline {w x y} {
4441     global canv canvy0 ctext linespc
4442     global rowtextx
4443     set ymax [lindex [$canv cget -scrollregion] 3]
4444     if {$ymax == {}} return
4445     set yfrac [lindex [$canv yview] 0]
4446     set y [expr {$y + $yfrac * $ymax}]
4447     set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
4448     if {$l < 0} {
4449         set l 0
4450     }
4451     if {$w eq $canv} {
4452         if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
4453     }
4454     unmarkmatches
4455     selectline $l 1
4458 proc commit_descriptor {p} {
4459     global commitinfo
4460     if {![info exists commitinfo($p)]} {
4461         getcommit $p
4462     }
4463     set l "..."
4464     if {[llength $commitinfo($p)] > 1} {
4465         set l [lindex $commitinfo($p) 0]
4466     }
4467     return "$p ($l)\n"
4470 # append some text to the ctext widget, and make any SHA1 ID
4471 # that we know about be a clickable link.
4472 proc appendwithlinks {text tags} {
4473     global ctext commitrow linknum curview pendinglinks
4475     set start [$ctext index "end - 1c"]
4476     $ctext insert end $text $tags
4477     set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
4478     foreach l $links {
4479         set s [lindex $l 0]
4480         set e [lindex $l 1]
4481         set linkid [string range $text $s $e]
4482         incr e
4483         $ctext tag delete link$linknum
4484         $ctext tag add link$linknum "$start + $s c" "$start + $e c"
4485         setlink $linkid link$linknum
4486         incr linknum
4487     }
4490 proc setlink {id lk} {
4491     global curview commitrow ctext pendinglinks commitinterest
4493     if {[info exists commitrow($curview,$id)]} {
4494         $ctext tag conf $lk -foreground blue -underline 1
4495         $ctext tag bind $lk <1> [list selectline $commitrow($curview,$id) 1]
4496         $ctext tag bind $lk <Enter> {linkcursor %W 1}
4497         $ctext tag bind $lk <Leave> {linkcursor %W -1}
4498     } else {
4499         lappend pendinglinks($id) $lk
4500         lappend commitinterest($id) {makelink %I}
4501     }
4504 proc makelink {id} {
4505     global pendinglinks
4507     if {![info exists pendinglinks($id)]} return
4508     foreach lk $pendinglinks($id) {
4509         setlink $id $lk
4510     }
4511     unset pendinglinks($id)
4514 proc linkcursor {w inc} {
4515     global linkentercount curtextcursor
4517     if {[incr linkentercount $inc] > 0} {
4518         $w configure -cursor hand2
4519     } else {
4520         $w configure -cursor $curtextcursor
4521         if {$linkentercount < 0} {
4522             set linkentercount 0
4523         }
4524     }
4527 proc viewnextline {dir} {
4528     global canv linespc
4530     $canv delete hover
4531     set ymax [lindex [$canv cget -scrollregion] 3]
4532     set wnow [$canv yview]
4533     set wtop [expr {[lindex $wnow 0] * $ymax}]
4534     set newtop [expr {$wtop + $dir * $linespc}]
4535     if {$newtop < 0} {
4536         set newtop 0
4537     } elseif {$newtop > $ymax} {
4538         set newtop $ymax
4539     }
4540     allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4543 # add a list of tag or branch names at position pos
4544 # returns the number of names inserted
4545 proc appendrefs {pos ids var} {
4546     global ctext commitrow linknum curview $var maxrefs
4548     if {[catch {$ctext index $pos}]} {
4549         return 0
4550     }
4551     $ctext conf -state normal
4552     $ctext delete $pos "$pos lineend"
4553     set tags {}
4554     foreach id $ids {
4555         foreach tag [set $var\($id\)] {
4556             lappend tags [list $tag $id]
4557         }
4558     }
4559     if {[llength $tags] > $maxrefs} {
4560         $ctext insert $pos "many ([llength $tags])"
4561     } else {
4562         set tags [lsort -index 0 -decreasing $tags]
4563         set sep {}
4564         foreach ti $tags {
4565             set id [lindex $ti 1]
4566             set lk link$linknum
4567             incr linknum
4568             $ctext tag delete $lk
4569             $ctext insert $pos $sep
4570             $ctext insert $pos [lindex $ti 0] $lk
4571             setlink $id $lk
4572             set sep ", "
4573         }
4574     }
4575     $ctext conf -state disabled
4576     return [llength $tags]
4579 # called when we have finished computing the nearby tags
4580 proc dispneartags {delay} {
4581     global selectedline currentid showneartags tagphase
4583     if {![info exists selectedline] || !$showneartags} return
4584     after cancel dispnexttag
4585     if {$delay} {
4586         after 200 dispnexttag
4587         set tagphase -1
4588     } else {
4589         after idle dispnexttag
4590         set tagphase 0
4591     }
4594 proc dispnexttag {} {
4595     global selectedline currentid showneartags tagphase ctext
4597     if {![info exists selectedline] || !$showneartags} return
4598     switch -- $tagphase {
4599         0 {
4600             set dtags [desctags $currentid]
4601             if {$dtags ne {}} {
4602                 appendrefs precedes $dtags idtags
4603             }
4604         }
4605         1 {
4606             set atags [anctags $currentid]
4607             if {$atags ne {}} {
4608                 appendrefs follows $atags idtags
4609             }
4610         }
4611         2 {
4612             set dheads [descheads $currentid]
4613             if {$dheads ne {}} {
4614                 if {[appendrefs branch $dheads idheads] > 1
4615                     && [$ctext get "branch -3c"] eq "h"} {
4616                     # turn "Branch" into "Branches"
4617                     $ctext conf -state normal
4618                     $ctext insert "branch -2c" "es"
4619                     $ctext conf -state disabled
4620                 }
4621             }
4622         }
4623     }
4624     if {[incr tagphase] <= 2} {
4625         after idle dispnexttag
4626     }
4629 proc make_secsel {l} {
4630     global linehtag linentag linedtag canv canv2 canv3
4632     if {![info exists linehtag($l)]} return
4633     $canv delete secsel
4634     set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
4635                -tags secsel -fill [$canv cget -selectbackground]]
4636     $canv lower $t
4637     $canv2 delete secsel
4638     set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
4639                -tags secsel -fill [$canv2 cget -selectbackground]]
4640     $canv2 lower $t
4641     $canv3 delete secsel
4642     set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
4643                -tags secsel -fill [$canv3 cget -selectbackground]]
4644     $canv3 lower $t
4647 proc selectline {l isnew} {
4648     global canv ctext commitinfo selectedline
4649     global displayorder
4650     global canvy0 linespc parentlist children curview
4651     global currentid sha1entry
4652     global commentend idtags linknum
4653     global mergemax numcommits pending_select
4654     global cmitmode showneartags allcommits
4656     catch {unset pending_select}
4657     $canv delete hover
4658     normalline
4659     unsel_reflist
4660     stopfinding
4661     if {$l < 0 || $l >= $numcommits} return
4662     set y [expr {$canvy0 + $l * $linespc}]
4663     set ymax [lindex [$canv cget -scrollregion] 3]
4664     set ytop [expr {$y - $linespc - 1}]
4665     set ybot [expr {$y + $linespc + 1}]
4666     set wnow [$canv yview]
4667     set wtop [expr {[lindex $wnow 0] * $ymax}]
4668     set wbot [expr {[lindex $wnow 1] * $ymax}]
4669     set wh [expr {$wbot - $wtop}]
4670     set newtop $wtop
4671     if {$ytop < $wtop} {
4672         if {$ybot < $wtop} {
4673             set newtop [expr {$y - $wh / 2.0}]
4674         } else {
4675             set newtop $ytop
4676             if {$newtop > $wtop - $linespc} {
4677                 set newtop [expr {$wtop - $linespc}]
4678             }
4679         }
4680     } elseif {$ybot > $wbot} {
4681         if {$ytop > $wbot} {
4682             set newtop [expr {$y - $wh / 2.0}]
4683         } else {
4684             set newtop [expr {$ybot - $wh}]
4685             if {$newtop < $wtop + $linespc} {
4686                 set newtop [expr {$wtop + $linespc}]
4687             }
4688         }
4689     }
4690     if {$newtop != $wtop} {
4691         if {$newtop < 0} {
4692             set newtop 0
4693         }
4694         allcanvs yview moveto [expr {$newtop * 1.0 / $ymax}]
4695         drawvisible
4696     }
4698     make_secsel $l
4700     if {$isnew} {
4701         addtohistory [list selectline $l 0]
4702     }
4704     set selectedline $l
4706     set id [lindex $displayorder $l]
4707     set currentid $id
4708     $sha1entry delete 0 end
4709     $sha1entry insert 0 $id
4710     $sha1entry selection from 0
4711     $sha1entry selection to end
4712     rhighlight_sel $id
4714     $ctext conf -state normal
4715     clear_ctext
4716     set linknum 0
4717     set info $commitinfo($id)
4718     set date [formatdate [lindex $info 2]]
4719     $ctext insert end "Author: [lindex $info 1]  $date\n"
4720     set date [formatdate [lindex $info 4]]
4721     $ctext insert end "Committer: [lindex $info 3]  $date\n"
4722     if {[info exists idtags($id)]} {
4723         $ctext insert end "Tags:"
4724         foreach tag $idtags($id) {
4725             $ctext insert end " $tag"
4726         }
4727         $ctext insert end "\n"
4728     }
4730     set headers {}
4731     set olds [lindex $parentlist $l]
4732     if {[llength $olds] > 1} {
4733         set np 0
4734         foreach p $olds {
4735             if {$np >= $mergemax} {
4736                 set tag mmax
4737             } else {
4738                 set tag m$np
4739             }
4740             $ctext insert end "Parent: " $tag
4741             appendwithlinks [commit_descriptor $p] {}
4742             incr np
4743         }
4744     } else {
4745         foreach p $olds {
4746             append headers "Parent: [commit_descriptor $p]"
4747         }
4748     }
4750     foreach c $children($curview,$id) {
4751         append headers "Child:  [commit_descriptor $c]"
4752     }
4754     # make anything that looks like a SHA1 ID be a clickable link
4755     appendwithlinks $headers {}
4756     if {$showneartags} {
4757         if {![info exists allcommits]} {
4758             getallcommits
4759         }
4760         $ctext insert end "Branch: "
4761         $ctext mark set branch "end -1c"
4762         $ctext mark gravity branch left
4763         $ctext insert end "\nFollows: "
4764         $ctext mark set follows "end -1c"
4765         $ctext mark gravity follows left
4766         $ctext insert end "\nPrecedes: "
4767         $ctext mark set precedes "end -1c"
4768         $ctext mark gravity precedes left
4769         $ctext insert end "\n"
4770         dispneartags 1
4771     }
4772     $ctext insert end "\n"
4773     set comment [lindex $info 5]
4774     if {[string first "\r" $comment] >= 0} {
4775         set comment [string map {"\r" "\n    "} $comment]
4776     }
4777     appendwithlinks $comment {comment}
4779     $ctext tag remove found 1.0 end
4780     $ctext conf -state disabled
4781     set commentend [$ctext index "end - 1c"]
4783     init_flist "Comments"
4784     if {$cmitmode eq "tree"} {
4785         gettree $id
4786     } elseif {[llength $olds] <= 1} {
4787         startdiff $id
4788     } else {
4789         mergediff $id $l
4790     }
4793 proc selfirstline {} {
4794     unmarkmatches
4795     selectline 0 1
4798 proc sellastline {} {
4799     global numcommits
4800     unmarkmatches
4801     set l [expr {$numcommits - 1}]
4802     selectline $l 1
4805 proc selnextline {dir} {
4806     global selectedline
4807     focus .
4808     if {![info exists selectedline]} return
4809     set l [expr {$selectedline + $dir}]
4810     unmarkmatches
4811     selectline $l 1
4814 proc selnextpage {dir} {
4815     global canv linespc selectedline numcommits
4817     set lpp [expr {([winfo height $canv] - 2) / $linespc}]
4818     if {$lpp < 1} {
4819         set lpp 1
4820     }
4821     allcanvs yview scroll [expr {$dir * $lpp}] units
4822     drawvisible
4823     if {![info exists selectedline]} return
4824     set l [expr {$selectedline + $dir * $lpp}]
4825     if {$l < 0} {
4826         set l 0
4827     } elseif {$l >= $numcommits} {
4828         set l [expr $numcommits - 1]
4829     }
4830     unmarkmatches
4831     selectline $l 1
4834 proc unselectline {} {
4835     global selectedline currentid
4837     catch {unset selectedline}
4838     catch {unset currentid}
4839     allcanvs delete secsel
4840     rhighlight_none
4843 proc reselectline {} {
4844     global selectedline
4846     if {[info exists selectedline]} {
4847         selectline $selectedline 0
4848     }
4851 proc addtohistory {cmd} {
4852     global history historyindex curview
4854     set elt [list $curview $cmd]
4855     if {$historyindex > 0
4856         && [lindex $history [expr {$historyindex - 1}]] == $elt} {
4857         return
4858     }
4860     if {$historyindex < [llength $history]} {
4861         set history [lreplace $history $historyindex end $elt]
4862     } else {
4863         lappend history $elt
4864     }
4865     incr historyindex
4866     if {$historyindex > 1} {
4867         .tf.bar.leftbut conf -state normal
4868     } else {
4869         .tf.bar.leftbut conf -state disabled
4870     }
4871     .tf.bar.rightbut conf -state disabled
4874 proc godo {elt} {
4875     global curview
4877     set view [lindex $elt 0]
4878     set cmd [lindex $elt 1]
4879     if {$curview != $view} {
4880         showview $view
4881     }
4882     eval $cmd
4885 proc goback {} {
4886     global history historyindex
4887     focus .
4889     if {$historyindex > 1} {
4890         incr historyindex -1
4891         godo [lindex $history [expr {$historyindex - 1}]]
4892         .tf.bar.rightbut conf -state normal
4893     }
4894     if {$historyindex <= 1} {
4895         .tf.bar.leftbut conf -state disabled
4896     }
4899 proc goforw {} {
4900     global history historyindex
4901     focus .
4903     if {$historyindex < [llength $history]} {
4904         set cmd [lindex $history $historyindex]
4905         incr historyindex
4906         godo $cmd
4907         .tf.bar.leftbut conf -state normal
4908     }
4909     if {$historyindex >= [llength $history]} {
4910         .tf.bar.rightbut conf -state disabled
4911     }
4914 proc gettree {id} {
4915     global treefilelist treeidlist diffids diffmergeid treepending
4916     global nullid nullid2
4918     set diffids $id
4919     catch {unset diffmergeid}
4920     if {![info exists treefilelist($id)]} {
4921         if {![info exists treepending]} {
4922             if {$id eq $nullid} {
4923                 set cmd [list | git ls-files]
4924             } elseif {$id eq $nullid2} {
4925                 set cmd [list | git ls-files --stage -t]
4926             } else {
4927                 set cmd [list | git ls-tree -r $id]
4928             }
4929             if {[catch {set gtf [open $cmd r]}]} {
4930                 return
4931             }
4932             set treepending $id
4933             set treefilelist($id) {}
4934             set treeidlist($id) {}
4935             fconfigure $gtf -blocking 0
4936             filerun $gtf [list gettreeline $gtf $id]
4937         }
4938     } else {
4939         setfilelist $id
4940     }
4943 proc gettreeline {gtf id} {
4944     global treefilelist treeidlist treepending cmitmode diffids nullid nullid2
4946     set nl 0
4947     while {[incr nl] <= 1000 && [gets $gtf line] >= 0} {
4948         if {$diffids eq $nullid} {
4949             set fname $line
4950         } else {
4951             if {$diffids ne $nullid2 && [lindex $line 1] ne "blob"} continue
4952             set i [string first "\t" $line]
4953             if {$i < 0} continue
4954             set sha1 [lindex $line 2]
4955             set fname [string range $line [expr {$i+1}] end]
4956             if {[string index $fname 0] eq "\""} {
4957                 set fname [lindex $fname 0]
4958             }
4959             lappend treeidlist($id) $sha1
4960         }
4961         lappend treefilelist($id) $fname
4962     }
4963     if {![eof $gtf]} {
4964         return [expr {$nl >= 1000? 2: 1}]
4965     }
4966     close $gtf
4967     unset treepending
4968     if {$cmitmode ne "tree"} {
4969         if {![info exists diffmergeid]} {
4970             gettreediffs $diffids
4971         }
4972     } elseif {$id ne $diffids} {
4973         gettree $diffids
4974     } else {
4975         setfilelist $id
4976     }
4977     return 0
4980 proc showfile {f} {
4981     global treefilelist treeidlist diffids nullid nullid2
4982     global ctext commentend
4984     set i [lsearch -exact $treefilelist($diffids) $f]
4985     if {$i < 0} {
4986         puts "oops, $f not in list for id $diffids"
4987         return
4988     }
4989     if {$diffids eq $nullid} {
4990         if {[catch {set bf [open $f r]} err]} {
4991             puts "oops, can't read $f: $err"
4992             return
4993         }
4994     } else {
4995         set blob [lindex $treeidlist($diffids) $i]
4996         if {[catch {set bf [open [concat | git cat-file blob $blob] r]} err]} {
4997             puts "oops, error reading blob $blob: $err"
4998             return
4999         }
5000     }
5001     fconfigure $bf -blocking 0
5002     filerun $bf [list getblobline $bf $diffids]
5003     $ctext config -state normal
5004     clear_ctext $commentend
5005     $ctext insert end "\n"
5006     $ctext insert end "$f\n" filesep
5007     $ctext config -state disabled
5008     $ctext yview $commentend
5009     settabs 0
5012 proc getblobline {bf id} {
5013     global diffids cmitmode ctext
5015     if {$id ne $diffids || $cmitmode ne "tree"} {
5016         catch {close $bf}
5017         return 0
5018     }
5019     $ctext config -state normal
5020     set nl 0
5021     while {[incr nl] <= 1000 && [gets $bf line] >= 0} {
5022         $ctext insert end "$line\n"
5023     }
5024     if {[eof $bf]} {
5025         # delete last newline
5026         $ctext delete "end - 2c" "end - 1c"
5027         close $bf
5028         return 0
5029     }
5030     $ctext config -state disabled
5031     return [expr {$nl >= 1000? 2: 1}]
5034 proc mergediff {id l} {
5035     global diffmergeid mdifffd
5036     global diffids
5037     global parentlist
5038     global limitdiffs viewfiles curview
5040     set diffmergeid $id
5041     set diffids $id
5042     # this doesn't seem to actually affect anything...
5043     set cmd [concat | git diff-tree --no-commit-id --cc $id]
5044     if {$limitdiffs && $viewfiles($curview) ne {}} {
5045         set cmd [concat $cmd -- $viewfiles($curview)]
5046     }
5047     if {[catch {set mdf [open $cmd r]} err]} {
5048         error_popup "Error getting merge diffs: $err"
5049         return
5050     }
5051     fconfigure $mdf -blocking 0
5052     set mdifffd($id) $mdf
5053     set np [llength [lindex $parentlist $l]]
5054     settabs $np
5055     filerun $mdf [list getmergediffline $mdf $id $np]
5058 proc getmergediffline {mdf id np} {
5059     global diffmergeid ctext cflist mergemax
5060     global difffilestart mdifffd
5062     $ctext conf -state normal
5063     set nr 0
5064     while {[incr nr] <= 1000 && [gets $mdf line] >= 0} {
5065         if {![info exists diffmergeid] || $id != $diffmergeid
5066             || $mdf != $mdifffd($id)} {
5067             close $mdf
5068             return 0
5069         }
5070         if {[regexp {^diff --cc (.*)} $line match fname]} {
5071             # start of a new file
5072             $ctext insert end "\n"
5073             set here [$ctext index "end - 1c"]
5074             lappend difffilestart $here
5075             add_flist [list $fname]
5076             set l [expr {(78 - [string length $fname]) / 2}]
5077             set pad [string range "----------------------------------------" 1 $l]
5078             $ctext insert end "$pad $fname $pad\n" filesep
5079         } elseif {[regexp {^@@} $line]} {
5080             $ctext insert end "$line\n" hunksep
5081         } elseif {[regexp {^[0-9a-f]{40}$} $line] || [regexp {^index} $line]} {
5082             # do nothing
5083         } else {
5084             # parse the prefix - one ' ', '-' or '+' for each parent
5085             set spaces {}
5086             set minuses {}
5087             set pluses {}
5088             set isbad 0
5089             for {set j 0} {$j < $np} {incr j} {
5090                 set c [string range $line $j $j]
5091                 if {$c == " "} {
5092                     lappend spaces $j
5093                 } elseif {$c == "-"} {
5094                     lappend minuses $j
5095                 } elseif {$c == "+"} {
5096                     lappend pluses $j
5097                 } else {
5098                     set isbad 1
5099                     break
5100                 }
5101             }
5102             set tags {}
5103             set num {}
5104             if {!$isbad && $minuses ne {} && $pluses eq {}} {
5105                 # line doesn't appear in result, parents in $minuses have the line
5106                 set num [lindex $minuses 0]
5107             } elseif {!$isbad && $pluses ne {} && $minuses eq {}} {
5108                 # line appears in result, parents in $pluses don't have the line
5109                 lappend tags mresult
5110                 set num [lindex $spaces 0]
5111             }
5112             if {$num ne {}} {
5113                 if {$num >= $mergemax} {
5114                     set num "max"
5115                 }
5116                 lappend tags m$num
5117             }
5118             $ctext insert end "$line\n" $tags
5119         }
5120     }
5121     $ctext conf -state disabled
5122     if {[eof $mdf]} {
5123         close $mdf
5124         return 0
5125     }
5126     return [expr {$nr >= 1000? 2: 1}]
5129 proc startdiff {ids} {
5130     global treediffs diffids treepending diffmergeid nullid nullid2
5132     settabs 1
5133     set diffids $ids
5134     catch {unset diffmergeid}
5135     if {![info exists treediffs($ids)] ||
5136         [lsearch -exact $ids $nullid] >= 0 ||
5137         [lsearch -exact $ids $nullid2] >= 0} {
5138         if {![info exists treepending]} {
5139             gettreediffs $ids
5140         }
5141     } else {
5142         addtocflist $ids
5143     }
5146 proc path_filter {filter name} {
5147     foreach p $filter {
5148         set l [string length $p]
5149         if {[string index $p end] eq "/"} {
5150             if {[string compare -length $l $p $name] == 0} {
5151                 return 1
5152             }
5153         } else {
5154             if {[string compare -length $l $p $name] == 0 &&
5155                 ([string length $name] == $l ||
5156                  [string index $name $l] eq "/")} {
5157                 return 1
5158             }
5159         }
5160     }
5161     return 0
5164 proc addtocflist {ids} {
5165     global treediffs
5167     add_flist $treediffs($ids)
5168     getblobdiffs $ids
5171 proc diffcmd {ids flags} {
5172     global nullid nullid2
5174     set i [lsearch -exact $ids $nullid]
5175     set j [lsearch -exact $ids $nullid2]
5176     if {$i >= 0} {
5177         if {[llength $ids] > 1 && $j < 0} {
5178             # comparing working directory with some specific revision
5179             set cmd [concat | git diff-index $flags]
5180             if {$i == 0} {
5181                 lappend cmd -R [lindex $ids 1]
5182             } else {
5183                 lappend cmd [lindex $ids 0]
5184             }
5185         } else {
5186             # comparing working directory with index
5187             set cmd [concat | git diff-files $flags]
5188             if {$j == 1} {
5189                 lappend cmd -R
5190             }
5191         }
5192     } elseif {$j >= 0} {
5193         set cmd [concat | git diff-index --cached $flags]
5194         if {[llength $ids] > 1} {
5195             # comparing index with specific revision
5196             if {$i == 0} {
5197                 lappend cmd -R [lindex $ids 1]
5198             } else {
5199                 lappend cmd [lindex $ids 0]
5200             }
5201         } else {
5202             # comparing index with HEAD
5203             lappend cmd HEAD
5204         }
5205     } else {
5206         set cmd [concat | git diff-tree -r $flags $ids]
5207     }
5208     return $cmd
5211 proc gettreediffs {ids} {
5212     global treediff treepending
5214     set treepending $ids
5215     set treediff {}
5216     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5217     fconfigure $gdtf -blocking 0
5218     filerun $gdtf [list gettreediffline $gdtf $ids]
5221 proc gettreediffline {gdtf ids} {
5222     global treediff treediffs treepending diffids diffmergeid
5223     global cmitmode viewfiles curview limitdiffs
5225     set nr 0
5226     while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5227         set i [string first "\t" $line]
5228         if {$i >= 0} {
5229             set file [string range $line [expr {$i+1}] end]
5230             if {[string index $file 0] eq "\""} {
5231                 set file [lindex $file 0]
5232             }
5233             lappend treediff $file
5234         }
5235     }
5236     if {![eof $gdtf]} {
5237         return [expr {$nr >= 1000? 2: 1}]
5238     }
5239     close $gdtf
5240     if {$limitdiffs && $viewfiles($curview) ne {}} {
5241         set flist {}
5242         foreach f $treediff {
5243             if {[path_filter $viewfiles($curview) $f]} {
5244                 lappend flist $f
5245             }
5246         }
5247         set treediffs($ids) $flist
5248     } else {
5249         set treediffs($ids) $treediff
5250     }
5251     unset treepending
5252     if {$cmitmode eq "tree"} {
5253         gettree $diffids
5254     } elseif {$ids != $diffids} {
5255         if {![info exists diffmergeid]} {
5256             gettreediffs $diffids
5257         }
5258     } else {
5259         addtocflist $ids
5260     }
5261     return 0
5264 # empty string or positive integer
5265 proc diffcontextvalidate {v} {
5266     return [regexp {^(|[1-9][0-9]*)$} $v]
5269 proc diffcontextchange {n1 n2 op} {
5270     global diffcontextstring diffcontext
5272     if {[string is integer -strict $diffcontextstring]} {
5273         if {$diffcontextstring > 0} {
5274             set diffcontext $diffcontextstring
5275             reselectline
5276         }
5277     }
5280 proc getblobdiffs {ids} {
5281     global blobdifffd diffids env
5282     global diffinhdr treediffs
5283     global diffcontext
5284     global limitdiffs viewfiles curview
5286     set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5287     if {$limitdiffs && $viewfiles($curview) ne {}} {
5288         set cmd [concat $cmd -- $viewfiles($curview)]
5289     }
5290     if {[catch {set bdf [open $cmd r]} err]} {
5291         puts "error getting diffs: $err"
5292         return
5293     }
5294     set diffinhdr 0
5295     fconfigure $bdf -blocking 0
5296     set blobdifffd($ids) $bdf
5297     filerun $bdf [list getblobdiffline $bdf $diffids]
5300 proc setinlist {var i val} {
5301     global $var
5303     while {[llength [set $var]] < $i} {
5304         lappend $var {}
5305     }
5306     if {[llength [set $var]] == $i} {
5307         lappend $var $val
5308     } else {
5309         lset $var $i $val
5310     }
5313 proc makediffhdr {fname ids} {
5314     global ctext curdiffstart treediffs
5316     set i [lsearch -exact $treediffs($ids) $fname]
5317     if {$i >= 0} {
5318         setinlist difffilestart $i $curdiffstart
5319     }
5320     set l [expr {(78 - [string length $fname]) / 2}]
5321     set pad [string range "----------------------------------------" 1 $l]
5322     $ctext insert $curdiffstart "$pad $fname $pad" filesep
5325 proc getblobdiffline {bdf ids} {
5326     global diffids blobdifffd ctext curdiffstart
5327     global diffnexthead diffnextnote difffilestart
5328     global diffinhdr treediffs
5330     set nr 0
5331     $ctext conf -state normal
5332     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5333         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5334             close $bdf
5335             return 0
5336         }
5337         if {![string compare -length 11 "diff --git " $line]} {
5338             # trim off "diff --git "
5339             set line [string range $line 11 end]
5340             set diffinhdr 1
5341             # start of a new file
5342             $ctext insert end "\n"
5343             set curdiffstart [$ctext index "end - 1c"]
5344             $ctext insert end "\n" filesep
5345             # If the name hasn't changed the length will be odd,
5346             # the middle char will be a space, and the two bits either
5347             # side will be a/name and b/name, or "a/name" and "b/name".
5348             # If the name has changed we'll get "rename from" and
5349             # "rename to" or "copy from" and "copy to" lines following this,
5350             # and we'll use them to get the filenames.
5351             # This complexity is necessary because spaces in the filename(s)
5352             # don't get escaped.
5353             set l [string length $line]
5354             set i [expr {$l / 2}]
5355             if {!(($l & 1) && [string index $line $i] eq " " &&
5356                   [string range $line 2 [expr {$i - 1}]] eq \
5357                       [string range $line [expr {$i + 3}] end])} {
5358                 continue
5359             }
5360             # unescape if quoted and chop off the a/ from the front
5361             if {[string index $line 0] eq "\""} {
5362                 set fname [string range [lindex $line 0] 2 end]
5363             } else {
5364                 set fname [string range $line 2 [expr {$i - 1}]]
5365             }
5366             makediffhdr $fname $ids
5368         } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5369                        $line match f1l f1c f2l f2c rest]} {
5370             $ctext insert end "$line\n" hunksep
5371             set diffinhdr 0
5373         } elseif {$diffinhdr} {
5374             if {![string compare -length 12 "rename from " $line]} {
5375                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5376                 if {[string index $fname 0] eq "\""} {
5377                     set fname [lindex $fname 0]
5378                 }
5379                 set i [lsearch -exact $treediffs($ids) $fname]
5380                 if {$i >= 0} {
5381                     setinlist difffilestart $i $curdiffstart
5382                 }
5383             } elseif {![string compare -length 10 $line "rename to "] ||
5384                       ![string compare -length 8 $line "copy to "]} {
5385                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5386                 if {[string index $fname 0] eq "\""} {
5387                     set fname [lindex $fname 0]
5388                 }
5389                 makediffhdr $fname $ids
5390             } elseif {[string compare -length 3 $line "---"] == 0} {
5391                 # do nothing
5392                 continue
5393             } elseif {[string compare -length 3 $line "+++"] == 0} {
5394                 set diffinhdr 0
5395                 continue
5396             }
5397             $ctext insert end "$line\n" filesep
5399         } else {
5400             set x [string range $line 0 0]
5401             if {$x == "-" || $x == "+"} {
5402                 set tag [expr {$x == "+"}]
5403                 $ctext insert end "$line\n" d$tag
5404             } elseif {$x == " "} {
5405                 $ctext insert end "$line\n"
5406             } else {
5407                 # "\ No newline at end of file",
5408                 # or something else we don't recognize
5409                 $ctext insert end "$line\n" hunksep
5410             }
5411         }
5412     }
5413     $ctext conf -state disabled
5414     if {[eof $bdf]} {
5415         close $bdf
5416         return 0
5417     }
5418     return [expr {$nr >= 1000? 2: 1}]
5421 proc changediffdisp {} {
5422     global ctext diffelide
5424     $ctext tag conf d0 -elide [lindex $diffelide 0]
5425     $ctext tag conf d1 -elide [lindex $diffelide 1]
5428 proc prevfile {} {
5429     global difffilestart ctext
5430     set prev [lindex $difffilestart 0]
5431     set here [$ctext index @0,0]
5432     foreach loc $difffilestart {
5433         if {[$ctext compare $loc >= $here]} {
5434             $ctext yview $prev
5435             return
5436         }
5437         set prev $loc
5438     }
5439     $ctext yview $prev
5442 proc nextfile {} {
5443     global difffilestart ctext
5444     set here [$ctext index @0,0]
5445     foreach loc $difffilestart {
5446         if {[$ctext compare $loc > $here]} {
5447             $ctext yview $loc
5448             return
5449         }
5450     }
5453 proc clear_ctext {{first 1.0}} {
5454     global ctext smarktop smarkbot
5455     global pendinglinks
5457     set l [lindex [split $first .] 0]
5458     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5459         set smarktop $l
5460     }
5461     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5462         set smarkbot $l
5463     }
5464     $ctext delete $first end
5465     if {$first eq "1.0"} {
5466         catch {unset pendinglinks}
5467     }
5470 proc settabs {{firstab {}}} {
5471     global firsttabstop tabstop ctext have_tk85
5473     if {$firstab ne {} && $have_tk85} {
5474         set firsttabstop $firstab
5475     }
5476     set w [font measure textfont "0"]
5477     if {$firsttabstop != 0} {
5478         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5479                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5480     } elseif {$have_tk85 || $tabstop != 8} {
5481         $ctext conf -tabs [expr {$tabstop * $w}]
5482     } else {
5483         $ctext conf -tabs {}
5484     }
5487 proc incrsearch {name ix op} {
5488     global ctext searchstring searchdirn
5490     $ctext tag remove found 1.0 end
5491     if {[catch {$ctext index anchor}]} {
5492         # no anchor set, use start of selection, or of visible area
5493         set sel [$ctext tag ranges sel]
5494         if {$sel ne {}} {
5495             $ctext mark set anchor [lindex $sel 0]
5496         } elseif {$searchdirn eq "-forwards"} {
5497             $ctext mark set anchor @0,0
5498         } else {
5499             $ctext mark set anchor @0,[winfo height $ctext]
5500         }
5501     }
5502     if {$searchstring ne {}} {
5503         set here [$ctext search $searchdirn -- $searchstring anchor]
5504         if {$here ne {}} {
5505             $ctext see $here
5506         }
5507         searchmarkvisible 1
5508     }
5511 proc dosearch {} {
5512     global sstring ctext searchstring searchdirn
5514     focus $sstring
5515     $sstring icursor end
5516     set searchdirn -forwards
5517     if {$searchstring ne {}} {
5518         set sel [$ctext tag ranges sel]
5519         if {$sel ne {}} {
5520             set start "[lindex $sel 0] + 1c"
5521         } elseif {[catch {set start [$ctext index anchor]}]} {
5522             set start "@0,0"
5523         }
5524         set match [$ctext search -count mlen -- $searchstring $start]
5525         $ctext tag remove sel 1.0 end
5526         if {$match eq {}} {
5527             bell
5528             return
5529         }
5530         $ctext see $match
5531         set mend "$match + $mlen c"
5532         $ctext tag add sel $match $mend
5533         $ctext mark unset anchor
5534     }
5537 proc dosearchback {} {
5538     global sstring ctext searchstring searchdirn
5540     focus $sstring
5541     $sstring icursor end
5542     set searchdirn -backwards
5543     if {$searchstring ne {}} {
5544         set sel [$ctext tag ranges sel]
5545         if {$sel ne {}} {
5546             set start [lindex $sel 0]
5547         } elseif {[catch {set start [$ctext index anchor]}]} {
5548             set start @0,[winfo height $ctext]
5549         }
5550         set match [$ctext search -backwards -count ml -- $searchstring $start]
5551         $ctext tag remove sel 1.0 end
5552         if {$match eq {}} {
5553             bell
5554             return
5555         }
5556         $ctext see $match
5557         set mend "$match + $ml c"
5558         $ctext tag add sel $match $mend
5559         $ctext mark unset anchor
5560     }
5563 proc searchmark {first last} {
5564     global ctext searchstring
5566     set mend $first.0
5567     while {1} {
5568         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5569         if {$match eq {}} break
5570         set mend "$match + $mlen c"
5571         $ctext tag add found $match $mend
5572     }
5575 proc searchmarkvisible {doall} {
5576     global ctext smarktop smarkbot
5578     set topline [lindex [split [$ctext index @0,0] .] 0]
5579     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5580     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5581         # no overlap with previous
5582         searchmark $topline $botline
5583         set smarktop $topline
5584         set smarkbot $botline
5585     } else {
5586         if {$topline < $smarktop} {
5587             searchmark $topline [expr {$smarktop-1}]
5588             set smarktop $topline
5589         }
5590         if {$botline > $smarkbot} {
5591             searchmark [expr {$smarkbot+1}] $botline
5592             set smarkbot $botline
5593         }
5594     }
5597 proc scrolltext {f0 f1} {
5598     global searchstring
5600     .bleft.sb set $f0 $f1
5601     if {$searchstring ne {}} {
5602         searchmarkvisible 0
5603     }
5606 proc setcoords {} {
5607     global linespc charspc canvx0 canvy0
5608     global xspc1 xspc2 lthickness
5610     set linespc [font metrics mainfont -linespace]
5611     set charspc [font measure mainfont "m"]
5612     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5613     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5614     set lthickness [expr {int($linespc / 9) + 1}]
5615     set xspc1(0) $linespc
5616     set xspc2 $linespc
5619 proc redisplay {} {
5620     global canv
5621     global selectedline
5623     set ymax [lindex [$canv cget -scrollregion] 3]
5624     if {$ymax eq {} || $ymax == 0} return
5625     set span [$canv yview]
5626     clear_display
5627     setcanvscroll
5628     allcanvs yview moveto [lindex $span 0]
5629     drawvisible
5630     if {[info exists selectedline]} {
5631         selectline $selectedline 0
5632         allcanvs yview moveto [lindex $span 0]
5633     }
5636 proc parsefont {f n} {
5637     global fontattr
5639     set fontattr($f,family) [lindex $n 0]
5640     set s [lindex $n 1]
5641     if {$s eq {} || $s == 0} {
5642         set s 10
5643     } elseif {$s < 0} {
5644         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5645     }
5646     set fontattr($f,size) $s
5647     set fontattr($f,weight) normal
5648     set fontattr($f,slant) roman
5649     foreach style [lrange $n 2 end] {
5650         switch -- $style {
5651             "normal" -
5652             "bold"   {set fontattr($f,weight) $style}
5653             "roman" -
5654             "italic" {set fontattr($f,slant) $style}
5655         }
5656     }
5659 proc fontflags {f {isbold 0}} {
5660     global fontattr
5662     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5663                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5664                 -slant $fontattr($f,slant)]
5667 proc fontname {f} {
5668     global fontattr
5670     set n [list $fontattr($f,family) $fontattr($f,size)]
5671     if {$fontattr($f,weight) eq "bold"} {
5672         lappend n "bold"
5673     }
5674     if {$fontattr($f,slant) eq "italic"} {
5675         lappend n "italic"
5676     }
5677     return $n
5680 proc incrfont {inc} {
5681     global mainfont textfont ctext canv phase cflist showrefstop
5682     global stopped entries fontattr
5684     unmarkmatches
5685     set s $fontattr(mainfont,size)
5686     incr s $inc
5687     if {$s < 1} {
5688         set s 1
5689     }
5690     set fontattr(mainfont,size) $s
5691     font config mainfont -size $s
5692     font config mainfontbold -size $s
5693     set mainfont [fontname mainfont]
5694     set s $fontattr(textfont,size)
5695     incr s $inc
5696     if {$s < 1} {
5697         set s 1
5698     }
5699     set fontattr(textfont,size) $s
5700     font config textfont -size $s
5701     font config textfontbold -size $s
5702     set textfont [fontname textfont]
5703     setcoords
5704     settabs
5705     redisplay
5708 proc clearsha1 {} {
5709     global sha1entry sha1string
5710     if {[string length $sha1string] == 40} {
5711         $sha1entry delete 0 end
5712     }
5715 proc sha1change {n1 n2 op} {
5716     global sha1string currentid sha1but
5717     if {$sha1string == {}
5718         || ([info exists currentid] && $sha1string == $currentid)} {
5719         set state disabled
5720     } else {
5721         set state normal
5722     }
5723     if {[$sha1but cget -state] == $state} return
5724     if {$state == "normal"} {
5725         $sha1but conf -state normal -relief raised -text "Goto: "
5726     } else {
5727         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5728     }
5731 proc gotocommit {} {
5732     global sha1string currentid commitrow tagids headids
5733     global displayorder numcommits curview
5735     if {$sha1string == {}
5736         || ([info exists currentid] && $sha1string == $currentid)} return
5737     if {[info exists tagids($sha1string)]} {
5738         set id $tagids($sha1string)
5739     } elseif {[info exists headids($sha1string)]} {
5740         set id $headids($sha1string)
5741     } else {
5742         set id [string tolower $sha1string]
5743         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5744             set matches {}
5745             foreach i $displayorder {
5746                 if {[string match $id* $i]} {
5747                     lappend matches $i
5748                 }
5749             }
5750             if {$matches ne {}} {
5751                 if {[llength $matches] > 1} {
5752                     error_popup "Short SHA1 id $id is ambiguous"
5753                     return
5754                 }
5755                 set id [lindex $matches 0]
5756             }
5757         }
5758     }
5759     if {[info exists commitrow($curview,$id)]} {
5760         selectline $commitrow($curview,$id) 1
5761         return
5762     }
5763     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5764         set type "SHA1 id"
5765     } else {
5766         set type "Tag/Head"
5767     }
5768     error_popup "$type $sha1string is not known"
5771 proc lineenter {x y id} {
5772     global hoverx hovery hoverid hovertimer
5773     global commitinfo canv
5775     if {![info exists commitinfo($id)] && ![getcommit $id]} return
5776     set hoverx $x
5777     set hovery $y
5778     set hoverid $id
5779     if {[info exists hovertimer]} {
5780         after cancel $hovertimer
5781     }
5782     set hovertimer [after 500 linehover]
5783     $canv delete hover
5786 proc linemotion {x y id} {
5787     global hoverx hovery hoverid hovertimer
5789     if {[info exists hoverid] && $id == $hoverid} {
5790         set hoverx $x
5791         set hovery $y
5792         if {[info exists hovertimer]} {
5793             after cancel $hovertimer
5794         }
5795         set hovertimer [after 500 linehover]
5796     }
5799 proc lineleave {id} {
5800     global hoverid hovertimer canv
5802     if {[info exists hoverid] && $id == $hoverid} {
5803         $canv delete hover
5804         if {[info exists hovertimer]} {
5805             after cancel $hovertimer
5806             unset hovertimer
5807         }
5808         unset hoverid
5809     }
5812 proc linehover {} {
5813     global hoverx hovery hoverid hovertimer
5814     global canv linespc lthickness
5815     global commitinfo
5817     set text [lindex $commitinfo($hoverid) 0]
5818     set ymax [lindex [$canv cget -scrollregion] 3]
5819     if {$ymax == {}} return
5820     set yfrac [lindex [$canv yview] 0]
5821     set x [expr {$hoverx + 2 * $linespc}]
5822     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5823     set x0 [expr {$x - 2 * $lthickness}]
5824     set y0 [expr {$y - 2 * $lthickness}]
5825     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5826     set y1 [expr {$y + $linespc + 2 * $lthickness}]
5827     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5828                -fill \#ffff80 -outline black -width 1 -tags hover]
5829     $canv raise $t
5830     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5831                -font mainfont]
5832     $canv raise $t
5835 proc clickisonarrow {id y} {
5836     global lthickness
5838     set ranges [rowranges $id]
5839     set thresh [expr {2 * $lthickness + 6}]
5840     set n [expr {[llength $ranges] - 1}]
5841     for {set i 1} {$i < $n} {incr i} {
5842         set row [lindex $ranges $i]
5843         if {abs([yc $row] - $y) < $thresh} {
5844             return $i
5845         }
5846     }
5847     return {}
5850 proc arrowjump {id n y} {
5851     global canv
5853     # 1 <-> 2, 3 <-> 4, etc...
5854     set n [expr {(($n - 1) ^ 1) + 1}]
5855     set row [lindex [rowranges $id] $n]
5856     set yt [yc $row]
5857     set ymax [lindex [$canv cget -scrollregion] 3]
5858     if {$ymax eq {} || $ymax <= 0} return
5859     set view [$canv yview]
5860     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5861     set yfrac [expr {$yt / $ymax - $yspan / 2}]
5862     if {$yfrac < 0} {
5863         set yfrac 0
5864     }
5865     allcanvs yview moveto $yfrac
5868 proc lineclick {x y id isnew} {
5869     global ctext commitinfo children canv thickerline curview commitrow
5871     if {![info exists commitinfo($id)] && ![getcommit $id]} return
5872     unmarkmatches
5873     unselectline
5874     normalline
5875     $canv delete hover
5876     # draw this line thicker than normal
5877     set thickerline $id
5878     drawlines $id
5879     if {$isnew} {
5880         set ymax [lindex [$canv cget -scrollregion] 3]
5881         if {$ymax eq {}} return
5882         set yfrac [lindex [$canv yview] 0]
5883         set y [expr {$y + $yfrac * $ymax}]
5884     }
5885     set dirn [clickisonarrow $id $y]
5886     if {$dirn ne {}} {
5887         arrowjump $id $dirn $y
5888         return
5889     }
5891     if {$isnew} {
5892         addtohistory [list lineclick $x $y $id 0]
5893     }
5894     # fill the details pane with info about this line
5895     $ctext conf -state normal
5896     clear_ctext
5897     settabs 0
5898     $ctext insert end "Parent:\t"
5899     $ctext insert end $id link0
5900     setlink $id link0
5901     set info $commitinfo($id)
5902     $ctext insert end "\n\t[lindex $info 0]\n"
5903     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5904     set date [formatdate [lindex $info 2]]
5905     $ctext insert end "\tDate:\t$date\n"
5906     set kids $children($curview,$id)
5907     if {$kids ne {}} {
5908         $ctext insert end "\nChildren:"
5909         set i 0
5910         foreach child $kids {
5911             incr i
5912             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5913             set info $commitinfo($child)
5914             $ctext insert end "\n\t"
5915             $ctext insert end $child link$i
5916             setlink $child link$i
5917             $ctext insert end "\n\t[lindex $info 0]"
5918             $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5919             set date [formatdate [lindex $info 2]]
5920             $ctext insert end "\n\tDate:\t$date\n"
5921         }
5922     }
5923     $ctext conf -state disabled
5924     init_flist {}
5927 proc normalline {} {
5928     global thickerline
5929     if {[info exists thickerline]} {
5930         set id $thickerline
5931         unset thickerline
5932         drawlines $id
5933     }
5936 proc selbyid {id} {
5937     global commitrow curview
5938     if {[info exists commitrow($curview,$id)]} {
5939         selectline $commitrow($curview,$id) 1
5940     }
5943 proc mstime {} {
5944     global startmstime
5945     if {![info exists startmstime]} {
5946         set startmstime [clock clicks -milliseconds]
5947     }
5948     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5951 proc rowmenu {x y id} {
5952     global rowctxmenu commitrow selectedline rowmenuid curview
5953     global nullid nullid2 fakerowmenu mainhead
5955     stopfinding
5956     set rowmenuid $id
5957     if {![info exists selectedline]
5958         || $commitrow($curview,$id) eq $selectedline} {
5959         set state disabled
5960     } else {
5961         set state normal
5962     }
5963     if {$id ne $nullid && $id ne $nullid2} {
5964         set menu $rowctxmenu
5965         $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5966     } else {
5967         set menu $fakerowmenu
5968     }
5969     $menu entryconfigure "Diff this*" -state $state
5970     $menu entryconfigure "Diff selected*" -state $state
5971     $menu entryconfigure "Make patch" -state $state
5972     tk_popup $menu $x $y
5975 proc diffvssel {dirn} {
5976     global rowmenuid selectedline displayorder
5978     if {![info exists selectedline]} return
5979     if {$dirn} {
5980         set oldid [lindex $displayorder $selectedline]
5981         set newid $rowmenuid
5982     } else {
5983         set oldid $rowmenuid
5984         set newid [lindex $displayorder $selectedline]
5985     }
5986     addtohistory [list doseldiff $oldid $newid]
5987     doseldiff $oldid $newid
5990 proc doseldiff {oldid newid} {
5991     global ctext
5992     global commitinfo
5994     $ctext conf -state normal
5995     clear_ctext
5996     init_flist "Top"
5997     $ctext insert end "From "
5998     $ctext insert end $oldid link0
5999     setlink $oldid link0
6000     $ctext insert end "\n     "
6001     $ctext insert end [lindex $commitinfo($oldid) 0]
6002     $ctext insert end "\n\nTo   "
6003     $ctext insert end $newid link1
6004     setlink $newid link1
6005     $ctext insert end "\n     "
6006     $ctext insert end [lindex $commitinfo($newid) 0]
6007     $ctext insert end "\n"
6008     $ctext conf -state disabled
6009     $ctext tag remove found 1.0 end
6010     startdiff [list $oldid $newid]
6013 proc mkpatch {} {
6014     global rowmenuid currentid commitinfo patchtop patchnum
6016     if {![info exists currentid]} return
6017     set oldid $currentid
6018     set oldhead [lindex $commitinfo($oldid) 0]
6019     set newid $rowmenuid
6020     set newhead [lindex $commitinfo($newid) 0]
6021     set top .patch
6022     set patchtop $top
6023     catch {destroy $top}
6024     toplevel $top
6025     label $top.title -text "Generate patch"
6026     grid $top.title - -pady 10
6027     label $top.from -text "From:"
6028     entry $top.fromsha1 -width 40 -relief flat
6029     $top.fromsha1 insert 0 $oldid
6030     $top.fromsha1 conf -state readonly
6031     grid $top.from $top.fromsha1 -sticky w
6032     entry $top.fromhead -width 60 -relief flat
6033     $top.fromhead insert 0 $oldhead
6034     $top.fromhead conf -state readonly
6035     grid x $top.fromhead -sticky w
6036     label $top.to -text "To:"
6037     entry $top.tosha1 -width 40 -relief flat
6038     $top.tosha1 insert 0 $newid
6039     $top.tosha1 conf -state readonly
6040     grid $top.to $top.tosha1 -sticky w
6041     entry $top.tohead -width 60 -relief flat
6042     $top.tohead insert 0 $newhead
6043     $top.tohead conf -state readonly
6044     grid x $top.tohead -sticky w
6045     button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6046     grid $top.rev x -pady 10
6047     label $top.flab -text "Output file:"
6048     entry $top.fname -width 60
6049     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6050     incr patchnum
6051     grid $top.flab $top.fname -sticky w
6052     frame $top.buts
6053     button $top.buts.gen -text "Generate" -command mkpatchgo
6054     button $top.buts.can -text "Cancel" -command mkpatchcan
6055     grid $top.buts.gen $top.buts.can
6056     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6057     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6058     grid $top.buts - -pady 10 -sticky ew
6059     focus $top.fname
6062 proc mkpatchrev {} {
6063     global patchtop
6065     set oldid [$patchtop.fromsha1 get]
6066     set oldhead [$patchtop.fromhead get]
6067     set newid [$patchtop.tosha1 get]
6068     set newhead [$patchtop.tohead get]
6069     foreach e [list fromsha1 fromhead tosha1 tohead] \
6070             v [list $newid $newhead $oldid $oldhead] {
6071         $patchtop.$e conf -state normal
6072         $patchtop.$e delete 0 end
6073         $patchtop.$e insert 0 $v
6074         $patchtop.$e conf -state readonly
6075     }
6078 proc mkpatchgo {} {
6079     global patchtop nullid nullid2
6081     set oldid [$patchtop.fromsha1 get]
6082     set newid [$patchtop.tosha1 get]
6083     set fname [$patchtop.fname get]
6084     set cmd [diffcmd [list $oldid $newid] -p]
6085     # trim off the initial "|"
6086     set cmd [lrange $cmd 1 end]
6087     lappend cmd >$fname &
6088     if {[catch {eval exec $cmd} err]} {
6089         error_popup "Error creating patch: $err"
6090     }
6091     catch {destroy $patchtop}
6092     unset patchtop
6095 proc mkpatchcan {} {
6096     global patchtop
6098     catch {destroy $patchtop}
6099     unset patchtop
6102 proc mktag {} {
6103     global rowmenuid mktagtop commitinfo
6105     set top .maketag
6106     set mktagtop $top
6107     catch {destroy $top}
6108     toplevel $top
6109     label $top.title -text "Create tag"
6110     grid $top.title - -pady 10
6111     label $top.id -text "ID:"
6112     entry $top.sha1 -width 40 -relief flat
6113     $top.sha1 insert 0 $rowmenuid
6114     $top.sha1 conf -state readonly
6115     grid $top.id $top.sha1 -sticky w
6116     entry $top.head -width 60 -relief flat
6117     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6118     $top.head conf -state readonly
6119     grid x $top.head -sticky w
6120     label $top.tlab -text "Tag name:"
6121     entry $top.tag -width 60
6122     grid $top.tlab $top.tag -sticky w
6123     frame $top.buts
6124     button $top.buts.gen -text "Create" -command mktaggo
6125     button $top.buts.can -text "Cancel" -command mktagcan
6126     grid $top.buts.gen $top.buts.can
6127     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6128     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6129     grid $top.buts - -pady 10 -sticky ew
6130     focus $top.tag
6133 proc domktag {} {
6134     global mktagtop env tagids idtags
6136     set id [$mktagtop.sha1 get]
6137     set tag [$mktagtop.tag get]
6138     if {$tag == {}} {
6139         error_popup "No tag name specified"
6140         return
6141     }
6142     if {[info exists tagids($tag)]} {
6143         error_popup "Tag \"$tag\" already exists"
6144         return
6145     }
6146     if {[catch {
6147         set dir [gitdir]
6148         set fname [file join $dir "refs/tags" $tag]
6149         set f [open $fname w]
6150         puts $f $id
6151         close $f
6152     } err]} {
6153         error_popup "Error creating tag: $err"
6154         return
6155     }
6157     set tagids($tag) $id
6158     lappend idtags($id) $tag
6159     redrawtags $id
6160     addedtag $id
6161     dispneartags 0
6162     run refill_reflist
6165 proc redrawtags {id} {
6166     global canv linehtag commitrow idpos selectedline curview
6167     global canvxmax iddrawn
6169     if {![info exists commitrow($curview,$id)]} return
6170     if {![info exists iddrawn($id)]} return
6171     drawcommits $commitrow($curview,$id)
6172     $canv delete tag.$id
6173     set xt [eval drawtags $id $idpos($id)]
6174     $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6175     set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6176     set xr [expr {$xt + [font measure mainfont $text]}]
6177     if {$xr > $canvxmax} {
6178         set canvxmax $xr
6179         setcanvscroll
6180     }
6181     if {[info exists selectedline]
6182         && $selectedline == $commitrow($curview,$id)} {
6183         selectline $selectedline 0
6184     }
6187 proc mktagcan {} {
6188     global mktagtop
6190     catch {destroy $mktagtop}
6191     unset mktagtop
6194 proc mktaggo {} {
6195     domktag
6196     mktagcan
6199 proc writecommit {} {
6200     global rowmenuid wrcomtop commitinfo wrcomcmd
6202     set top .writecommit
6203     set wrcomtop $top
6204     catch {destroy $top}
6205     toplevel $top
6206     label $top.title -text "Write commit to file"
6207     grid $top.title - -pady 10
6208     label $top.id -text "ID:"
6209     entry $top.sha1 -width 40 -relief flat
6210     $top.sha1 insert 0 $rowmenuid
6211     $top.sha1 conf -state readonly
6212     grid $top.id $top.sha1 -sticky w
6213     entry $top.head -width 60 -relief flat
6214     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6215     $top.head conf -state readonly
6216     grid x $top.head -sticky w
6217     label $top.clab -text "Command:"
6218     entry $top.cmd -width 60 -textvariable wrcomcmd
6219     grid $top.clab $top.cmd -sticky w -pady 10
6220     label $top.flab -text "Output file:"
6221     entry $top.fname -width 60
6222     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6223     grid $top.flab $top.fname -sticky w
6224     frame $top.buts
6225     button $top.buts.gen -text "Write" -command wrcomgo
6226     button $top.buts.can -text "Cancel" -command wrcomcan
6227     grid $top.buts.gen $top.buts.can
6228     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6229     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6230     grid $top.buts - -pady 10 -sticky ew
6231     focus $top.fname
6234 proc wrcomgo {} {
6235     global wrcomtop
6237     set id [$wrcomtop.sha1 get]
6238     set cmd "echo $id | [$wrcomtop.cmd get]"
6239     set fname [$wrcomtop.fname get]
6240     if {[catch {exec sh -c $cmd >$fname &} err]} {
6241         error_popup "Error writing commit: $err"
6242     }
6243     catch {destroy $wrcomtop}
6244     unset wrcomtop
6247 proc wrcomcan {} {
6248     global wrcomtop
6250     catch {destroy $wrcomtop}
6251     unset wrcomtop
6254 proc mkbranch {} {
6255     global rowmenuid mkbrtop
6257     set top .makebranch
6258     catch {destroy $top}
6259     toplevel $top
6260     label $top.title -text "Create new branch"
6261     grid $top.title - -pady 10
6262     label $top.id -text "ID:"
6263     entry $top.sha1 -width 40 -relief flat
6264     $top.sha1 insert 0 $rowmenuid
6265     $top.sha1 conf -state readonly
6266     grid $top.id $top.sha1 -sticky w
6267     label $top.nlab -text "Name:"
6268     entry $top.name -width 40
6269     grid $top.nlab $top.name -sticky w
6270     frame $top.buts
6271     button $top.buts.go -text "Create" -command [list mkbrgo $top]
6272     button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6273     grid $top.buts.go $top.buts.can
6274     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6275     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6276     grid $top.buts - -pady 10 -sticky ew
6277     focus $top.name
6280 proc mkbrgo {top} {
6281     global headids idheads
6283     set name [$top.name get]
6284     set id [$top.sha1 get]
6285     if {$name eq {}} {
6286         error_popup "Please specify a name for the new branch"
6287         return
6288     }
6289     catch {destroy $top}
6290     nowbusy newbranch
6291     update
6292     if {[catch {
6293         exec git branch $name $id
6294     } err]} {
6295         notbusy newbranch
6296         error_popup $err
6297     } else {
6298         set headids($name) $id
6299         lappend idheads($id) $name
6300         addedhead $id $name
6301         notbusy newbranch
6302         redrawtags $id
6303         dispneartags 0
6304         run refill_reflist
6305     }
6308 proc cherrypick {} {
6309     global rowmenuid curview commitrow
6310     global mainhead
6312     set oldhead [exec git rev-parse HEAD]
6313     set dheads [descheads $rowmenuid]
6314     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6315         set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6316                         included in branch $mainhead -- really re-apply it?"]
6317         if {!$ok} return
6318     }
6319     nowbusy cherrypick "Cherry-picking"
6320     update
6321     # Unfortunately git-cherry-pick writes stuff to stderr even when
6322     # no error occurs, and exec takes that as an indication of error...
6323     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6324         notbusy cherrypick
6325         error_popup $err
6326         return
6327     }
6328     set newhead [exec git rev-parse HEAD]
6329     if {$newhead eq $oldhead} {
6330         notbusy cherrypick
6331         error_popup "No changes committed"
6332         return
6333     }
6334     addnewchild $newhead $oldhead
6335     if {[info exists commitrow($curview,$oldhead)]} {
6336         insertrow $commitrow($curview,$oldhead) $newhead
6337         if {$mainhead ne {}} {
6338             movehead $newhead $mainhead
6339             movedhead $newhead $mainhead
6340         }
6341         redrawtags $oldhead
6342         redrawtags $newhead
6343     }
6344     notbusy cherrypick
6347 proc resethead {} {
6348     global mainheadid mainhead rowmenuid confirm_ok resettype
6350     set confirm_ok 0
6351     set w ".confirmreset"
6352     toplevel $w
6353     wm transient $w .
6354     wm title $w "Confirm reset"
6355     message $w.m -text \
6356         "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6357         -justify center -aspect 1000
6358     pack $w.m -side top -fill x -padx 20 -pady 20
6359     frame $w.f -relief sunken -border 2
6360     message $w.f.rt -text "Reset type:" -aspect 1000
6361     grid $w.f.rt -sticky w
6362     set resettype mixed
6363     radiobutton $w.f.soft -value soft -variable resettype -justify left \
6364         -text "Soft: Leave working tree and index untouched"
6365     grid $w.f.soft -sticky w
6366     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6367         -text "Mixed: Leave working tree untouched, reset index"
6368     grid $w.f.mixed -sticky w
6369     radiobutton $w.f.hard -value hard -variable resettype -justify left \
6370         -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6371     grid $w.f.hard -sticky w
6372     pack $w.f -side top -fill x
6373     button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6374     pack $w.ok -side left -fill x -padx 20 -pady 20
6375     button $w.cancel -text Cancel -command "destroy $w"
6376     pack $w.cancel -side right -fill x -padx 20 -pady 20
6377     bind $w <Visibility> "grab $w; focus $w"
6378     tkwait window $w
6379     if {!$confirm_ok} return
6380     if {[catch {set fd [open \
6381             [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6382         error_popup $err
6383     } else {
6384         dohidelocalchanges
6385         filerun $fd [list readresetstat $fd]
6386         nowbusy reset "Resetting"
6387     }
6390 proc readresetstat {fd} {
6391     global mainhead mainheadid showlocalchanges rprogcoord
6393     if {[gets $fd line] >= 0} {
6394         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6395             set rprogcoord [expr {1.0 * $m / $n}]
6396             adjustprogress
6397         }
6398         return 1
6399     }
6400     set rprogcoord 0
6401     adjustprogress
6402     notbusy reset
6403     if {[catch {close $fd} err]} {
6404         error_popup $err
6405     }
6406     set oldhead $mainheadid
6407     set newhead [exec git rev-parse HEAD]
6408     if {$newhead ne $oldhead} {
6409         movehead $newhead $mainhead
6410         movedhead $newhead $mainhead
6411         set mainheadid $newhead
6412         redrawtags $oldhead
6413         redrawtags $newhead
6414     }
6415     if {$showlocalchanges} {
6416         doshowlocalchanges
6417     }
6418     return 0
6421 # context menu for a head
6422 proc headmenu {x y id head} {
6423     global headmenuid headmenuhead headctxmenu mainhead
6425     stopfinding
6426     set headmenuid $id
6427     set headmenuhead $head
6428     set state normal
6429     if {$head eq $mainhead} {
6430         set state disabled
6431     }
6432     $headctxmenu entryconfigure 0 -state $state
6433     $headctxmenu entryconfigure 1 -state $state
6434     tk_popup $headctxmenu $x $y
6437 proc cobranch {} {
6438     global headmenuid headmenuhead mainhead headids
6439     global showlocalchanges mainheadid
6441     # check the tree is clean first??
6442     set oldmainhead $mainhead
6443     nowbusy checkout "Checking out"
6444     update
6445     dohidelocalchanges
6446     if {[catch {
6447         exec git checkout -q $headmenuhead
6448     } err]} {
6449         notbusy checkout
6450         error_popup $err
6451     } else {
6452         notbusy checkout
6453         set mainhead $headmenuhead
6454         set mainheadid $headmenuid
6455         if {[info exists headids($oldmainhead)]} {
6456             redrawtags $headids($oldmainhead)
6457         }
6458         redrawtags $headmenuid
6459     }
6460     if {$showlocalchanges} {
6461         dodiffindex
6462     }
6465 proc rmbranch {} {
6466     global headmenuid headmenuhead mainhead
6467     global idheads
6469     set head $headmenuhead
6470     set id $headmenuid
6471     # this check shouldn't be needed any more...
6472     if {$head eq $mainhead} {
6473         error_popup "Cannot delete the currently checked-out branch"
6474         return
6475     }
6476     set dheads [descheads $id]
6477     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6478         # the stuff on this branch isn't on any other branch
6479         if {![confirm_popup "The commits on branch $head aren't on any other\
6480                         branch.\nReally delete branch $head?"]} return
6481     }
6482     nowbusy rmbranch
6483     update
6484     if {[catch {exec git branch -D $head} err]} {
6485         notbusy rmbranch
6486         error_popup $err
6487         return
6488     }
6489     removehead $id $head
6490     removedhead $id $head
6491     redrawtags $id
6492     notbusy rmbranch
6493     dispneartags 0
6494     run refill_reflist
6497 # Display a list of tags and heads
6498 proc showrefs {} {
6499     global showrefstop bgcolor fgcolor selectbgcolor
6500     global bglist fglist reflistfilter reflist maincursor
6502     set top .showrefs
6503     set showrefstop $top
6504     if {[winfo exists $top]} {
6505         raise $top
6506         refill_reflist
6507         return
6508     }
6509     toplevel $top
6510     wm title $top "Tags and heads: [file tail [pwd]]"
6511     text $top.list -background $bgcolor -foreground $fgcolor \
6512         -selectbackground $selectbgcolor -font mainfont \
6513         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6514         -width 30 -height 20 -cursor $maincursor \
6515         -spacing1 1 -spacing3 1 -state disabled
6516     $top.list tag configure highlight -background $selectbgcolor
6517     lappend bglist $top.list
6518     lappend fglist $top.list
6519     scrollbar $top.ysb -command "$top.list yview" -orient vertical
6520     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6521     grid $top.list $top.ysb -sticky nsew
6522     grid $top.xsb x -sticky ew
6523     frame $top.f
6524     label $top.f.l -text "Filter: " -font uifont
6525     entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6526     set reflistfilter "*"
6527     trace add variable reflistfilter write reflistfilter_change
6528     pack $top.f.e -side right -fill x -expand 1
6529     pack $top.f.l -side left
6530     grid $top.f - -sticky ew -pady 2
6531     button $top.close -command [list destroy $top] -text "Close" \
6532         -font uifont
6533     grid $top.close -
6534     grid columnconfigure $top 0 -weight 1
6535     grid rowconfigure $top 0 -weight 1
6536     bind $top.list <1> {break}
6537     bind $top.list <B1-Motion> {break}
6538     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6539     set reflist {}
6540     refill_reflist
6543 proc sel_reflist {w x y} {
6544     global showrefstop reflist headids tagids otherrefids
6546     if {![winfo exists $showrefstop]} return
6547     set l [lindex [split [$w index "@$x,$y"] "."] 0]
6548     set ref [lindex $reflist [expr {$l-1}]]
6549     set n [lindex $ref 0]
6550     switch -- [lindex $ref 1] {
6551         "H" {selbyid $headids($n)}
6552         "T" {selbyid $tagids($n)}
6553         "o" {selbyid $otherrefids($n)}
6554     }
6555     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6558 proc unsel_reflist {} {
6559     global showrefstop
6561     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6562     $showrefstop.list tag remove highlight 0.0 end
6565 proc reflistfilter_change {n1 n2 op} {
6566     global reflistfilter
6568     after cancel refill_reflist
6569     after 200 refill_reflist
6572 proc refill_reflist {} {
6573     global reflist reflistfilter showrefstop headids tagids otherrefids
6574     global commitrow curview commitinterest
6576     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6577     set refs {}
6578     foreach n [array names headids] {
6579         if {[string match $reflistfilter $n]} {
6580             if {[info exists commitrow($curview,$headids($n))]} {
6581                 lappend refs [list $n H]
6582             } else {
6583                 set commitinterest($headids($n)) {run refill_reflist}
6584             }
6585         }
6586     }
6587     foreach n [array names tagids] {
6588         if {[string match $reflistfilter $n]} {
6589             if {[info exists commitrow($curview,$tagids($n))]} {
6590                 lappend refs [list $n T]
6591             } else {
6592                 set commitinterest($tagids($n)) {run refill_reflist}
6593             }
6594         }
6595     }
6596     foreach n [array names otherrefids] {
6597         if {[string match $reflistfilter $n]} {
6598             if {[info exists commitrow($curview,$otherrefids($n))]} {
6599                 lappend refs [list $n o]
6600             } else {
6601                 set commitinterest($otherrefids($n)) {run refill_reflist}
6602             }
6603         }
6604     }
6605     set refs [lsort -index 0 $refs]
6606     if {$refs eq $reflist} return
6608     # Update the contents of $showrefstop.list according to the
6609     # differences between $reflist (old) and $refs (new)
6610     $showrefstop.list conf -state normal
6611     $showrefstop.list insert end "\n"
6612     set i 0
6613     set j 0
6614     while {$i < [llength $reflist] || $j < [llength $refs]} {
6615         if {$i < [llength $reflist]} {
6616             if {$j < [llength $refs]} {
6617                 set cmp [string compare [lindex $reflist $i 0] \
6618                              [lindex $refs $j 0]]
6619                 if {$cmp == 0} {
6620                     set cmp [string compare [lindex $reflist $i 1] \
6621                                  [lindex $refs $j 1]]
6622                 }
6623             } else {
6624                 set cmp -1
6625             }
6626         } else {
6627             set cmp 1
6628         }
6629         switch -- $cmp {
6630             -1 {
6631                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6632                 incr i
6633             }
6634             0 {
6635                 incr i
6636                 incr j
6637             }
6638             1 {
6639                 set l [expr {$j + 1}]
6640                 $showrefstop.list image create $l.0 -align baseline \
6641                     -image reficon-[lindex $refs $j 1] -padx 2
6642                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6643                 incr j
6644             }
6645         }
6646     }
6647     set reflist $refs
6648     # delete last newline
6649     $showrefstop.list delete end-2c end-1c
6650     $showrefstop.list conf -state disabled
6653 # Stuff for finding nearby tags
6654 proc getallcommits {} {
6655     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6656     global idheads idtags idotherrefs allparents tagobjid
6658     if {![info exists allcommits]} {
6659         set nextarc 0
6660         set allcommits 0
6661         set seeds {}
6662         set allcwait 0
6663         set cachedarcs 0
6664         set allccache [file join [gitdir] "gitk.cache"]
6665         if {![catch {
6666             set f [open $allccache r]
6667             set allcwait 1
6668             getcache $f
6669         }]} return
6670     }
6672     if {$allcwait} {
6673         return
6674     }
6675     set cmd [list | git rev-list --parents]
6676     set allcupdate [expr {$seeds ne {}}]
6677     if {!$allcupdate} {
6678         set ids "--all"
6679     } else {
6680         set refs [concat [array names idheads] [array names idtags] \
6681                       [array names idotherrefs]]
6682         set ids {}
6683         set tagobjs {}
6684         foreach name [array names tagobjid] {
6685             lappend tagobjs $tagobjid($name)
6686         }
6687         foreach id [lsort -unique $refs] {
6688             if {![info exists allparents($id)] &&
6689                 [lsearch -exact $tagobjs $id] < 0} {
6690                 lappend ids $id
6691             }
6692         }
6693         if {$ids ne {}} {
6694             foreach id $seeds {
6695                 lappend ids "^$id"
6696             }
6697         }
6698     }
6699     if {$ids ne {}} {
6700         set fd [open [concat $cmd $ids] r]
6701         fconfigure $fd -blocking 0
6702         incr allcommits
6703         nowbusy allcommits
6704         filerun $fd [list getallclines $fd]
6705     } else {
6706         dispneartags 0
6707     }
6710 # Since most commits have 1 parent and 1 child, we group strings of
6711 # such commits into "arcs" joining branch/merge points (BMPs), which
6712 # are commits that either don't have 1 parent or don't have 1 child.
6714 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6715 # arcout(id) - outgoing arcs for BMP
6716 # arcids(a) - list of IDs on arc including end but not start
6717 # arcstart(a) - BMP ID at start of arc
6718 # arcend(a) - BMP ID at end of arc
6719 # growing(a) - arc a is still growing
6720 # arctags(a) - IDs out of arcids (excluding end) that have tags
6721 # archeads(a) - IDs out of arcids (excluding end) that have heads
6722 # The start of an arc is at the descendent end, so "incoming" means
6723 # coming from descendents, and "outgoing" means going towards ancestors.
6725 proc getallclines {fd} {
6726     global allparents allchildren idtags idheads nextarc
6727     global arcnos arcids arctags arcout arcend arcstart archeads growing
6728     global seeds allcommits cachedarcs allcupdate
6729     
6730     set nid 0
6731     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6732         set id [lindex $line 0]
6733         if {[info exists allparents($id)]} {
6734             # seen it already
6735             continue
6736         }
6737         set cachedarcs 0
6738         set olds [lrange $line 1 end]
6739         set allparents($id) $olds
6740         if {![info exists allchildren($id)]} {
6741             set allchildren($id) {}
6742             set arcnos($id) {}
6743             lappend seeds $id
6744         } else {
6745             set a $arcnos($id)
6746             if {[llength $olds] == 1 && [llength $a] == 1} {
6747                 lappend arcids($a) $id
6748                 if {[info exists idtags($id)]} {
6749                     lappend arctags($a) $id
6750                 }
6751                 if {[info exists idheads($id)]} {
6752                     lappend archeads($a) $id
6753                 }
6754                 if {[info exists allparents($olds)]} {
6755                     # seen parent already
6756                     if {![info exists arcout($olds)]} {
6757                         splitarc $olds
6758                     }
6759                     lappend arcids($a) $olds
6760                     set arcend($a) $olds
6761                     unset growing($a)
6762                 }
6763                 lappend allchildren($olds) $id
6764                 lappend arcnos($olds) $a
6765                 continue
6766             }
6767         }
6768         foreach a $arcnos($id) {
6769             lappend arcids($a) $id
6770             set arcend($a) $id
6771             unset growing($a)
6772         }
6774         set ao {}
6775         foreach p $olds {
6776             lappend allchildren($p) $id
6777             set a [incr nextarc]
6778             set arcstart($a) $id
6779             set archeads($a) {}
6780             set arctags($a) {}
6781             set archeads($a) {}
6782             set arcids($a) {}
6783             lappend ao $a
6784             set growing($a) 1
6785             if {[info exists allparents($p)]} {
6786                 # seen it already, may need to make a new branch
6787                 if {![info exists arcout($p)]} {
6788                     splitarc $p
6789                 }
6790                 lappend arcids($a) $p
6791                 set arcend($a) $p
6792                 unset growing($a)
6793             }
6794             lappend arcnos($p) $a
6795         }
6796         set arcout($id) $ao
6797     }
6798     if {$nid > 0} {
6799         global cached_dheads cached_dtags cached_atags
6800         catch {unset cached_dheads}
6801         catch {unset cached_dtags}
6802         catch {unset cached_atags}
6803     }
6804     if {![eof $fd]} {
6805         return [expr {$nid >= 1000? 2: 1}]
6806     }
6807     set cacheok 1
6808     if {[catch {
6809         fconfigure $fd -blocking 1
6810         close $fd
6811     } err]} {
6812         # got an error reading the list of commits
6813         # if we were updating, try rereading the whole thing again
6814         if {$allcupdate} {
6815             incr allcommits -1
6816             dropcache $err
6817             return
6818         }
6819         error_popup "Error reading commit topology information;\
6820                 branch and preceding/following tag information\
6821                 will be incomplete.\n($err)"
6822         set cacheok 0
6823     }
6824     if {[incr allcommits -1] == 0} {
6825         notbusy allcommits
6826         if {$cacheok} {
6827             run savecache
6828         }
6829     }
6830     dispneartags 0
6831     return 0
6834 proc recalcarc {a} {
6835     global arctags archeads arcids idtags idheads
6837     set at {}
6838     set ah {}
6839     foreach id [lrange $arcids($a) 0 end-1] {
6840         if {[info exists idtags($id)]} {
6841             lappend at $id
6842         }
6843         if {[info exists idheads($id)]} {
6844             lappend ah $id
6845         }
6846     }
6847     set arctags($a) $at
6848     set archeads($a) $ah
6851 proc splitarc {p} {
6852     global arcnos arcids nextarc arctags archeads idtags idheads
6853     global arcstart arcend arcout allparents growing
6855     set a $arcnos($p)
6856     if {[llength $a] != 1} {
6857         puts "oops splitarc called but [llength $a] arcs already"
6858         return
6859     }
6860     set a [lindex $a 0]
6861     set i [lsearch -exact $arcids($a) $p]
6862     if {$i < 0} {
6863         puts "oops splitarc $p not in arc $a"
6864         return
6865     }
6866     set na [incr nextarc]
6867     if {[info exists arcend($a)]} {
6868         set arcend($na) $arcend($a)
6869     } else {
6870         set l [lindex $allparents([lindex $arcids($a) end]) 0]
6871         set j [lsearch -exact $arcnos($l) $a]
6872         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6873     }
6874     set tail [lrange $arcids($a) [expr {$i+1}] end]
6875     set arcids($a) [lrange $arcids($a) 0 $i]
6876     set arcend($a) $p
6877     set arcstart($na) $p
6878     set arcout($p) $na
6879     set arcids($na) $tail
6880     if {[info exists growing($a)]} {
6881         set growing($na) 1
6882         unset growing($a)
6883     }
6885     foreach id $tail {
6886         if {[llength $arcnos($id)] == 1} {
6887             set arcnos($id) $na
6888         } else {
6889             set j [lsearch -exact $arcnos($id) $a]
6890             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6891         }
6892     }
6894     # reconstruct tags and heads lists
6895     if {$arctags($a) ne {} || $archeads($a) ne {}} {
6896         recalcarc $a
6897         recalcarc $na
6898     } else {
6899         set arctags($na) {}
6900         set archeads($na) {}
6901     }
6904 # Update things for a new commit added that is a child of one
6905 # existing commit.  Used when cherry-picking.
6906 proc addnewchild {id p} {
6907     global allparents allchildren idtags nextarc
6908     global arcnos arcids arctags arcout arcend arcstart archeads growing
6909     global seeds allcommits
6911     if {![info exists allcommits] || ![info exists arcnos($p)]} return
6912     set allparents($id) [list $p]
6913     set allchildren($id) {}
6914     set arcnos($id) {}
6915     lappend seeds $id
6916     lappend allchildren($p) $id
6917     set a [incr nextarc]
6918     set arcstart($a) $id
6919     set archeads($a) {}
6920     set arctags($a) {}
6921     set arcids($a) [list $p]
6922     set arcend($a) $p
6923     if {![info exists arcout($p)]} {
6924         splitarc $p
6925     }
6926     lappend arcnos($p) $a
6927     set arcout($id) [list $a]
6930 # This implements a cache for the topology information.
6931 # The cache saves, for each arc, the start and end of the arc,
6932 # the ids on the arc, and the outgoing arcs from the end.
6933 proc readcache {f} {
6934     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6935     global idtags idheads allparents cachedarcs possible_seeds seeds growing
6936     global allcwait
6938     set a $nextarc
6939     set lim $cachedarcs
6940     if {$lim - $a > 500} {
6941         set lim [expr {$a + 500}]
6942     }
6943     if {[catch {
6944         if {$a == $lim} {
6945             # finish reading the cache and setting up arctags, etc.
6946             set line [gets $f]
6947             if {$line ne "1"} {error "bad final version"}
6948             close $f
6949             foreach id [array names idtags] {
6950                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6951                     [llength $allparents($id)] == 1} {
6952                     set a [lindex $arcnos($id) 0]
6953                     if {$arctags($a) eq {}} {
6954                         recalcarc $a
6955                     }
6956                 }
6957             }
6958             foreach id [array names idheads] {
6959                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6960                     [llength $allparents($id)] == 1} {
6961                     set a [lindex $arcnos($id) 0]
6962                     if {$archeads($a) eq {}} {
6963                         recalcarc $a
6964                     }
6965                 }
6966             }
6967             foreach id [lsort -unique $possible_seeds] {
6968                 if {$arcnos($id) eq {}} {
6969                     lappend seeds $id
6970                 }
6971             }
6972             set allcwait 0
6973         } else {
6974             while {[incr a] <= $lim} {
6975                 set line [gets $f]
6976                 if {[llength $line] != 3} {error "bad line"}
6977                 set s [lindex $line 0]
6978                 set arcstart($a) $s
6979                 lappend arcout($s) $a
6980                 if {![info exists arcnos($s)]} {
6981                     lappend possible_seeds $s
6982                     set arcnos($s) {}
6983                 }
6984                 set e [lindex $line 1]
6985                 if {$e eq {}} {
6986                     set growing($a) 1
6987                 } else {
6988                     set arcend($a) $e
6989                     if {![info exists arcout($e)]} {
6990                         set arcout($e) {}
6991                     }
6992                 }
6993                 set arcids($a) [lindex $line 2]
6994                 foreach id $arcids($a) {
6995                     lappend allparents($s) $id
6996                     set s $id
6997                     lappend arcnos($id) $a
6998                 }
6999                 if {![info exists allparents($s)]} {
7000                     set allparents($s) {}
7001                 }
7002                 set arctags($a) {}
7003                 set archeads($a) {}
7004             }
7005             set nextarc [expr {$a - 1}]
7006         }
7007     } err]} {
7008         dropcache $err
7009         return 0
7010     }
7011     if {!$allcwait} {
7012         getallcommits
7013     }
7014     return $allcwait
7017 proc getcache {f} {
7018     global nextarc cachedarcs possible_seeds
7020     if {[catch {
7021         set line [gets $f]
7022         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7023         # make sure it's an integer
7024         set cachedarcs [expr {int([lindex $line 1])}]
7025         if {$cachedarcs < 0} {error "bad number of arcs"}
7026         set nextarc 0
7027         set possible_seeds {}
7028         run readcache $f
7029     } err]} {
7030         dropcache $err
7031     }
7032     return 0
7035 proc dropcache {err} {
7036     global allcwait nextarc cachedarcs seeds
7038     #puts "dropping cache ($err)"
7039     foreach v {arcnos arcout arcids arcstart arcend growing \
7040                    arctags archeads allparents allchildren} {
7041         global $v
7042         catch {unset $v}
7043     }
7044     set allcwait 0
7045     set nextarc 0
7046     set cachedarcs 0
7047     set seeds {}
7048     getallcommits
7051 proc writecache {f} {
7052     global cachearc cachedarcs allccache
7053     global arcstart arcend arcnos arcids arcout
7055     set a $cachearc
7056     set lim $cachedarcs
7057     if {$lim - $a > 1000} {
7058         set lim [expr {$a + 1000}]
7059     }
7060     if {[catch {
7061         while {[incr a] <= $lim} {
7062             if {[info exists arcend($a)]} {
7063                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7064             } else {
7065                 puts $f [list $arcstart($a) {} $arcids($a)]
7066             }
7067         }
7068     } err]} {
7069         catch {close $f}
7070         catch {file delete $allccache}
7071         #puts "writing cache failed ($err)"
7072         return 0
7073     }
7074     set cachearc [expr {$a - 1}]
7075     if {$a > $cachedarcs} {
7076         puts $f "1"
7077         close $f
7078         return 0
7079     }
7080     return 1
7083 proc savecache {} {
7084     global nextarc cachedarcs cachearc allccache
7086     if {$nextarc == $cachedarcs} return
7087     set cachearc 0
7088     set cachedarcs $nextarc
7089     catch {
7090         set f [open $allccache w]
7091         puts $f [list 1 $cachedarcs]
7092         run writecache $f
7093     }
7096 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7097 # or 0 if neither is true.
7098 proc anc_or_desc {a b} {
7099     global arcout arcstart arcend arcnos cached_isanc
7101     if {$arcnos($a) eq $arcnos($b)} {
7102         # Both are on the same arc(s); either both are the same BMP,
7103         # or if one is not a BMP, the other is also not a BMP or is
7104         # the BMP at end of the arc (and it only has 1 incoming arc).
7105         # Or both can be BMPs with no incoming arcs.
7106         if {$a eq $b || $arcnos($a) eq {}} {
7107             return 0
7108         }
7109         # assert {[llength $arcnos($a)] == 1}
7110         set arc [lindex $arcnos($a) 0]
7111         set i [lsearch -exact $arcids($arc) $a]
7112         set j [lsearch -exact $arcids($arc) $b]
7113         if {$i < 0 || $i > $j} {
7114             return 1
7115         } else {
7116             return -1
7117         }
7118     }
7120     if {![info exists arcout($a)]} {
7121         set arc [lindex $arcnos($a) 0]
7122         if {[info exists arcend($arc)]} {
7123             set aend $arcend($arc)
7124         } else {
7125             set aend {}
7126         }
7127         set a $arcstart($arc)
7128     } else {
7129         set aend $a
7130     }
7131     if {![info exists arcout($b)]} {
7132         set arc [lindex $arcnos($b) 0]
7133         if {[info exists arcend($arc)]} {
7134             set bend $arcend($arc)
7135         } else {
7136             set bend {}
7137         }
7138         set b $arcstart($arc)
7139     } else {
7140         set bend $b
7141     }
7142     if {$a eq $bend} {
7143         return 1
7144     }
7145     if {$b eq $aend} {
7146         return -1
7147     }
7148     if {[info exists cached_isanc($a,$bend)]} {
7149         if {$cached_isanc($a,$bend)} {
7150             return 1
7151         }
7152     }
7153     if {[info exists cached_isanc($b,$aend)]} {
7154         if {$cached_isanc($b,$aend)} {
7155             return -1
7156         }
7157         if {[info exists cached_isanc($a,$bend)]} {
7158             return 0
7159         }
7160     }
7162     set todo [list $a $b]
7163     set anc($a) a
7164     set anc($b) b
7165     for {set i 0} {$i < [llength $todo]} {incr i} {
7166         set x [lindex $todo $i]
7167         if {$anc($x) eq {}} {
7168             continue
7169         }
7170         foreach arc $arcnos($x) {
7171             set xd $arcstart($arc)
7172             if {$xd eq $bend} {
7173                 set cached_isanc($a,$bend) 1
7174                 set cached_isanc($b,$aend) 0
7175                 return 1
7176             } elseif {$xd eq $aend} {
7177                 set cached_isanc($b,$aend) 1
7178                 set cached_isanc($a,$bend) 0
7179                 return -1
7180             }
7181             if {![info exists anc($xd)]} {
7182                 set anc($xd) $anc($x)
7183                 lappend todo $xd
7184             } elseif {$anc($xd) ne $anc($x)} {
7185                 set anc($xd) {}
7186             }
7187         }
7188     }
7189     set cached_isanc($a,$bend) 0
7190     set cached_isanc($b,$aend) 0
7191     return 0
7194 # This identifies whether $desc has an ancestor that is
7195 # a growing tip of the graph and which is not an ancestor of $anc
7196 # and returns 0 if so and 1 if not.
7197 # If we subsequently discover a tag on such a growing tip, and that
7198 # turns out to be a descendent of $anc (which it could, since we
7199 # don't necessarily see children before parents), then $desc
7200 # isn't a good choice to display as a descendent tag of
7201 # $anc (since it is the descendent of another tag which is
7202 # a descendent of $anc).  Similarly, $anc isn't a good choice to
7203 # display as a ancestor tag of $desc.
7205 proc is_certain {desc anc} {
7206     global arcnos arcout arcstart arcend growing problems
7208     set certain {}
7209     if {[llength $arcnos($anc)] == 1} {
7210         # tags on the same arc are certain
7211         if {$arcnos($desc) eq $arcnos($anc)} {
7212             return 1
7213         }
7214         if {![info exists arcout($anc)]} {
7215             # if $anc is partway along an arc, use the start of the arc instead
7216             set a [lindex $arcnos($anc) 0]
7217             set anc $arcstart($a)
7218         }
7219     }
7220     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7221         set x $desc
7222     } else {
7223         set a [lindex $arcnos($desc) 0]
7224         set x $arcend($a)
7225     }
7226     if {$x == $anc} {
7227         return 1
7228     }
7229     set anclist [list $x]
7230     set dl($x) 1
7231     set nnh 1
7232     set ngrowanc 0
7233     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7234         set x [lindex $anclist $i]
7235         if {$dl($x)} {
7236             incr nnh -1
7237         }
7238         set done($x) 1
7239         foreach a $arcout($x) {
7240             if {[info exists growing($a)]} {
7241                 if {![info exists growanc($x)] && $dl($x)} {
7242                     set growanc($x) 1
7243                     incr ngrowanc
7244                 }
7245             } else {
7246                 set y $arcend($a)
7247                 if {[info exists dl($y)]} {
7248                     if {$dl($y)} {
7249                         if {!$dl($x)} {
7250                             set dl($y) 0
7251                             if {![info exists done($y)]} {
7252                                 incr nnh -1
7253                             }
7254                             if {[info exists growanc($x)]} {
7255                                 incr ngrowanc -1
7256                             }
7257                             set xl [list $y]
7258                             for {set k 0} {$k < [llength $xl]} {incr k} {
7259                                 set z [lindex $xl $k]
7260                                 foreach c $arcout($z) {
7261                                     if {[info exists arcend($c)]} {
7262                                         set v $arcend($c)
7263                                         if {[info exists dl($v)] && $dl($v)} {
7264                                             set dl($v) 0
7265                                             if {![info exists done($v)]} {
7266                                                 incr nnh -1
7267                                             }
7268                                             if {[info exists growanc($v)]} {
7269                                                 incr ngrowanc -1
7270                                             }
7271                                             lappend xl $v
7272                                         }
7273                                     }
7274                                 }
7275                             }
7276                         }
7277                     }
7278                 } elseif {$y eq $anc || !$dl($x)} {
7279                     set dl($y) 0
7280                     lappend anclist $y
7281                 } else {
7282                     set dl($y) 1
7283                     lappend anclist $y
7284                     incr nnh
7285                 }
7286             }
7287         }
7288     }
7289     foreach x [array names growanc] {
7290         if {$dl($x)} {
7291             return 0
7292         }
7293         return 0
7294     }
7295     return 1
7298 proc validate_arctags {a} {
7299     global arctags idtags
7301     set i -1
7302     set na $arctags($a)
7303     foreach id $arctags($a) {
7304         incr i
7305         if {![info exists idtags($id)]} {
7306             set na [lreplace $na $i $i]
7307             incr i -1
7308         }
7309     }
7310     set arctags($a) $na
7313 proc validate_archeads {a} {
7314     global archeads idheads
7316     set i -1
7317     set na $archeads($a)
7318     foreach id $archeads($a) {
7319         incr i
7320         if {![info exists idheads($id)]} {
7321             set na [lreplace $na $i $i]
7322             incr i -1
7323         }
7324     }
7325     set archeads($a) $na
7328 # Return the list of IDs that have tags that are descendents of id,
7329 # ignoring IDs that are descendents of IDs already reported.
7330 proc desctags {id} {
7331     global arcnos arcstart arcids arctags idtags allparents
7332     global growing cached_dtags
7334     if {![info exists allparents($id)]} {
7335         return {}
7336     }
7337     set t1 [clock clicks -milliseconds]
7338     set argid $id
7339     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7340         # part-way along an arc; check that arc first
7341         set a [lindex $arcnos($id) 0]
7342         if {$arctags($a) ne {}} {
7343             validate_arctags $a
7344             set i [lsearch -exact $arcids($a) $id]
7345             set tid {}
7346             foreach t $arctags($a) {
7347                 set j [lsearch -exact $arcids($a) $t]
7348                 if {$j >= $i} break
7349                 set tid $t
7350             }
7351             if {$tid ne {}} {
7352                 return $tid
7353             }
7354         }
7355         set id $arcstart($a)
7356         if {[info exists idtags($id)]} {
7357             return $id
7358         }
7359     }
7360     if {[info exists cached_dtags($id)]} {
7361         return $cached_dtags($id)
7362     }
7364     set origid $id
7365     set todo [list $id]
7366     set queued($id) 1
7367     set nc 1
7368     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7369         set id [lindex $todo $i]
7370         set done($id) 1
7371         set ta [info exists hastaggedancestor($id)]
7372         if {!$ta} {
7373             incr nc -1
7374         }
7375         # ignore tags on starting node
7376         if {!$ta && $i > 0} {
7377             if {[info exists idtags($id)]} {
7378                 set tagloc($id) $id
7379                 set ta 1
7380             } elseif {[info exists cached_dtags($id)]} {
7381                 set tagloc($id) $cached_dtags($id)
7382                 set ta 1
7383             }
7384         }
7385         foreach a $arcnos($id) {
7386             set d $arcstart($a)
7387             if {!$ta && $arctags($a) ne {}} {
7388                 validate_arctags $a
7389                 if {$arctags($a) ne {}} {
7390                     lappend tagloc($id) [lindex $arctags($a) end]
7391                 }
7392             }
7393             if {$ta || $arctags($a) ne {}} {
7394                 set tomark [list $d]
7395                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7396                     set dd [lindex $tomark $j]
7397                     if {![info exists hastaggedancestor($dd)]} {
7398                         if {[info exists done($dd)]} {
7399                             foreach b $arcnos($dd) {
7400                                 lappend tomark $arcstart($b)
7401                             }
7402                             if {[info exists tagloc($dd)]} {
7403                                 unset tagloc($dd)
7404                             }
7405                         } elseif {[info exists queued($dd)]} {
7406                             incr nc -1
7407                         }
7408                         set hastaggedancestor($dd) 1
7409                     }
7410                 }
7411             }
7412             if {![info exists queued($d)]} {
7413                 lappend todo $d
7414                 set queued($d) 1
7415                 if {![info exists hastaggedancestor($d)]} {
7416                     incr nc
7417                 }
7418             }
7419         }
7420     }
7421     set tags {}
7422     foreach id [array names tagloc] {
7423         if {![info exists hastaggedancestor($id)]} {
7424             foreach t $tagloc($id) {
7425                 if {[lsearch -exact $tags $t] < 0} {
7426                     lappend tags $t
7427                 }
7428             }
7429         }
7430     }
7431     set t2 [clock clicks -milliseconds]
7432     set loopix $i
7434     # remove tags that are descendents of other tags
7435     for {set i 0} {$i < [llength $tags]} {incr i} {
7436         set a [lindex $tags $i]
7437         for {set j 0} {$j < $i} {incr j} {
7438             set b [lindex $tags $j]
7439             set r [anc_or_desc $a $b]
7440             if {$r == 1} {
7441                 set tags [lreplace $tags $j $j]
7442                 incr j -1
7443                 incr i -1
7444             } elseif {$r == -1} {
7445                 set tags [lreplace $tags $i $i]
7446                 incr i -1
7447                 break
7448             }
7449         }
7450     }
7452     if {[array names growing] ne {}} {
7453         # graph isn't finished, need to check if any tag could get
7454         # eclipsed by another tag coming later.  Simply ignore any
7455         # tags that could later get eclipsed.
7456         set ctags {}
7457         foreach t $tags {
7458             if {[is_certain $t $origid]} {
7459                 lappend ctags $t
7460             }
7461         }
7462         if {$tags eq $ctags} {
7463             set cached_dtags($origid) $tags
7464         } else {
7465             set tags $ctags
7466         }
7467     } else {
7468         set cached_dtags($origid) $tags
7469     }
7470     set t3 [clock clicks -milliseconds]
7471     if {0 && $t3 - $t1 >= 100} {
7472         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7473             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7474     }
7475     return $tags
7478 proc anctags {id} {
7479     global arcnos arcids arcout arcend arctags idtags allparents
7480     global growing cached_atags
7482     if {![info exists allparents($id)]} {
7483         return {}
7484     }
7485     set t1 [clock clicks -milliseconds]
7486     set argid $id
7487     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7488         # part-way along an arc; check that arc first
7489         set a [lindex $arcnos($id) 0]
7490         if {$arctags($a) ne {}} {
7491             validate_arctags $a
7492             set i [lsearch -exact $arcids($a) $id]
7493             foreach t $arctags($a) {
7494                 set j [lsearch -exact $arcids($a) $t]
7495                 if {$j > $i} {
7496                     return $t
7497                 }
7498             }
7499         }
7500         if {![info exists arcend($a)]} {
7501             return {}
7502         }
7503         set id $arcend($a)
7504         if {[info exists idtags($id)]} {
7505             return $id
7506         }
7507     }
7508     if {[info exists cached_atags($id)]} {
7509         return $cached_atags($id)
7510     }
7512     set origid $id
7513     set todo [list $id]
7514     set queued($id) 1
7515     set taglist {}
7516     set nc 1
7517     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7518         set id [lindex $todo $i]
7519         set done($id) 1
7520         set td [info exists hastaggeddescendent($id)]
7521         if {!$td} {
7522             incr nc -1
7523         }
7524         # ignore tags on starting node
7525         if {!$td && $i > 0} {
7526             if {[info exists idtags($id)]} {
7527                 set tagloc($id) $id
7528                 set td 1
7529             } elseif {[info exists cached_atags($id)]} {
7530                 set tagloc($id) $cached_atags($id)
7531                 set td 1
7532             }
7533         }
7534         foreach a $arcout($id) {
7535             if {!$td && $arctags($a) ne {}} {
7536                 validate_arctags $a
7537                 if {$arctags($a) ne {}} {
7538                     lappend tagloc($id) [lindex $arctags($a) 0]
7539                 }
7540             }
7541             if {![info exists arcend($a)]} continue
7542             set d $arcend($a)
7543             if {$td || $arctags($a) ne {}} {
7544                 set tomark [list $d]
7545                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7546                     set dd [lindex $tomark $j]
7547                     if {![info exists hastaggeddescendent($dd)]} {
7548                         if {[info exists done($dd)]} {
7549                             foreach b $arcout($dd) {
7550                                 if {[info exists arcend($b)]} {
7551                                     lappend tomark $arcend($b)
7552                                 }
7553                             }
7554                             if {[info exists tagloc($dd)]} {
7555                                 unset tagloc($dd)
7556                             }
7557                         } elseif {[info exists queued($dd)]} {
7558                             incr nc -1
7559                         }
7560                         set hastaggeddescendent($dd) 1
7561                     }
7562                 }
7563             }
7564             if {![info exists queued($d)]} {
7565                 lappend todo $d
7566                 set queued($d) 1
7567                 if {![info exists hastaggeddescendent($d)]} {
7568                     incr nc
7569                 }
7570             }
7571         }
7572     }
7573     set t2 [clock clicks -milliseconds]
7574     set loopix $i
7575     set tags {}
7576     foreach id [array names tagloc] {
7577         if {![info exists hastaggeddescendent($id)]} {
7578             foreach t $tagloc($id) {
7579                 if {[lsearch -exact $tags $t] < 0} {
7580                     lappend tags $t
7581                 }
7582             }
7583         }
7584     }
7586     # remove tags that are ancestors of other tags
7587     for {set i 0} {$i < [llength $tags]} {incr i} {
7588         set a [lindex $tags $i]
7589         for {set j 0} {$j < $i} {incr j} {
7590             set b [lindex $tags $j]
7591             set r [anc_or_desc $a $b]
7592             if {$r == -1} {
7593                 set tags [lreplace $tags $j $j]
7594                 incr j -1
7595                 incr i -1
7596             } elseif {$r == 1} {
7597                 set tags [lreplace $tags $i $i]
7598                 incr i -1
7599                 break
7600             }
7601         }
7602     }
7604     if {[array names growing] ne {}} {
7605         # graph isn't finished, need to check if any tag could get
7606         # eclipsed by another tag coming later.  Simply ignore any
7607         # tags that could later get eclipsed.
7608         set ctags {}
7609         foreach t $tags {
7610             if {[is_certain $origid $t]} {
7611                 lappend ctags $t
7612             }
7613         }
7614         if {$tags eq $ctags} {
7615             set cached_atags($origid) $tags
7616         } else {
7617             set tags $ctags
7618         }
7619     } else {
7620         set cached_atags($origid) $tags
7621     }
7622     set t3 [clock clicks -milliseconds]
7623     if {0 && $t3 - $t1 >= 100} {
7624         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7625             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7626     }
7627     return $tags
7630 # Return the list of IDs that have heads that are descendents of id,
7631 # including id itself if it has a head.
7632 proc descheads {id} {
7633     global arcnos arcstart arcids archeads idheads cached_dheads
7634     global allparents
7636     if {![info exists allparents($id)]} {
7637         return {}
7638     }
7639     set aret {}
7640     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7641         # part-way along an arc; check it first
7642         set a [lindex $arcnos($id) 0]
7643         if {$archeads($a) ne {}} {
7644             validate_archeads $a
7645             set i [lsearch -exact $arcids($a) $id]
7646             foreach t $archeads($a) {
7647                 set j [lsearch -exact $arcids($a) $t]
7648                 if {$j > $i} break
7649                 lappend aret $t
7650             }
7651         }
7652         set id $arcstart($a)
7653     }
7654     set origid $id
7655     set todo [list $id]
7656     set seen($id) 1
7657     set ret {}
7658     for {set i 0} {$i < [llength $todo]} {incr i} {
7659         set id [lindex $todo $i]
7660         if {[info exists cached_dheads($id)]} {
7661             set ret [concat $ret $cached_dheads($id)]
7662         } else {
7663             if {[info exists idheads($id)]} {
7664                 lappend ret $id
7665             }
7666             foreach a $arcnos($id) {
7667                 if {$archeads($a) ne {}} {
7668                     validate_archeads $a
7669                     if {$archeads($a) ne {}} {
7670                         set ret [concat $ret $archeads($a)]
7671                     }
7672                 }
7673                 set d $arcstart($a)
7674                 if {![info exists seen($d)]} {
7675                     lappend todo $d
7676                     set seen($d) 1
7677                 }
7678             }
7679         }
7680     }
7681     set ret [lsort -unique $ret]
7682     set cached_dheads($origid) $ret
7683     return [concat $ret $aret]
7686 proc addedtag {id} {
7687     global arcnos arcout cached_dtags cached_atags
7689     if {![info exists arcnos($id)]} return
7690     if {![info exists arcout($id)]} {
7691         recalcarc [lindex $arcnos($id) 0]
7692     }
7693     catch {unset cached_dtags}
7694     catch {unset cached_atags}
7697 proc addedhead {hid head} {
7698     global arcnos arcout cached_dheads
7700     if {![info exists arcnos($hid)]} return
7701     if {![info exists arcout($hid)]} {
7702         recalcarc [lindex $arcnos($hid) 0]
7703     }
7704     catch {unset cached_dheads}
7707 proc removedhead {hid head} {
7708     global cached_dheads
7710     catch {unset cached_dheads}
7713 proc movedhead {hid head} {
7714     global arcnos arcout cached_dheads
7716     if {![info exists arcnos($hid)]} return
7717     if {![info exists arcout($hid)]} {
7718         recalcarc [lindex $arcnos($hid) 0]
7719     }
7720     catch {unset cached_dheads}
7723 proc changedrefs {} {
7724     global cached_dheads cached_dtags cached_atags
7725     global arctags archeads arcnos arcout idheads idtags
7727     foreach id [concat [array names idheads] [array names idtags]] {
7728         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7729             set a [lindex $arcnos($id) 0]
7730             if {![info exists donearc($a)]} {
7731                 recalcarc $a
7732                 set donearc($a) 1
7733             }
7734         }
7735     }
7736     catch {unset cached_dtags}
7737     catch {unset cached_atags}
7738     catch {unset cached_dheads}
7741 proc rereadrefs {} {
7742     global idtags idheads idotherrefs mainhead
7744     set refids [concat [array names idtags] \
7745                     [array names idheads] [array names idotherrefs]]
7746     foreach id $refids {
7747         if {![info exists ref($id)]} {
7748             set ref($id) [listrefs $id]
7749         }
7750     }
7751     set oldmainhead $mainhead
7752     readrefs
7753     changedrefs
7754     set refids [lsort -unique [concat $refids [array names idtags] \
7755                         [array names idheads] [array names idotherrefs]]]
7756     foreach id $refids {
7757         set v [listrefs $id]
7758         if {![info exists ref($id)] || $ref($id) != $v ||
7759             ($id eq $oldmainhead && $id ne $mainhead) ||
7760             ($id eq $mainhead && $id ne $oldmainhead)} {
7761             redrawtags $id
7762         }
7763     }
7764     run refill_reflist
7767 proc listrefs {id} {
7768     global idtags idheads idotherrefs
7770     set x {}
7771     if {[info exists idtags($id)]} {
7772         set x $idtags($id)
7773     }
7774     set y {}
7775     if {[info exists idheads($id)]} {
7776         set y $idheads($id)
7777     }
7778     set z {}
7779     if {[info exists idotherrefs($id)]} {
7780         set z $idotherrefs($id)
7781     }
7782     return [list $x $y $z]
7785 proc showtag {tag isnew} {
7786     global ctext tagcontents tagids linknum tagobjid
7788     if {$isnew} {
7789         addtohistory [list showtag $tag 0]
7790     }
7791     $ctext conf -state normal
7792     clear_ctext
7793     settabs 0
7794     set linknum 0
7795     if {![info exists tagcontents($tag)]} {
7796         catch {
7797             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7798         }
7799     }
7800     if {[info exists tagcontents($tag)]} {
7801         set text $tagcontents($tag)
7802     } else {
7803         set text "Tag: $tag\nId:  $tagids($tag)"
7804     }
7805     appendwithlinks $text {}
7806     $ctext conf -state disabled
7807     init_flist {}
7810 proc doquit {} {
7811     global stopped
7812     set stopped 100
7813     savestuff .
7814     destroy .
7817 proc mkfontdisp {font top which} {
7818     global fontattr fontpref $font
7820     set fontpref($font) [set $font]
7821     button $top.${font}but -text $which -font optionfont \
7822         -command [list choosefont $font $which]
7823     label $top.$font -relief flat -font $font \
7824         -text $fontattr($font,family) -justify left
7825     grid x $top.${font}but $top.$font -sticky w
7828 proc choosefont {font which} {
7829     global fontparam fontlist fonttop fontattr
7831     set fontparam(which) $which
7832     set fontparam(font) $font
7833     set fontparam(family) [font actual $font -family]
7834     set fontparam(size) $fontattr($font,size)
7835     set fontparam(weight) $fontattr($font,weight)
7836     set fontparam(slant) $fontattr($font,slant)
7837     set top .gitkfont
7838     set fonttop $top
7839     if {![winfo exists $top]} {
7840         font create sample
7841         eval font config sample [font actual $font]
7842         toplevel $top
7843         wm title $top "Gitk font chooser"
7844         label $top.l -textvariable fontparam(which) -font uifont
7845         pack $top.l -side top
7846         set fontlist [lsort [font families]]
7847         frame $top.f
7848         listbox $top.f.fam -listvariable fontlist \
7849             -yscrollcommand [list $top.f.sb set]
7850         bind $top.f.fam <<ListboxSelect>> selfontfam
7851         scrollbar $top.f.sb -command [list $top.f.fam yview]
7852         pack $top.f.sb -side right -fill y
7853         pack $top.f.fam -side left -fill both -expand 1
7854         pack $top.f -side top -fill both -expand 1
7855         frame $top.g
7856         spinbox $top.g.size -from 4 -to 40 -width 4 \
7857             -textvariable fontparam(size) \
7858             -validatecommand {string is integer -strict %s}
7859         checkbutton $top.g.bold -padx 5 \
7860             -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7861             -variable fontparam(weight) -onvalue bold -offvalue normal
7862         checkbutton $top.g.ital -padx 5 \
7863             -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0  \
7864             -variable fontparam(slant) -onvalue italic -offvalue roman
7865         pack $top.g.size $top.g.bold $top.g.ital -side left
7866         pack $top.g -side top
7867         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7868             -background white
7869         $top.c create text 100 25 -anchor center -text $which -font sample \
7870             -fill black -tags text
7871         bind $top.c <Configure> [list centertext $top.c]
7872         pack $top.c -side top -fill x
7873         frame $top.buts
7874         button $top.buts.ok -text "OK" -command fontok -default active \
7875             -font uifont
7876         button $top.buts.can -text "Cancel" -command fontcan -default normal \
7877             -font uifont
7878         grid $top.buts.ok $top.buts.can
7879         grid columnconfigure $top.buts 0 -weight 1 -uniform a
7880         grid columnconfigure $top.buts 1 -weight 1 -uniform a
7881         pack $top.buts -side bottom -fill x
7882         trace add variable fontparam write chg_fontparam
7883     } else {
7884         raise $top
7885         $top.c itemconf text -text $which
7886     }
7887     set i [lsearch -exact $fontlist $fontparam(family)]
7888     if {$i >= 0} {
7889         $top.f.fam selection set $i
7890         $top.f.fam see $i
7891     }
7894 proc centertext {w} {
7895     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7898 proc fontok {} {
7899     global fontparam fontpref prefstop
7901     set f $fontparam(font)
7902     set fontpref($f) [list $fontparam(family) $fontparam(size)]
7903     if {$fontparam(weight) eq "bold"} {
7904         lappend fontpref($f) "bold"
7905     }
7906     if {$fontparam(slant) eq "italic"} {
7907         lappend fontpref($f) "italic"
7908     }
7909     set w $prefstop.$f
7910     $w conf -text $fontparam(family) -font $fontpref($f)
7911         
7912     fontcan
7915 proc fontcan {} {
7916     global fonttop fontparam
7918     if {[info exists fonttop]} {
7919         catch {destroy $fonttop}
7920         catch {font delete sample}
7921         unset fonttop
7922         unset fontparam
7923     }
7926 proc selfontfam {} {
7927     global fonttop fontparam
7929     set i [$fonttop.f.fam curselection]
7930     if {$i ne {}} {
7931         set fontparam(family) [$fonttop.f.fam get $i]
7932     }
7935 proc chg_fontparam {v sub op} {
7936     global fontparam
7938     font config sample -$sub $fontparam($sub)
7941 proc doprefs {} {
7942     global maxwidth maxgraphpct
7943     global oldprefs prefstop showneartags showlocalchanges
7944     global bgcolor fgcolor ctext diffcolors selectbgcolor
7945     global uifont tabstop limitdiffs
7947     set top .gitkprefs
7948     set prefstop $top
7949     if {[winfo exists $top]} {
7950         raise $top
7951         return
7952     }
7953     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7954                    limitdiffs tabstop} {
7955         set oldprefs($v) [set $v]
7956     }
7957     toplevel $top
7958     wm title $top "Gitk preferences"
7959     label $top.ldisp -text "Commit list display options"
7960     $top.ldisp configure -font uifont
7961     grid $top.ldisp - -sticky w -pady 10
7962     label $top.spacer -text " "
7963     label $top.maxwidthl -text "Maximum graph width (lines)" \
7964         -font optionfont
7965     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7966     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7967     label $top.maxpctl -text "Maximum graph width (% of pane)" \
7968         -font optionfont
7969     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7970     grid x $top.maxpctl $top.maxpct -sticky w
7971     frame $top.showlocal
7972     label $top.showlocal.l -text "Show local changes" -font optionfont
7973     checkbutton $top.showlocal.b -variable showlocalchanges
7974     pack $top.showlocal.b $top.showlocal.l -side left
7975     grid x $top.showlocal -sticky w
7977     label $top.ddisp -text "Diff display options"
7978     $top.ddisp configure -font uifont
7979     grid $top.ddisp - -sticky w -pady 10
7980     label $top.tabstopl -text "Tab spacing" -font optionfont
7981     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7982     grid x $top.tabstopl $top.tabstop -sticky w
7983     frame $top.ntag
7984     label $top.ntag.l -text "Display nearby tags" -font optionfont
7985     checkbutton $top.ntag.b -variable showneartags
7986     pack $top.ntag.b $top.ntag.l -side left
7987     grid x $top.ntag -sticky w
7988     frame $top.ldiff
7989     label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
7990     checkbutton $top.ldiff.b -variable limitdiffs
7991     pack $top.ldiff.b $top.ldiff.l -side left
7992     grid x $top.ldiff -sticky w
7994     label $top.cdisp -text "Colors: press to choose"
7995     $top.cdisp configure -font uifont
7996     grid $top.cdisp - -sticky w -pady 10
7997     label $top.bg -padx 40 -relief sunk -background $bgcolor
7998     button $top.bgbut -text "Background" -font optionfont \
7999         -command [list choosecolor bgcolor 0 $top.bg background setbg]
8000     grid x $top.bgbut $top.bg -sticky w
8001     label $top.fg -padx 40 -relief sunk -background $fgcolor
8002     button $top.fgbut -text "Foreground" -font optionfont \
8003         -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
8004     grid x $top.fgbut $top.fg -sticky w
8005     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8006     button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8007         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8008                       [list $ctext tag conf d0 -foreground]]
8009     grid x $top.diffoldbut $top.diffold -sticky w
8010     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8011     button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8012         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8013                       [list $ctext tag conf d1 -foreground]]
8014     grid x $top.diffnewbut $top.diffnew -sticky w
8015     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8016     button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8017         -command [list choosecolor diffcolors 2 $top.hunksep \
8018                       "diff hunk header" \
8019                       [list $ctext tag conf hunksep -foreground]]
8020     grid x $top.hunksepbut $top.hunksep -sticky w
8021     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8022     button $top.selbgbut -text "Select bg" -font optionfont \
8023         -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8024     grid x $top.selbgbut $top.selbgsep -sticky w
8026     label $top.cfont -text "Fonts: press to choose"
8027     $top.cfont configure -font uifont
8028     grid $top.cfont - -sticky w -pady 10
8029     mkfontdisp mainfont $top "Main font"
8030     mkfontdisp textfont $top "Diff display font"
8031     mkfontdisp uifont $top "User interface font"
8033     frame $top.buts
8034     button $top.buts.ok -text "OK" -command prefsok -default active
8035     $top.buts.ok configure -font uifont
8036     button $top.buts.can -text "Cancel" -command prefscan -default normal
8037     $top.buts.can configure -font uifont
8038     grid $top.buts.ok $top.buts.can
8039     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8040     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8041     grid $top.buts - - -pady 10 -sticky ew
8042     bind $top <Visibility> "focus $top.buts.ok"
8045 proc choosecolor {v vi w x cmd} {
8046     global $v
8048     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8049                -title "Gitk: choose color for $x"]
8050     if {$c eq {}} return
8051     $w conf -background $c
8052     lset $v $vi $c
8053     eval $cmd $c
8056 proc setselbg {c} {
8057     global bglist cflist
8058     foreach w $bglist {
8059         $w configure -selectbackground $c
8060     }
8061     $cflist tag configure highlight \
8062         -background [$cflist cget -selectbackground]
8063     allcanvs itemconf secsel -fill $c
8066 proc setbg {c} {
8067     global bglist
8069     foreach w $bglist {
8070         $w conf -background $c
8071     }
8074 proc setfg {c} {
8075     global fglist canv
8077     foreach w $fglist {
8078         $w conf -foreground $c
8079     }
8080     allcanvs itemconf text -fill $c
8081     $canv itemconf circle -outline $c
8084 proc prefscan {} {
8085     global oldprefs prefstop
8087     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8088                    limitdiffs tabstop} {
8089         global $v
8090         set $v $oldprefs($v)
8091     }
8092     catch {destroy $prefstop}
8093     unset prefstop
8094     fontcan
8097 proc prefsok {} {
8098     global maxwidth maxgraphpct
8099     global oldprefs prefstop showneartags showlocalchanges
8100     global fontpref mainfont textfont uifont
8101     global limitdiffs treediffs
8103     catch {destroy $prefstop}
8104     unset prefstop
8105     fontcan
8106     set fontchanged 0
8107     if {$mainfont ne $fontpref(mainfont)} {
8108         set mainfont $fontpref(mainfont)
8109         parsefont mainfont $mainfont
8110         eval font configure mainfont [fontflags mainfont]
8111         eval font configure mainfontbold [fontflags mainfont 1]
8112         setcoords
8113         set fontchanged 1
8114     }
8115     if {$textfont ne $fontpref(textfont)} {
8116         set textfont $fontpref(textfont)
8117         parsefont textfont $textfont
8118         eval font configure textfont [fontflags textfont]
8119         eval font configure textfontbold [fontflags textfont 1]
8120     }
8121     if {$uifont ne $fontpref(uifont)} {
8122         set uifont $fontpref(uifont)
8123         parsefont uifont $uifont
8124         eval font configure uifont [fontflags uifont]
8125     }
8126     settabs
8127     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8128         if {$showlocalchanges} {
8129             doshowlocalchanges
8130         } else {
8131             dohidelocalchanges
8132         }
8133     }
8134     if {$limitdiffs != $oldprefs(limitdiffs)} {
8135         # treediffs elements are limited by path
8136         catch {unset treediffs}
8137     }
8138     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8139         || $maxgraphpct != $oldprefs(maxgraphpct)} {
8140         redisplay
8141     } elseif {$showneartags != $oldprefs(showneartags) ||
8142           $limitdiffs != $oldprefs(limitdiffs)} {
8143         reselectline
8144     }
8147 proc formatdate {d} {
8148     global datetimeformat
8149     if {$d ne {}} {
8150         set d [clock format $d -format $datetimeformat]
8151     }
8152     return $d
8155 # This list of encoding names and aliases is distilled from
8156 # http://www.iana.org/assignments/character-sets.
8157 # Not all of them are supported by Tcl.
8158 set encoding_aliases {
8159     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8160       ISO646-US US-ASCII us IBM367 cp367 csASCII }
8161     { ISO-10646-UTF-1 csISO10646UTF1 }
8162     { ISO_646.basic:1983 ref csISO646basic1983 }
8163     { INVARIANT csINVARIANT }
8164     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8165     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8166     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8167     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8168     { NATS-DANO iso-ir-9-1 csNATSDANO }
8169     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8170     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8171     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8172     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8173     { ISO-2022-KR csISO2022KR }
8174     { EUC-KR csEUCKR }
8175     { ISO-2022-JP csISO2022JP }
8176     { ISO-2022-JP-2 csISO2022JP2 }
8177     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8178       csISO13JISC6220jp }
8179     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8180     { IT iso-ir-15 ISO646-IT csISO15Italian }
8181     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8182     { ES iso-ir-17 ISO646-ES csISO17Spanish }
8183     { greek7-old iso-ir-18 csISO18Greek7Old }
8184     { latin-greek iso-ir-19 csISO19LatinGreek }
8185     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8186     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8187     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8188     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8189     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8190     { BS_viewdata iso-ir-47 csISO47BSViewdata }
8191     { INIS iso-ir-49 csISO49INIS }
8192     { INIS-8 iso-ir-50 csISO50INIS8 }
8193     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8194     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8195     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8196     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8197     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8198     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8199       csISO60Norwegian1 }
8200     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8201     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8202     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8203     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8204     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8205     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8206     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8207     { greek7 iso-ir-88 csISO88Greek7 }
8208     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8209     { iso-ir-90 csISO90 }
8210     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8211     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8212       csISO92JISC62991984b }
8213     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8214     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8215     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8216       csISO95JIS62291984handadd }
8217     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8218     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8219     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8220     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8221       CP819 csISOLatin1 }
8222     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8223     { T.61-7bit iso-ir-102 csISO102T617bit }
8224     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8225     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8226     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8227     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8228     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8229     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8230     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8231     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8232       arabic csISOLatinArabic }
8233     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8234     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8235     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8236       greek greek8 csISOLatinGreek }
8237     { T.101-G2 iso-ir-128 csISO128T101G2 }
8238     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8239       csISOLatinHebrew }
8240     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8241     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8242     { CSN_369103 iso-ir-139 csISO139CSN369103 }
8243     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8244     { ISO_6937-2-add iso-ir-142 csISOTextComm }
8245     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8246     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8247       csISOLatinCyrillic }
8248     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8249     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8250     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8251     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8252     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8253     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8254     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8255     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8256     { ISO_10367-box iso-ir-155 csISO10367Box }
8257     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8258     { latin-lap lap iso-ir-158 csISO158Lap }
8259     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8260     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8261     { us-dk csUSDK }
8262     { dk-us csDKUS }
8263     { JIS_X0201 X0201 csHalfWidthKatakana }
8264     { KSC5636 ISO646-KR csKSC5636 }
8265     { ISO-10646-UCS-2 csUnicode }
8266     { ISO-10646-UCS-4 csUCS4 }
8267     { DEC-MCS dec csDECMCS }
8268     { hp-roman8 roman8 r8 csHPRoman8 }
8269     { macintosh mac csMacintosh }
8270     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8271       csIBM037 }
8272     { IBM038 EBCDIC-INT cp038 csIBM038 }
8273     { IBM273 CP273 csIBM273 }
8274     { IBM274 EBCDIC-BE CP274 csIBM274 }
8275     { IBM275 EBCDIC-BR cp275 csIBM275 }
8276     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8277     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8278     { IBM280 CP280 ebcdic-cp-it csIBM280 }
8279     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8280     { IBM284 CP284 ebcdic-cp-es csIBM284 }
8281     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8282     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8283     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8284     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8285     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8286     { IBM424 cp424 ebcdic-cp-he csIBM424 }
8287     { IBM437 cp437 437 csPC8CodePage437 }
8288     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8289     { IBM775 cp775 csPC775Baltic }
8290     { IBM850 cp850 850 csPC850Multilingual }
8291     { IBM851 cp851 851 csIBM851 }
8292     { IBM852 cp852 852 csPCp852 }
8293     { IBM855 cp855 855 csIBM855 }
8294     { IBM857 cp857 857 csIBM857 }
8295     { IBM860 cp860 860 csIBM860 }
8296     { IBM861 cp861 861 cp-is csIBM861 }
8297     { IBM862 cp862 862 csPC862LatinHebrew }
8298     { IBM863 cp863 863 csIBM863 }
8299     { IBM864 cp864 csIBM864 }
8300     { IBM865 cp865 865 csIBM865 }
8301     { IBM866 cp866 866 csIBM866 }
8302     { IBM868 CP868 cp-ar csIBM868 }
8303     { IBM869 cp869 869 cp-gr csIBM869 }
8304     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8305     { IBM871 CP871 ebcdic-cp-is csIBM871 }
8306     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8307     { IBM891 cp891 csIBM891 }
8308     { IBM903 cp903 csIBM903 }
8309     { IBM904 cp904 904 csIBBM904 }
8310     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8311     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8312     { IBM1026 CP1026 csIBM1026 }
8313     { EBCDIC-AT-DE csIBMEBCDICATDE }
8314     { EBCDIC-AT-DE-A csEBCDICATDEA }
8315     { EBCDIC-CA-FR csEBCDICCAFR }
8316     { EBCDIC-DK-NO csEBCDICDKNO }
8317     { EBCDIC-DK-NO-A csEBCDICDKNOA }
8318     { EBCDIC-FI-SE csEBCDICFISE }
8319     { EBCDIC-FI-SE-A csEBCDICFISEA }
8320     { EBCDIC-FR csEBCDICFR }
8321     { EBCDIC-IT csEBCDICIT }
8322     { EBCDIC-PT csEBCDICPT }
8323     { EBCDIC-ES csEBCDICES }
8324     { EBCDIC-ES-A csEBCDICESA }
8325     { EBCDIC-ES-S csEBCDICESS }
8326     { EBCDIC-UK csEBCDICUK }
8327     { EBCDIC-US csEBCDICUS }
8328     { UNKNOWN-8BIT csUnknown8BiT }
8329     { MNEMONIC csMnemonic }
8330     { MNEM csMnem }
8331     { VISCII csVISCII }
8332     { VIQR csVIQR }
8333     { KOI8-R csKOI8R }
8334     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8335     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8336     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8337     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8338     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8339     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8340     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8341     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8342     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8343     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8344     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8345     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8346     { IBM1047 IBM-1047 }
8347     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8348     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8349     { UNICODE-1-1 csUnicode11 }
8350     { CESU-8 csCESU-8 }
8351     { BOCU-1 csBOCU-1 }
8352     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8353     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8354       l8 }
8355     { ISO-8859-15 ISO_8859-15 Latin-9 }
8356     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8357     { GBK CP936 MS936 windows-936 }
8358     { JIS_Encoding csJISEncoding }
8359     { Shift_JIS MS_Kanji csShiftJIS }
8360     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8361       EUC-JP }
8362     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8363     { ISO-10646-UCS-Basic csUnicodeASCII }
8364     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8365     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8366     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8367     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8368     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8369     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8370     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8371     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8372     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8373     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8374     { Adobe-Standard-Encoding csAdobeStandardEncoding }
8375     { Ventura-US csVenturaUS }
8376     { Ventura-International csVenturaInternational }
8377     { PC8-Danish-Norwegian csPC8DanishNorwegian }
8378     { PC8-Turkish csPC8Turkish }
8379     { IBM-Symbols csIBMSymbols }
8380     { IBM-Thai csIBMThai }
8381     { HP-Legal csHPLegal }
8382     { HP-Pi-font csHPPiFont }
8383     { HP-Math8 csHPMath8 }
8384     { Adobe-Symbol-Encoding csHPPSMath }
8385     { HP-DeskTop csHPDesktop }
8386     { Ventura-Math csVenturaMath }
8387     { Microsoft-Publishing csMicrosoftPublishing }
8388     { Windows-31J csWindows31J }
8389     { GB2312 csGB2312 }
8390     { Big5 csBig5 }
8393 proc tcl_encoding {enc} {
8394     global encoding_aliases
8395     set names [encoding names]
8396     set lcnames [string tolower $names]
8397     set enc [string tolower $enc]
8398     set i [lsearch -exact $lcnames $enc]
8399     if {$i < 0} {
8400         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8401         if {[regsub {^iso[-_]} $enc iso encx]} {
8402             set i [lsearch -exact $lcnames $encx]
8403         }
8404     }
8405     if {$i < 0} {
8406         foreach l $encoding_aliases {
8407             set ll [string tolower $l]
8408             if {[lsearch -exact $ll $enc] < 0} continue
8409             # look through the aliases for one that tcl knows about
8410             foreach e $ll {
8411                 set i [lsearch -exact $lcnames $e]
8412                 if {$i < 0} {
8413                     if {[regsub {^iso[-_]} $e iso ex]} {
8414                         set i [lsearch -exact $lcnames $ex]
8415                     }
8416                 }
8417                 if {$i >= 0} break
8418             }
8419             break
8420         }
8421     }
8422     if {$i >= 0} {
8423         return [lindex $names $i]
8424     }
8425     return {}
8428 # First check that Tcl/Tk is recent enough
8429 if {[catch {package require Tk 8.4} err]} {
8430     show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8431                      Gitk requires at least Tcl/Tk 8.4."
8432     exit 1
8435 # defaults...
8436 set datemode 0
8437 set wrcomcmd "git diff-tree --stdin -p --pretty"
8439 set gitencoding {}
8440 catch {
8441     set gitencoding [exec git config --get i18n.commitencoding]
8443 if {$gitencoding == ""} {
8444     set gitencoding "utf-8"
8446 set tclencoding [tcl_encoding $gitencoding]
8447 if {$tclencoding == {}} {
8448     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8451 set mainfont {Helvetica 9}
8452 set textfont {Courier 9}
8453 set uifont {Helvetica 9 bold}
8454 set tabstop 8
8455 set findmergefiles 0
8456 set maxgraphpct 50
8457 set maxwidth 16
8458 set revlistorder 0
8459 set fastdate 0
8460 set uparrowlen 5
8461 set downarrowlen 5
8462 set mingaplen 100
8463 set cmitmode "patch"
8464 set wrapcomment "none"
8465 set showneartags 1
8466 set maxrefs 20
8467 set maxlinelen 200
8468 set showlocalchanges 1
8469 set limitdiffs 1
8470 set datetimeformat "%Y-%m-%d %H:%M:%S"
8472 set colors {green red blue magenta darkgrey brown orange}
8473 set bgcolor white
8474 set fgcolor black
8475 set diffcolors {red "#00a000" blue}
8476 set diffcontext 3
8477 set selectbgcolor gray85
8479 catch {source ~/.gitk}
8481 font create optionfont -family sans-serif -size -12
8483 parsefont mainfont $mainfont
8484 eval font create mainfont [fontflags mainfont]
8485 eval font create mainfontbold [fontflags mainfont 1]
8487 parsefont textfont $textfont
8488 eval font create textfont [fontflags textfont]
8489 eval font create textfontbold [fontflags textfont 1]
8491 parsefont uifont $uifont
8492 eval font create uifont [fontflags uifont]
8494 # check that we can find a .git directory somewhere...
8495 if {[catch {set gitdir [gitdir]}]} {
8496     show_error {} . "Cannot find a git repository here."
8497     exit 1
8499 if {![file isdirectory $gitdir]} {
8500     show_error {} . "Cannot find the git directory \"$gitdir\"."
8501     exit 1
8504 set mergeonly 0
8505 set revtreeargs {}
8506 set cmdline_files {}
8507 set i 0
8508 foreach arg $argv {
8509     switch -- $arg {
8510         "" { }
8511         "-d" { set datemode 1 }
8512         "--merge" {
8513             set mergeonly 1
8514             lappend revtreeargs $arg
8515         }
8516         "--" {
8517             set cmdline_files [lrange $argv [expr {$i + 1}] end]
8518             break
8519         }
8520         default {
8521             lappend revtreeargs $arg
8522         }
8523     }
8524     incr i
8527 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8528     # no -- on command line, but some arguments (other than -d)
8529     if {[catch {
8530         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8531         set cmdline_files [split $f "\n"]
8532         set n [llength $cmdline_files]
8533         set revtreeargs [lrange $revtreeargs 0 end-$n]
8534         # Unfortunately git rev-parse doesn't produce an error when
8535         # something is both a revision and a filename.  To be consistent
8536         # with git log and git rev-list, check revtreeargs for filenames.
8537         foreach arg $revtreeargs {
8538             if {[file exists $arg]} {
8539                 show_error {} . "Ambiguous argument '$arg': both revision\
8540                                  and filename"
8541                 exit 1
8542             }
8543         }
8544     } err]} {
8545         # unfortunately we get both stdout and stderr in $err,
8546         # so look for "fatal:".
8547         set i [string first "fatal:" $err]
8548         if {$i > 0} {
8549             set err [string range $err [expr {$i + 6}] end]
8550         }
8551         show_error {} . "Bad arguments to gitk:\n$err"
8552         exit 1
8553     }
8556 if {$mergeonly} {
8557     # find the list of unmerged files
8558     set mlist {}
8559     set nr_unmerged 0
8560     if {[catch {
8561         set fd [open "| git ls-files -u" r]
8562     } err]} {
8563         show_error {} . "Couldn't get list of unmerged files: $err"
8564         exit 1
8565     }
8566     while {[gets $fd line] >= 0} {
8567         set i [string first "\t" $line]
8568         if {$i < 0} continue
8569         set fname [string range $line [expr {$i+1}] end]
8570         if {[lsearch -exact $mlist $fname] >= 0} continue
8571         incr nr_unmerged
8572         if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8573             lappend mlist $fname
8574         }
8575     }
8576     catch {close $fd}
8577     if {$mlist eq {}} {
8578         if {$nr_unmerged == 0} {
8579             show_error {} . "No files selected: --merge specified but\
8580                              no files are unmerged."
8581         } else {
8582             show_error {} . "No files selected: --merge specified but\
8583                              no unmerged files are within file limit."
8584         }
8585         exit 1
8586     }
8587     set cmdline_files $mlist
8590 set nullid "0000000000000000000000000000000000000000"
8591 set nullid2 "0000000000000000000000000000000000000001"
8593 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8595 set runq {}
8596 set history {}
8597 set historyindex 0
8598 set fh_serial 0
8599 set nhl_names {}
8600 set highlight_paths {}
8601 set findpattern {}
8602 set searchdirn -forwards
8603 set boldrows {}
8604 set boldnamerows {}
8605 set diffelide {0 0}
8606 set markingmatches 0
8607 set linkentercount 0
8608 set need_redisplay 0
8609 set nrows_drawn 0
8610 set firsttabstop 0
8612 set nextviewnum 1
8613 set curview 0
8614 set selectedview 0
8615 set selectedhlview None
8616 set highlight_related None
8617 set highlight_files {}
8618 set viewfiles(0) {}
8619 set viewperm(0) 0
8620 set viewargs(0) {}
8622 set cmdlineok 0
8623 set stopped 0
8624 set stuffsaved 0
8625 set patchnum 0
8626 set localirow -1
8627 set localfrow -1
8628 set lserial 0
8629 setcoords
8630 makewindow
8631 # wait for the window to become visible
8632 tkwait visibility .
8633 wm title . "[file tail $argv0]: [file tail [pwd]]"
8634 readrefs
8636 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8637     # create a view for the files/dirs specified on the command line
8638     set curview 1
8639     set selectedview 1
8640     set nextviewnum 2
8641     set viewname(1) "Command line"
8642     set viewfiles(1) $cmdline_files
8643     set viewargs(1) $revtreeargs
8644     set viewperm(1) 0
8645     addviewmenu 1
8646     .bar.view entryconf Edit* -state normal
8647     .bar.view entryconf Delete* -state normal
8650 if {[info exists permviews]} {
8651     foreach v $permviews {
8652         set n $nextviewnum
8653         incr nextviewnum
8654         set viewname($n) [lindex $v 0]
8655         set viewfiles($n) [lindex $v 1]
8656         set viewargs($n) [lindex $v 2]
8657         set viewperm($n) 1
8658         addviewmenu $n
8659     }
8661 getcommits