Code

gitk: Simplify the code for finding commits
[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" \
834         -command changediffdisp -variable diffelide -value {0 0}
835     radiobutton .bleft.mid.old -text "Old version" \
836         -command changediffdisp -variable diffelide -value {0 1}
837     radiobutton .bleft.mid.new -text "New version" \
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 compare -length $l $p $name] == 0 &&
5150             ([string length $name] == $l || [string index $name $l] eq "/")} {
5151             return 1
5152         }
5153     }
5154     return 0
5157 proc addtocflist {ids} {
5158     global treediffs cflist viewfiles curview limitdiffs
5160     if {$limitdiffs && $viewfiles($curview) ne {}} {
5161         set flist {}
5162         foreach f $treediffs($ids) {
5163             if {[path_filter $viewfiles($curview) $f]} {
5164                 lappend flist $f
5165             }
5166         }
5167     } else {
5168         set flist $treediffs($ids)
5169     }
5170     add_flist $flist
5171     getblobdiffs $ids
5174 proc diffcmd {ids flags} {
5175     global nullid nullid2
5177     set i [lsearch -exact $ids $nullid]
5178     set j [lsearch -exact $ids $nullid2]
5179     if {$i >= 0} {
5180         if {[llength $ids] > 1 && $j < 0} {
5181             # comparing working directory with some specific revision
5182             set cmd [concat | git diff-index $flags]
5183             if {$i == 0} {
5184                 lappend cmd -R [lindex $ids 1]
5185             } else {
5186                 lappend cmd [lindex $ids 0]
5187             }
5188         } else {
5189             # comparing working directory with index
5190             set cmd [concat | git diff-files $flags]
5191             if {$j == 1} {
5192                 lappend cmd -R
5193             }
5194         }
5195     } elseif {$j >= 0} {
5196         set cmd [concat | git diff-index --cached $flags]
5197         if {[llength $ids] > 1} {
5198             # comparing index with specific revision
5199             if {$i == 0} {
5200                 lappend cmd -R [lindex $ids 1]
5201             } else {
5202                 lappend cmd [lindex $ids 0]
5203             }
5204         } else {
5205             # comparing index with HEAD
5206             lappend cmd HEAD
5207         }
5208     } else {
5209         set cmd [concat | git diff-tree -r $flags $ids]
5210     }
5211     return $cmd
5214 proc gettreediffs {ids} {
5215     global treediff treepending
5217     set treepending $ids
5218     set treediff {}
5219     if {[catch {set gdtf [open [diffcmd $ids {--no-commit-id}] r]}]} return
5220     fconfigure $gdtf -blocking 0
5221     filerun $gdtf [list gettreediffline $gdtf $ids]
5224 proc gettreediffline {gdtf ids} {
5225     global treediff treediffs treepending diffids diffmergeid
5226     global cmitmode
5228     set nr 0
5229     while {[incr nr] <= 1000 && [gets $gdtf line] >= 0} {
5230         set i [string first "\t" $line]
5231         if {$i >= 0} {
5232             set file [string range $line [expr {$i+1}] end]
5233             if {[string index $file 0] eq "\""} {
5234                 set file [lindex $file 0]
5235             }
5236             lappend treediff $file
5237         }
5238     }
5239     if {![eof $gdtf]} {
5240         return [expr {$nr >= 1000? 2: 1}]
5241     }
5242     close $gdtf
5243     set treediffs($ids) $treediff
5244     unset treepending
5245     if {$cmitmode eq "tree"} {
5246         gettree $diffids
5247     } elseif {$ids != $diffids} {
5248         if {![info exists diffmergeid]} {
5249             gettreediffs $diffids
5250         }
5251     } else {
5252         addtocflist $ids
5253     }
5254     return 0
5257 # empty string or positive integer
5258 proc diffcontextvalidate {v} {
5259     return [regexp {^(|[1-9][0-9]*)$} $v]
5262 proc diffcontextchange {n1 n2 op} {
5263     global diffcontextstring diffcontext
5265     if {[string is integer -strict $diffcontextstring]} {
5266         if {$diffcontextstring > 0} {
5267             set diffcontext $diffcontextstring
5268             reselectline
5269         }
5270     }
5273 proc getblobdiffs {ids} {
5274     global blobdifffd diffids env
5275     global diffinhdr treediffs
5276     global diffcontext
5277     global limitdiffs viewfiles curview
5279     set cmd [diffcmd $ids "-p -C --no-commit-id -U$diffcontext"]
5280     if {$limitdiffs && $viewfiles($curview) ne {}} {
5281         set cmd [concat $cmd -- $viewfiles($curview)]
5282     }
5283     if {[catch {set bdf [open $cmd r]} err]} {
5284         puts "error getting diffs: $err"
5285         return
5286     }
5287     set diffinhdr 0
5288     fconfigure $bdf -blocking 0
5289     set blobdifffd($ids) $bdf
5290     filerun $bdf [list getblobdiffline $bdf $diffids]
5293 proc setinlist {var i val} {
5294     global $var
5296     while {[llength [set $var]] < $i} {
5297         lappend $var {}
5298     }
5299     if {[llength [set $var]] == $i} {
5300         lappend $var $val
5301     } else {
5302         lset $var $i $val
5303     }
5306 proc makediffhdr {fname ids} {
5307     global ctext curdiffstart treediffs
5309     set i [lsearch -exact $treediffs($ids) $fname]
5310     if {$i >= 0} {
5311         setinlist difffilestart $i $curdiffstart
5312     }
5313     set l [expr {(78 - [string length $fname]) / 2}]
5314     set pad [string range "----------------------------------------" 1 $l]
5315     $ctext insert $curdiffstart "$pad $fname $pad" filesep
5318 proc getblobdiffline {bdf ids} {
5319     global diffids blobdifffd ctext curdiffstart
5320     global diffnexthead diffnextnote difffilestart
5321     global diffinhdr treediffs
5323     set nr 0
5324     $ctext conf -state normal
5325     while {[incr nr] <= 1000 && [gets $bdf line] >= 0} {
5326         if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
5327             close $bdf
5328             return 0
5329         }
5330         if {![string compare -length 11 "diff --git " $line]} {
5331             # trim off "diff --git "
5332             set line [string range $line 11 end]
5333             set diffinhdr 1
5334             # start of a new file
5335             $ctext insert end "\n"
5336             set curdiffstart [$ctext index "end - 1c"]
5337             $ctext insert end "\n" filesep
5338             # If the name hasn't changed the length will be odd,
5339             # the middle char will be a space, and the two bits either
5340             # side will be a/name and b/name, or "a/name" and "b/name".
5341             # If the name has changed we'll get "rename from" and
5342             # "rename to" or "copy from" and "copy to" lines following this,
5343             # and we'll use them to get the filenames.
5344             # This complexity is necessary because spaces in the filename(s)
5345             # don't get escaped.
5346             set l [string length $line]
5347             set i [expr {$l / 2}]
5348             if {!(($l & 1) && [string index $line $i] eq " " &&
5349                   [string range $line 2 [expr {$i - 1}]] eq \
5350                       [string range $line [expr {$i + 3}] end])} {
5351                 continue
5352             }
5353             # unescape if quoted and chop off the a/ from the front
5354             if {[string index $line 0] eq "\""} {
5355                 set fname [string range [lindex $line 0] 2 end]
5356             } else {
5357                 set fname [string range $line 2 [expr {$i - 1}]]
5358             }
5359             makediffhdr $fname $ids
5361         } elseif {[regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@(.*)} \
5362                        $line match f1l f1c f2l f2c rest]} {
5363             $ctext insert end "$line\n" hunksep
5364             set diffinhdr 0
5366         } elseif {$diffinhdr} {
5367             if {![string compare -length 12 "rename from " $line]} {
5368                 set fname [string range $line [expr 6 + [string first " from " $line] ] end]
5369                 if {[string index $fname 0] eq "\""} {
5370                     set fname [lindex $fname 0]
5371                 }
5372                 set i [lsearch -exact $treediffs($ids) $fname]
5373                 if {$i >= 0} {
5374                     setinlist difffilestart $i $curdiffstart
5375                 }
5376             } elseif {![string compare -length 10 $line "rename to "] ||
5377                       ![string compare -length 8 $line "copy to "]} {
5378                 set fname [string range $line [expr 4 + [string first " to " $line] ] end]
5379                 if {[string index $fname 0] eq "\""} {
5380                     set fname [lindex $fname 0]
5381                 }
5382                 makediffhdr $fname $ids
5383             } elseif {[string compare -length 3 $line "---"] == 0} {
5384                 # do nothing
5385                 continue
5386             } elseif {[string compare -length 3 $line "+++"] == 0} {
5387                 set diffinhdr 0
5388                 continue
5389             }
5390             $ctext insert end "$line\n" filesep
5392         } else {
5393             set x [string range $line 0 0]
5394             if {$x == "-" || $x == "+"} {
5395                 set tag [expr {$x == "+"}]
5396                 $ctext insert end "$line\n" d$tag
5397             } elseif {$x == " "} {
5398                 $ctext insert end "$line\n"
5399             } else {
5400                 # "\ No newline at end of file",
5401                 # or something else we don't recognize
5402                 $ctext insert end "$line\n" hunksep
5403             }
5404         }
5405     }
5406     $ctext conf -state disabled
5407     if {[eof $bdf]} {
5408         close $bdf
5409         return 0
5410     }
5411     return [expr {$nr >= 1000? 2: 1}]
5414 proc changediffdisp {} {
5415     global ctext diffelide
5417     $ctext tag conf d0 -elide [lindex $diffelide 0]
5418     $ctext tag conf d1 -elide [lindex $diffelide 1]
5421 proc prevfile {} {
5422     global difffilestart ctext
5423     set prev [lindex $difffilestart 0]
5424     set here [$ctext index @0,0]
5425     foreach loc $difffilestart {
5426         if {[$ctext compare $loc >= $here]} {
5427             $ctext yview $prev
5428             return
5429         }
5430         set prev $loc
5431     }
5432     $ctext yview $prev
5435 proc nextfile {} {
5436     global difffilestart ctext
5437     set here [$ctext index @0,0]
5438     foreach loc $difffilestart {
5439         if {[$ctext compare $loc > $here]} {
5440             $ctext yview $loc
5441             return
5442         }
5443     }
5446 proc clear_ctext {{first 1.0}} {
5447     global ctext smarktop smarkbot
5448     global pendinglinks
5450     set l [lindex [split $first .] 0]
5451     if {![info exists smarktop] || [$ctext compare $first < $smarktop.0]} {
5452         set smarktop $l
5453     }
5454     if {![info exists smarkbot] || [$ctext compare $first < $smarkbot.0]} {
5455         set smarkbot $l
5456     }
5457     $ctext delete $first end
5458     if {$first eq "1.0"} {
5459         catch {unset pendinglinks}
5460     }
5463 proc settabs {{firstab {}}} {
5464     global firsttabstop tabstop ctext have_tk85
5466     if {$firstab ne {} && $have_tk85} {
5467         set firsttabstop $firstab
5468     }
5469     set w [font measure textfont "0"]
5470     if {$firsttabstop != 0} {
5471         $ctext conf -tabs [list [expr {($firsttabstop + $tabstop) * $w}] \
5472                                [expr {($firsttabstop + 2 * $tabstop) * $w}]]
5473     } elseif {$have_tk85 || $tabstop != 8} {
5474         $ctext conf -tabs [expr {$tabstop * $w}]
5475     } else {
5476         $ctext conf -tabs {}
5477     }
5480 proc incrsearch {name ix op} {
5481     global ctext searchstring searchdirn
5483     $ctext tag remove found 1.0 end
5484     if {[catch {$ctext index anchor}]} {
5485         # no anchor set, use start of selection, or of visible area
5486         set sel [$ctext tag ranges sel]
5487         if {$sel ne {}} {
5488             $ctext mark set anchor [lindex $sel 0]
5489         } elseif {$searchdirn eq "-forwards"} {
5490             $ctext mark set anchor @0,0
5491         } else {
5492             $ctext mark set anchor @0,[winfo height $ctext]
5493         }
5494     }
5495     if {$searchstring ne {}} {
5496         set here [$ctext search $searchdirn -- $searchstring anchor]
5497         if {$here ne {}} {
5498             $ctext see $here
5499         }
5500         searchmarkvisible 1
5501     }
5504 proc dosearch {} {
5505     global sstring ctext searchstring searchdirn
5507     focus $sstring
5508     $sstring icursor end
5509     set searchdirn -forwards
5510     if {$searchstring ne {}} {
5511         set sel [$ctext tag ranges sel]
5512         if {$sel ne {}} {
5513             set start "[lindex $sel 0] + 1c"
5514         } elseif {[catch {set start [$ctext index anchor]}]} {
5515             set start "@0,0"
5516         }
5517         set match [$ctext search -count mlen -- $searchstring $start]
5518         $ctext tag remove sel 1.0 end
5519         if {$match eq {}} {
5520             bell
5521             return
5522         }
5523         $ctext see $match
5524         set mend "$match + $mlen c"
5525         $ctext tag add sel $match $mend
5526         $ctext mark unset anchor
5527     }
5530 proc dosearchback {} {
5531     global sstring ctext searchstring searchdirn
5533     focus $sstring
5534     $sstring icursor end
5535     set searchdirn -backwards
5536     if {$searchstring ne {}} {
5537         set sel [$ctext tag ranges sel]
5538         if {$sel ne {}} {
5539             set start [lindex $sel 0]
5540         } elseif {[catch {set start [$ctext index anchor]}]} {
5541             set start @0,[winfo height $ctext]
5542         }
5543         set match [$ctext search -backwards -count ml -- $searchstring $start]
5544         $ctext tag remove sel 1.0 end
5545         if {$match eq {}} {
5546             bell
5547             return
5548         }
5549         $ctext see $match
5550         set mend "$match + $ml c"
5551         $ctext tag add sel $match $mend
5552         $ctext mark unset anchor
5553     }
5556 proc searchmark {first last} {
5557     global ctext searchstring
5559     set mend $first.0
5560     while {1} {
5561         set match [$ctext search -count mlen -- $searchstring $mend $last.end]
5562         if {$match eq {}} break
5563         set mend "$match + $mlen c"
5564         $ctext tag add found $match $mend
5565     }
5568 proc searchmarkvisible {doall} {
5569     global ctext smarktop smarkbot
5571     set topline [lindex [split [$ctext index @0,0] .] 0]
5572     set botline [lindex [split [$ctext index @0,[winfo height $ctext]] .] 0]
5573     if {$doall || $botline < $smarktop || $topline > $smarkbot} {
5574         # no overlap with previous
5575         searchmark $topline $botline
5576         set smarktop $topline
5577         set smarkbot $botline
5578     } else {
5579         if {$topline < $smarktop} {
5580             searchmark $topline [expr {$smarktop-1}]
5581             set smarktop $topline
5582         }
5583         if {$botline > $smarkbot} {
5584             searchmark [expr {$smarkbot+1}] $botline
5585             set smarkbot $botline
5586         }
5587     }
5590 proc scrolltext {f0 f1} {
5591     global searchstring
5593     .bleft.sb set $f0 $f1
5594     if {$searchstring ne {}} {
5595         searchmarkvisible 0
5596     }
5599 proc setcoords {} {
5600     global linespc charspc canvx0 canvy0
5601     global xspc1 xspc2 lthickness
5603     set linespc [font metrics mainfont -linespace]
5604     set charspc [font measure mainfont "m"]
5605     set canvy0 [expr {int(3 + 0.5 * $linespc)}]
5606     set canvx0 [expr {int(3 + 0.5 * $linespc)}]
5607     set lthickness [expr {int($linespc / 9) + 1}]
5608     set xspc1(0) $linespc
5609     set xspc2 $linespc
5612 proc redisplay {} {
5613     global canv
5614     global selectedline
5616     set ymax [lindex [$canv cget -scrollregion] 3]
5617     if {$ymax eq {} || $ymax == 0} return
5618     set span [$canv yview]
5619     clear_display
5620     setcanvscroll
5621     allcanvs yview moveto [lindex $span 0]
5622     drawvisible
5623     if {[info exists selectedline]} {
5624         selectline $selectedline 0
5625         allcanvs yview moveto [lindex $span 0]
5626     }
5629 proc parsefont {f n} {
5630     global fontattr
5632     set fontattr($f,family) [lindex $n 0]
5633     set s [lindex $n 1]
5634     if {$s eq {} || $s == 0} {
5635         set s 10
5636     } elseif {$s < 0} {
5637         set s [expr {int(-$s / [winfo fpixels . 1p] + 0.5)}]
5638     }
5639     set fontattr($f,size) $s
5640     set fontattr($f,weight) normal
5641     set fontattr($f,slant) roman
5642     foreach style [lrange $n 2 end] {
5643         switch -- $style {
5644             "normal" -
5645             "bold"   {set fontattr($f,weight) $style}
5646             "roman" -
5647             "italic" {set fontattr($f,slant) $style}
5648         }
5649     }
5652 proc fontflags {f {isbold 0}} {
5653     global fontattr
5655     return [list -family $fontattr($f,family) -size $fontattr($f,size) \
5656                 -weight [expr {$isbold? "bold": $fontattr($f,weight)}] \
5657                 -slant $fontattr($f,slant)]
5660 proc fontname {f} {
5661     global fontattr
5663     set n [list $fontattr($f,family) $fontattr($f,size)]
5664     if {$fontattr($f,weight) eq "bold"} {
5665         lappend n "bold"
5666     }
5667     if {$fontattr($f,slant) eq "italic"} {
5668         lappend n "italic"
5669     }
5670     return $n
5673 proc incrfont {inc} {
5674     global mainfont textfont ctext canv phase cflist showrefstop
5675     global stopped entries fontattr
5677     unmarkmatches
5678     set s $fontattr(mainfont,size)
5679     incr s $inc
5680     if {$s < 1} {
5681         set s 1
5682     }
5683     set fontattr(mainfont,size) $s
5684     font config mainfont -size $s
5685     font config mainfontbold -size $s
5686     set mainfont [fontname mainfont]
5687     set s $fontattr(textfont,size)
5688     incr s $inc
5689     if {$s < 1} {
5690         set s 1
5691     }
5692     set fontattr(textfont,size) $s
5693     font config textfont -size $s
5694     font config textfontbold -size $s
5695     set textfont [fontname textfont]
5696     setcoords
5697     settabs
5698     redisplay
5701 proc clearsha1 {} {
5702     global sha1entry sha1string
5703     if {[string length $sha1string] == 40} {
5704         $sha1entry delete 0 end
5705     }
5708 proc sha1change {n1 n2 op} {
5709     global sha1string currentid sha1but
5710     if {$sha1string == {}
5711         || ([info exists currentid] && $sha1string == $currentid)} {
5712         set state disabled
5713     } else {
5714         set state normal
5715     }
5716     if {[$sha1but cget -state] == $state} return
5717     if {$state == "normal"} {
5718         $sha1but conf -state normal -relief raised -text "Goto: "
5719     } else {
5720         $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
5721     }
5724 proc gotocommit {} {
5725     global sha1string currentid commitrow tagids headids
5726     global displayorder numcommits curview
5728     if {$sha1string == {}
5729         || ([info exists currentid] && $sha1string == $currentid)} return
5730     if {[info exists tagids($sha1string)]} {
5731         set id $tagids($sha1string)
5732     } elseif {[info exists headids($sha1string)]} {
5733         set id $headids($sha1string)
5734     } else {
5735         set id [string tolower $sha1string]
5736         if {[regexp {^[0-9a-f]{4,39}$} $id]} {
5737             set matches {}
5738             foreach i $displayorder {
5739                 if {[string match $id* $i]} {
5740                     lappend matches $i
5741                 }
5742             }
5743             if {$matches ne {}} {
5744                 if {[llength $matches] > 1} {
5745                     error_popup "Short SHA1 id $id is ambiguous"
5746                     return
5747                 }
5748                 set id [lindex $matches 0]
5749             }
5750         }
5751     }
5752     if {[info exists commitrow($curview,$id)]} {
5753         selectline $commitrow($curview,$id) 1
5754         return
5755     }
5756     if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
5757         set type "SHA1 id"
5758     } else {
5759         set type "Tag/Head"
5760     }
5761     error_popup "$type $sha1string is not known"
5764 proc lineenter {x y id} {
5765     global hoverx hovery hoverid hovertimer
5766     global commitinfo canv
5768     if {![info exists commitinfo($id)] && ![getcommit $id]} return
5769     set hoverx $x
5770     set hovery $y
5771     set hoverid $id
5772     if {[info exists hovertimer]} {
5773         after cancel $hovertimer
5774     }
5775     set hovertimer [after 500 linehover]
5776     $canv delete hover
5779 proc linemotion {x y id} {
5780     global hoverx hovery hoverid hovertimer
5782     if {[info exists hoverid] && $id == $hoverid} {
5783         set hoverx $x
5784         set hovery $y
5785         if {[info exists hovertimer]} {
5786             after cancel $hovertimer
5787         }
5788         set hovertimer [after 500 linehover]
5789     }
5792 proc lineleave {id} {
5793     global hoverid hovertimer canv
5795     if {[info exists hoverid] && $id == $hoverid} {
5796         $canv delete hover
5797         if {[info exists hovertimer]} {
5798             after cancel $hovertimer
5799             unset hovertimer
5800         }
5801         unset hoverid
5802     }
5805 proc linehover {} {
5806     global hoverx hovery hoverid hovertimer
5807     global canv linespc lthickness
5808     global commitinfo
5810     set text [lindex $commitinfo($hoverid) 0]
5811     set ymax [lindex [$canv cget -scrollregion] 3]
5812     if {$ymax == {}} return
5813     set yfrac [lindex [$canv yview] 0]
5814     set x [expr {$hoverx + 2 * $linespc}]
5815     set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
5816     set x0 [expr {$x - 2 * $lthickness}]
5817     set y0 [expr {$y - 2 * $lthickness}]
5818     set x1 [expr {$x + [font measure mainfont $text] + 2 * $lthickness}]
5819     set y1 [expr {$y + $linespc + 2 * $lthickness}]
5820     set t [$canv create rectangle $x0 $y0 $x1 $y1 \
5821                -fill \#ffff80 -outline black -width 1 -tags hover]
5822     $canv raise $t
5823     set t [$canv create text $x $y -anchor nw -text $text -tags hover \
5824                -font mainfont]
5825     $canv raise $t
5828 proc clickisonarrow {id y} {
5829     global lthickness
5831     set ranges [rowranges $id]
5832     set thresh [expr {2 * $lthickness + 6}]
5833     set n [expr {[llength $ranges] - 1}]
5834     for {set i 1} {$i < $n} {incr i} {
5835         set row [lindex $ranges $i]
5836         if {abs([yc $row] - $y) < $thresh} {
5837             return $i
5838         }
5839     }
5840     return {}
5843 proc arrowjump {id n y} {
5844     global canv
5846     # 1 <-> 2, 3 <-> 4, etc...
5847     set n [expr {(($n - 1) ^ 1) + 1}]
5848     set row [lindex [rowranges $id] $n]
5849     set yt [yc $row]
5850     set ymax [lindex [$canv cget -scrollregion] 3]
5851     if {$ymax eq {} || $ymax <= 0} return
5852     set view [$canv yview]
5853     set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
5854     set yfrac [expr {$yt / $ymax - $yspan / 2}]
5855     if {$yfrac < 0} {
5856         set yfrac 0
5857     }
5858     allcanvs yview moveto $yfrac
5861 proc lineclick {x y id isnew} {
5862     global ctext commitinfo children canv thickerline curview commitrow
5864     if {![info exists commitinfo($id)] && ![getcommit $id]} return
5865     unmarkmatches
5866     unselectline
5867     normalline
5868     $canv delete hover
5869     # draw this line thicker than normal
5870     set thickerline $id
5871     drawlines $id
5872     if {$isnew} {
5873         set ymax [lindex [$canv cget -scrollregion] 3]
5874         if {$ymax eq {}} return
5875         set yfrac [lindex [$canv yview] 0]
5876         set y [expr {$y + $yfrac * $ymax}]
5877     }
5878     set dirn [clickisonarrow $id $y]
5879     if {$dirn ne {}} {
5880         arrowjump $id $dirn $y
5881         return
5882     }
5884     if {$isnew} {
5885         addtohistory [list lineclick $x $y $id 0]
5886     }
5887     # fill the details pane with info about this line
5888     $ctext conf -state normal
5889     clear_ctext
5890     settabs 0
5891     $ctext insert end "Parent:\t"
5892     $ctext insert end $id link0
5893     setlink $id link0
5894     set info $commitinfo($id)
5895     $ctext insert end "\n\t[lindex $info 0]\n"
5896     $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
5897     set date [formatdate [lindex $info 2]]
5898     $ctext insert end "\tDate:\t$date\n"
5899     set kids $children($curview,$id)
5900     if {$kids ne {}} {
5901         $ctext insert end "\nChildren:"
5902         set i 0
5903         foreach child $kids {
5904             incr i
5905             if {![info exists commitinfo($child)] && ![getcommit $child]} continue
5906             set info $commitinfo($child)
5907             $ctext insert end "\n\t"
5908             $ctext insert end $child link$i
5909             setlink $child link$i
5910             $ctext insert end "\n\t[lindex $info 0]"
5911             $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
5912             set date [formatdate [lindex $info 2]]
5913             $ctext insert end "\n\tDate:\t$date\n"
5914         }
5915     }
5916     $ctext conf -state disabled
5917     init_flist {}
5920 proc normalline {} {
5921     global thickerline
5922     if {[info exists thickerline]} {
5923         set id $thickerline
5924         unset thickerline
5925         drawlines $id
5926     }
5929 proc selbyid {id} {
5930     global commitrow curview
5931     if {[info exists commitrow($curview,$id)]} {
5932         selectline $commitrow($curview,$id) 1
5933     }
5936 proc mstime {} {
5937     global startmstime
5938     if {![info exists startmstime]} {
5939         set startmstime [clock clicks -milliseconds]
5940     }
5941     return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
5944 proc rowmenu {x y id} {
5945     global rowctxmenu commitrow selectedline rowmenuid curview
5946     global nullid nullid2 fakerowmenu mainhead
5948     stopfinding
5949     set rowmenuid $id
5950     if {![info exists selectedline]
5951         || $commitrow($curview,$id) eq $selectedline} {
5952         set state disabled
5953     } else {
5954         set state normal
5955     }
5956     if {$id ne $nullid && $id ne $nullid2} {
5957         set menu $rowctxmenu
5958         $menu entryconfigure 7 -label "Reset $mainhead branch to here"
5959     } else {
5960         set menu $fakerowmenu
5961     }
5962     $menu entryconfigure "Diff this*" -state $state
5963     $menu entryconfigure "Diff selected*" -state $state
5964     $menu entryconfigure "Make patch" -state $state
5965     tk_popup $menu $x $y
5968 proc diffvssel {dirn} {
5969     global rowmenuid selectedline displayorder
5971     if {![info exists selectedline]} return
5972     if {$dirn} {
5973         set oldid [lindex $displayorder $selectedline]
5974         set newid $rowmenuid
5975     } else {
5976         set oldid $rowmenuid
5977         set newid [lindex $displayorder $selectedline]
5978     }
5979     addtohistory [list doseldiff $oldid $newid]
5980     doseldiff $oldid $newid
5983 proc doseldiff {oldid newid} {
5984     global ctext
5985     global commitinfo
5987     $ctext conf -state normal
5988     clear_ctext
5989     init_flist "Top"
5990     $ctext insert end "From "
5991     $ctext insert end $oldid link0
5992     setlink $oldid link0
5993     $ctext insert end "\n     "
5994     $ctext insert end [lindex $commitinfo($oldid) 0]
5995     $ctext insert end "\n\nTo   "
5996     $ctext insert end $newid link1
5997     setlink $newid link1
5998     $ctext insert end "\n     "
5999     $ctext insert end [lindex $commitinfo($newid) 0]
6000     $ctext insert end "\n"
6001     $ctext conf -state disabled
6002     $ctext tag remove found 1.0 end
6003     startdiff [list $oldid $newid]
6006 proc mkpatch {} {
6007     global rowmenuid currentid commitinfo patchtop patchnum
6009     if {![info exists currentid]} return
6010     set oldid $currentid
6011     set oldhead [lindex $commitinfo($oldid) 0]
6012     set newid $rowmenuid
6013     set newhead [lindex $commitinfo($newid) 0]
6014     set top .patch
6015     set patchtop $top
6016     catch {destroy $top}
6017     toplevel $top
6018     label $top.title -text "Generate patch"
6019     grid $top.title - -pady 10
6020     label $top.from -text "From:"
6021     entry $top.fromsha1 -width 40 -relief flat
6022     $top.fromsha1 insert 0 $oldid
6023     $top.fromsha1 conf -state readonly
6024     grid $top.from $top.fromsha1 -sticky w
6025     entry $top.fromhead -width 60 -relief flat
6026     $top.fromhead insert 0 $oldhead
6027     $top.fromhead conf -state readonly
6028     grid x $top.fromhead -sticky w
6029     label $top.to -text "To:"
6030     entry $top.tosha1 -width 40 -relief flat
6031     $top.tosha1 insert 0 $newid
6032     $top.tosha1 conf -state readonly
6033     grid $top.to $top.tosha1 -sticky w
6034     entry $top.tohead -width 60 -relief flat
6035     $top.tohead insert 0 $newhead
6036     $top.tohead conf -state readonly
6037     grid x $top.tohead -sticky w
6038     button $top.rev -text "Reverse" -command mkpatchrev -padx 5
6039     grid $top.rev x -pady 10
6040     label $top.flab -text "Output file:"
6041     entry $top.fname -width 60
6042     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6043     incr patchnum
6044     grid $top.flab $top.fname -sticky w
6045     frame $top.buts
6046     button $top.buts.gen -text "Generate" -command mkpatchgo
6047     button $top.buts.can -text "Cancel" -command mkpatchcan
6048     grid $top.buts.gen $top.buts.can
6049     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6050     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6051     grid $top.buts - -pady 10 -sticky ew
6052     focus $top.fname
6055 proc mkpatchrev {} {
6056     global patchtop
6058     set oldid [$patchtop.fromsha1 get]
6059     set oldhead [$patchtop.fromhead get]
6060     set newid [$patchtop.tosha1 get]
6061     set newhead [$patchtop.tohead get]
6062     foreach e [list fromsha1 fromhead tosha1 tohead] \
6063             v [list $newid $newhead $oldid $oldhead] {
6064         $patchtop.$e conf -state normal
6065         $patchtop.$e delete 0 end
6066         $patchtop.$e insert 0 $v
6067         $patchtop.$e conf -state readonly
6068     }
6071 proc mkpatchgo {} {
6072     global patchtop nullid nullid2
6074     set oldid [$patchtop.fromsha1 get]
6075     set newid [$patchtop.tosha1 get]
6076     set fname [$patchtop.fname get]
6077     set cmd [diffcmd [list $oldid $newid] -p]
6078     # trim off the initial "|"
6079     set cmd [lrange $cmd 1 end]
6080     lappend cmd >$fname &
6081     if {[catch {eval exec $cmd} err]} {
6082         error_popup "Error creating patch: $err"
6083     }
6084     catch {destroy $patchtop}
6085     unset patchtop
6088 proc mkpatchcan {} {
6089     global patchtop
6091     catch {destroy $patchtop}
6092     unset patchtop
6095 proc mktag {} {
6096     global rowmenuid mktagtop commitinfo
6098     set top .maketag
6099     set mktagtop $top
6100     catch {destroy $top}
6101     toplevel $top
6102     label $top.title -text "Create tag"
6103     grid $top.title - -pady 10
6104     label $top.id -text "ID:"
6105     entry $top.sha1 -width 40 -relief flat
6106     $top.sha1 insert 0 $rowmenuid
6107     $top.sha1 conf -state readonly
6108     grid $top.id $top.sha1 -sticky w
6109     entry $top.head -width 60 -relief flat
6110     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6111     $top.head conf -state readonly
6112     grid x $top.head -sticky w
6113     label $top.tlab -text "Tag name:"
6114     entry $top.tag -width 60
6115     grid $top.tlab $top.tag -sticky w
6116     frame $top.buts
6117     button $top.buts.gen -text "Create" -command mktaggo
6118     button $top.buts.can -text "Cancel" -command mktagcan
6119     grid $top.buts.gen $top.buts.can
6120     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6121     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6122     grid $top.buts - -pady 10 -sticky ew
6123     focus $top.tag
6126 proc domktag {} {
6127     global mktagtop env tagids idtags
6129     set id [$mktagtop.sha1 get]
6130     set tag [$mktagtop.tag get]
6131     if {$tag == {}} {
6132         error_popup "No tag name specified"
6133         return
6134     }
6135     if {[info exists tagids($tag)]} {
6136         error_popup "Tag \"$tag\" already exists"
6137         return
6138     }
6139     if {[catch {
6140         set dir [gitdir]
6141         set fname [file join $dir "refs/tags" $tag]
6142         set f [open $fname w]
6143         puts $f $id
6144         close $f
6145     } err]} {
6146         error_popup "Error creating tag: $err"
6147         return
6148     }
6150     set tagids($tag) $id
6151     lappend idtags($id) $tag
6152     redrawtags $id
6153     addedtag $id
6154     dispneartags 0
6155     run refill_reflist
6158 proc redrawtags {id} {
6159     global canv linehtag commitrow idpos selectedline curview
6160     global canvxmax iddrawn
6162     if {![info exists commitrow($curview,$id)]} return
6163     if {![info exists iddrawn($id)]} return
6164     drawcommits $commitrow($curview,$id)
6165     $canv delete tag.$id
6166     set xt [eval drawtags $id $idpos($id)]
6167     $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6168     set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6169     set xr [expr {$xt + [font measure mainfont $text]}]
6170     if {$xr > $canvxmax} {
6171         set canvxmax $xr
6172         setcanvscroll
6173     }
6174     if {[info exists selectedline]
6175         && $selectedline == $commitrow($curview,$id)} {
6176         selectline $selectedline 0
6177     }
6180 proc mktagcan {} {
6181     global mktagtop
6183     catch {destroy $mktagtop}
6184     unset mktagtop
6187 proc mktaggo {} {
6188     domktag
6189     mktagcan
6192 proc writecommit {} {
6193     global rowmenuid wrcomtop commitinfo wrcomcmd
6195     set top .writecommit
6196     set wrcomtop $top
6197     catch {destroy $top}
6198     toplevel $top
6199     label $top.title -text "Write commit to file"
6200     grid $top.title - -pady 10
6201     label $top.id -text "ID:"
6202     entry $top.sha1 -width 40 -relief flat
6203     $top.sha1 insert 0 $rowmenuid
6204     $top.sha1 conf -state readonly
6205     grid $top.id $top.sha1 -sticky w
6206     entry $top.head -width 60 -relief flat
6207     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6208     $top.head conf -state readonly
6209     grid x $top.head -sticky w
6210     label $top.clab -text "Command:"
6211     entry $top.cmd -width 60 -textvariable wrcomcmd
6212     grid $top.clab $top.cmd -sticky w -pady 10
6213     label $top.flab -text "Output file:"
6214     entry $top.fname -width 60
6215     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6216     grid $top.flab $top.fname -sticky w
6217     frame $top.buts
6218     button $top.buts.gen -text "Write" -command wrcomgo
6219     button $top.buts.can -text "Cancel" -command wrcomcan
6220     grid $top.buts.gen $top.buts.can
6221     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6222     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6223     grid $top.buts - -pady 10 -sticky ew
6224     focus $top.fname
6227 proc wrcomgo {} {
6228     global wrcomtop
6230     set id [$wrcomtop.sha1 get]
6231     set cmd "echo $id | [$wrcomtop.cmd get]"
6232     set fname [$wrcomtop.fname get]
6233     if {[catch {exec sh -c $cmd >$fname &} err]} {
6234         error_popup "Error writing commit: $err"
6235     }
6236     catch {destroy $wrcomtop}
6237     unset wrcomtop
6240 proc wrcomcan {} {
6241     global wrcomtop
6243     catch {destroy $wrcomtop}
6244     unset wrcomtop
6247 proc mkbranch {} {
6248     global rowmenuid mkbrtop
6250     set top .makebranch
6251     catch {destroy $top}
6252     toplevel $top
6253     label $top.title -text "Create new branch"
6254     grid $top.title - -pady 10
6255     label $top.id -text "ID:"
6256     entry $top.sha1 -width 40 -relief flat
6257     $top.sha1 insert 0 $rowmenuid
6258     $top.sha1 conf -state readonly
6259     grid $top.id $top.sha1 -sticky w
6260     label $top.nlab -text "Name:"
6261     entry $top.name -width 40
6262     grid $top.nlab $top.name -sticky w
6263     frame $top.buts
6264     button $top.buts.go -text "Create" -command [list mkbrgo $top]
6265     button $top.buts.can -text "Cancel" -command "catch {destroy $top}"
6266     grid $top.buts.go $top.buts.can
6267     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6268     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6269     grid $top.buts - -pady 10 -sticky ew
6270     focus $top.name
6273 proc mkbrgo {top} {
6274     global headids idheads
6276     set name [$top.name get]
6277     set id [$top.sha1 get]
6278     if {$name eq {}} {
6279         error_popup "Please specify a name for the new branch"
6280         return
6281     }
6282     catch {destroy $top}
6283     nowbusy newbranch
6284     update
6285     if {[catch {
6286         exec git branch $name $id
6287     } err]} {
6288         notbusy newbranch
6289         error_popup $err
6290     } else {
6291         set headids($name) $id
6292         lappend idheads($id) $name
6293         addedhead $id $name
6294         notbusy newbranch
6295         redrawtags $id
6296         dispneartags 0
6297         run refill_reflist
6298     }
6301 proc cherrypick {} {
6302     global rowmenuid curview commitrow
6303     global mainhead
6305     set oldhead [exec git rev-parse HEAD]
6306     set dheads [descheads $rowmenuid]
6307     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6308         set ok [confirm_popup "Commit [string range $rowmenuid 0 7] is already\
6309                         included in branch $mainhead -- really re-apply it?"]
6310         if {!$ok} return
6311     }
6312     nowbusy cherrypick "Cherry-picking"
6313     update
6314     # Unfortunately git-cherry-pick writes stuff to stderr even when
6315     # no error occurs, and exec takes that as an indication of error...
6316     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6317         notbusy cherrypick
6318         error_popup $err
6319         return
6320     }
6321     set newhead [exec git rev-parse HEAD]
6322     if {$newhead eq $oldhead} {
6323         notbusy cherrypick
6324         error_popup "No changes committed"
6325         return
6326     }
6327     addnewchild $newhead $oldhead
6328     if {[info exists commitrow($curview,$oldhead)]} {
6329         insertrow $commitrow($curview,$oldhead) $newhead
6330         if {$mainhead ne {}} {
6331             movehead $newhead $mainhead
6332             movedhead $newhead $mainhead
6333         }
6334         redrawtags $oldhead
6335         redrawtags $newhead
6336     }
6337     notbusy cherrypick
6340 proc resethead {} {
6341     global mainheadid mainhead rowmenuid confirm_ok resettype
6343     set confirm_ok 0
6344     set w ".confirmreset"
6345     toplevel $w
6346     wm transient $w .
6347     wm title $w "Confirm reset"
6348     message $w.m -text \
6349         "Reset branch $mainhead to [string range $rowmenuid 0 7]?" \
6350         -justify center -aspect 1000
6351     pack $w.m -side top -fill x -padx 20 -pady 20
6352     frame $w.f -relief sunken -border 2
6353     message $w.f.rt -text "Reset type:" -aspect 1000
6354     grid $w.f.rt -sticky w
6355     set resettype mixed
6356     radiobutton $w.f.soft -value soft -variable resettype -justify left \
6357         -text "Soft: Leave working tree and index untouched"
6358     grid $w.f.soft -sticky w
6359     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6360         -text "Mixed: Leave working tree untouched, reset index"
6361     grid $w.f.mixed -sticky w
6362     radiobutton $w.f.hard -value hard -variable resettype -justify left \
6363         -text "Hard: Reset working tree and index\n(discard ALL local changes)"
6364     grid $w.f.hard -sticky w
6365     pack $w.f -side top -fill x
6366     button $w.ok -text OK -command "set confirm_ok 1; destroy $w"
6367     pack $w.ok -side left -fill x -padx 20 -pady 20
6368     button $w.cancel -text Cancel -command "destroy $w"
6369     pack $w.cancel -side right -fill x -padx 20 -pady 20
6370     bind $w <Visibility> "grab $w; focus $w"
6371     tkwait window $w
6372     if {!$confirm_ok} return
6373     if {[catch {set fd [open \
6374             [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6375         error_popup $err
6376     } else {
6377         dohidelocalchanges
6378         filerun $fd [list readresetstat $fd]
6379         nowbusy reset "Resetting"
6380     }
6383 proc readresetstat {fd} {
6384     global mainhead mainheadid showlocalchanges rprogcoord
6386     if {[gets $fd line] >= 0} {
6387         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6388             set rprogcoord [expr {1.0 * $m / $n}]
6389             adjustprogress
6390         }
6391         return 1
6392     }
6393     set rprogcoord 0
6394     adjustprogress
6395     notbusy reset
6396     if {[catch {close $fd} err]} {
6397         error_popup $err
6398     }
6399     set oldhead $mainheadid
6400     set newhead [exec git rev-parse HEAD]
6401     if {$newhead ne $oldhead} {
6402         movehead $newhead $mainhead
6403         movedhead $newhead $mainhead
6404         set mainheadid $newhead
6405         redrawtags $oldhead
6406         redrawtags $newhead
6407     }
6408     if {$showlocalchanges} {
6409         doshowlocalchanges
6410     }
6411     return 0
6414 # context menu for a head
6415 proc headmenu {x y id head} {
6416     global headmenuid headmenuhead headctxmenu mainhead
6418     stopfinding
6419     set headmenuid $id
6420     set headmenuhead $head
6421     set state normal
6422     if {$head eq $mainhead} {
6423         set state disabled
6424     }
6425     $headctxmenu entryconfigure 0 -state $state
6426     $headctxmenu entryconfigure 1 -state $state
6427     tk_popup $headctxmenu $x $y
6430 proc cobranch {} {
6431     global headmenuid headmenuhead mainhead headids
6432     global showlocalchanges mainheadid
6434     # check the tree is clean first??
6435     set oldmainhead $mainhead
6436     nowbusy checkout "Checking out"
6437     update
6438     dohidelocalchanges
6439     if {[catch {
6440         exec git checkout -q $headmenuhead
6441     } err]} {
6442         notbusy checkout
6443         error_popup $err
6444     } else {
6445         notbusy checkout
6446         set mainhead $headmenuhead
6447         set mainheadid $headmenuid
6448         if {[info exists headids($oldmainhead)]} {
6449             redrawtags $headids($oldmainhead)
6450         }
6451         redrawtags $headmenuid
6452     }
6453     if {$showlocalchanges} {
6454         dodiffindex
6455     }
6458 proc rmbranch {} {
6459     global headmenuid headmenuhead mainhead
6460     global idheads
6462     set head $headmenuhead
6463     set id $headmenuid
6464     # this check shouldn't be needed any more...
6465     if {$head eq $mainhead} {
6466         error_popup "Cannot delete the currently checked-out branch"
6467         return
6468     }
6469     set dheads [descheads $id]
6470     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6471         # the stuff on this branch isn't on any other branch
6472         if {![confirm_popup "The commits on branch $head aren't on any other\
6473                         branch.\nReally delete branch $head?"]} return
6474     }
6475     nowbusy rmbranch
6476     update
6477     if {[catch {exec git branch -D $head} err]} {
6478         notbusy rmbranch
6479         error_popup $err
6480         return
6481     }
6482     removehead $id $head
6483     removedhead $id $head
6484     redrawtags $id
6485     notbusy rmbranch
6486     dispneartags 0
6487     run refill_reflist
6490 # Display a list of tags and heads
6491 proc showrefs {} {
6492     global showrefstop bgcolor fgcolor selectbgcolor
6493     global bglist fglist reflistfilter reflist maincursor
6495     set top .showrefs
6496     set showrefstop $top
6497     if {[winfo exists $top]} {
6498         raise $top
6499         refill_reflist
6500         return
6501     }
6502     toplevel $top
6503     wm title $top "Tags and heads: [file tail [pwd]]"
6504     text $top.list -background $bgcolor -foreground $fgcolor \
6505         -selectbackground $selectbgcolor -font mainfont \
6506         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6507         -width 30 -height 20 -cursor $maincursor \
6508         -spacing1 1 -spacing3 1 -state disabled
6509     $top.list tag configure highlight -background $selectbgcolor
6510     lappend bglist $top.list
6511     lappend fglist $top.list
6512     scrollbar $top.ysb -command "$top.list yview" -orient vertical
6513     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6514     grid $top.list $top.ysb -sticky nsew
6515     grid $top.xsb x -sticky ew
6516     frame $top.f
6517     label $top.f.l -text "Filter: " -font uifont
6518     entry $top.f.e -width 20 -textvariable reflistfilter -font uifont
6519     set reflistfilter "*"
6520     trace add variable reflistfilter write reflistfilter_change
6521     pack $top.f.e -side right -fill x -expand 1
6522     pack $top.f.l -side left
6523     grid $top.f - -sticky ew -pady 2
6524     button $top.close -command [list destroy $top] -text "Close" \
6525         -font uifont
6526     grid $top.close -
6527     grid columnconfigure $top 0 -weight 1
6528     grid rowconfigure $top 0 -weight 1
6529     bind $top.list <1> {break}
6530     bind $top.list <B1-Motion> {break}
6531     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6532     set reflist {}
6533     refill_reflist
6536 proc sel_reflist {w x y} {
6537     global showrefstop reflist headids tagids otherrefids
6539     if {![winfo exists $showrefstop]} return
6540     set l [lindex [split [$w index "@$x,$y"] "."] 0]
6541     set ref [lindex $reflist [expr {$l-1}]]
6542     set n [lindex $ref 0]
6543     switch -- [lindex $ref 1] {
6544         "H" {selbyid $headids($n)}
6545         "T" {selbyid $tagids($n)}
6546         "o" {selbyid $otherrefids($n)}
6547     }
6548     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6551 proc unsel_reflist {} {
6552     global showrefstop
6554     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6555     $showrefstop.list tag remove highlight 0.0 end
6558 proc reflistfilter_change {n1 n2 op} {
6559     global reflistfilter
6561     after cancel refill_reflist
6562     after 200 refill_reflist
6565 proc refill_reflist {} {
6566     global reflist reflistfilter showrefstop headids tagids otherrefids
6567     global commitrow curview commitinterest
6569     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6570     set refs {}
6571     foreach n [array names headids] {
6572         if {[string match $reflistfilter $n]} {
6573             if {[info exists commitrow($curview,$headids($n))]} {
6574                 lappend refs [list $n H]
6575             } else {
6576                 set commitinterest($headids($n)) {run refill_reflist}
6577             }
6578         }
6579     }
6580     foreach n [array names tagids] {
6581         if {[string match $reflistfilter $n]} {
6582             if {[info exists commitrow($curview,$tagids($n))]} {
6583                 lappend refs [list $n T]
6584             } else {
6585                 set commitinterest($tagids($n)) {run refill_reflist}
6586             }
6587         }
6588     }
6589     foreach n [array names otherrefids] {
6590         if {[string match $reflistfilter $n]} {
6591             if {[info exists commitrow($curview,$otherrefids($n))]} {
6592                 lappend refs [list $n o]
6593             } else {
6594                 set commitinterest($otherrefids($n)) {run refill_reflist}
6595             }
6596         }
6597     }
6598     set refs [lsort -index 0 $refs]
6599     if {$refs eq $reflist} return
6601     # Update the contents of $showrefstop.list according to the
6602     # differences between $reflist (old) and $refs (new)
6603     $showrefstop.list conf -state normal
6604     $showrefstop.list insert end "\n"
6605     set i 0
6606     set j 0
6607     while {$i < [llength $reflist] || $j < [llength $refs]} {
6608         if {$i < [llength $reflist]} {
6609             if {$j < [llength $refs]} {
6610                 set cmp [string compare [lindex $reflist $i 0] \
6611                              [lindex $refs $j 0]]
6612                 if {$cmp == 0} {
6613                     set cmp [string compare [lindex $reflist $i 1] \
6614                                  [lindex $refs $j 1]]
6615                 }
6616             } else {
6617                 set cmp -1
6618             }
6619         } else {
6620             set cmp 1
6621         }
6622         switch -- $cmp {
6623             -1 {
6624                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6625                 incr i
6626             }
6627             0 {
6628                 incr i
6629                 incr j
6630             }
6631             1 {
6632                 set l [expr {$j + 1}]
6633                 $showrefstop.list image create $l.0 -align baseline \
6634                     -image reficon-[lindex $refs $j 1] -padx 2
6635                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6636                 incr j
6637             }
6638         }
6639     }
6640     set reflist $refs
6641     # delete last newline
6642     $showrefstop.list delete end-2c end-1c
6643     $showrefstop.list conf -state disabled
6646 # Stuff for finding nearby tags
6647 proc getallcommits {} {
6648     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6649     global idheads idtags idotherrefs allparents tagobjid
6651     if {![info exists allcommits]} {
6652         set nextarc 0
6653         set allcommits 0
6654         set seeds {}
6655         set allcwait 0
6656         set cachedarcs 0
6657         set allccache [file join [gitdir] "gitk.cache"]
6658         if {![catch {
6659             set f [open $allccache r]
6660             set allcwait 1
6661             getcache $f
6662         }]} return
6663     }
6665     if {$allcwait} {
6666         return
6667     }
6668     set cmd [list | git rev-list --parents]
6669     set allcupdate [expr {$seeds ne {}}]
6670     if {!$allcupdate} {
6671         set ids "--all"
6672     } else {
6673         set refs [concat [array names idheads] [array names idtags] \
6674                       [array names idotherrefs]]
6675         set ids {}
6676         set tagobjs {}
6677         foreach name [array names tagobjid] {
6678             lappend tagobjs $tagobjid($name)
6679         }
6680         foreach id [lsort -unique $refs] {
6681             if {![info exists allparents($id)] &&
6682                 [lsearch -exact $tagobjs $id] < 0} {
6683                 lappend ids $id
6684             }
6685         }
6686         if {$ids ne {}} {
6687             foreach id $seeds {
6688                 lappend ids "^$id"
6689             }
6690         }
6691     }
6692     if {$ids ne {}} {
6693         set fd [open [concat $cmd $ids] r]
6694         fconfigure $fd -blocking 0
6695         incr allcommits
6696         nowbusy allcommits
6697         filerun $fd [list getallclines $fd]
6698     } else {
6699         dispneartags 0
6700     }
6703 # Since most commits have 1 parent and 1 child, we group strings of
6704 # such commits into "arcs" joining branch/merge points (BMPs), which
6705 # are commits that either don't have 1 parent or don't have 1 child.
6707 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6708 # arcout(id) - outgoing arcs for BMP
6709 # arcids(a) - list of IDs on arc including end but not start
6710 # arcstart(a) - BMP ID at start of arc
6711 # arcend(a) - BMP ID at end of arc
6712 # growing(a) - arc a is still growing
6713 # arctags(a) - IDs out of arcids (excluding end) that have tags
6714 # archeads(a) - IDs out of arcids (excluding end) that have heads
6715 # The start of an arc is at the descendent end, so "incoming" means
6716 # coming from descendents, and "outgoing" means going towards ancestors.
6718 proc getallclines {fd} {
6719     global allparents allchildren idtags idheads nextarc
6720     global arcnos arcids arctags arcout arcend arcstart archeads growing
6721     global seeds allcommits cachedarcs allcupdate
6722     
6723     set nid 0
6724     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6725         set id [lindex $line 0]
6726         if {[info exists allparents($id)]} {
6727             # seen it already
6728             continue
6729         }
6730         set cachedarcs 0
6731         set olds [lrange $line 1 end]
6732         set allparents($id) $olds
6733         if {![info exists allchildren($id)]} {
6734             set allchildren($id) {}
6735             set arcnos($id) {}
6736             lappend seeds $id
6737         } else {
6738             set a $arcnos($id)
6739             if {[llength $olds] == 1 && [llength $a] == 1} {
6740                 lappend arcids($a) $id
6741                 if {[info exists idtags($id)]} {
6742                     lappend arctags($a) $id
6743                 }
6744                 if {[info exists idheads($id)]} {
6745                     lappend archeads($a) $id
6746                 }
6747                 if {[info exists allparents($olds)]} {
6748                     # seen parent already
6749                     if {![info exists arcout($olds)]} {
6750                         splitarc $olds
6751                     }
6752                     lappend arcids($a) $olds
6753                     set arcend($a) $olds
6754                     unset growing($a)
6755                 }
6756                 lappend allchildren($olds) $id
6757                 lappend arcnos($olds) $a
6758                 continue
6759             }
6760         }
6761         foreach a $arcnos($id) {
6762             lappend arcids($a) $id
6763             set arcend($a) $id
6764             unset growing($a)
6765         }
6767         set ao {}
6768         foreach p $olds {
6769             lappend allchildren($p) $id
6770             set a [incr nextarc]
6771             set arcstart($a) $id
6772             set archeads($a) {}
6773             set arctags($a) {}
6774             set archeads($a) {}
6775             set arcids($a) {}
6776             lappend ao $a
6777             set growing($a) 1
6778             if {[info exists allparents($p)]} {
6779                 # seen it already, may need to make a new branch
6780                 if {![info exists arcout($p)]} {
6781                     splitarc $p
6782                 }
6783                 lappend arcids($a) $p
6784                 set arcend($a) $p
6785                 unset growing($a)
6786             }
6787             lappend arcnos($p) $a
6788         }
6789         set arcout($id) $ao
6790     }
6791     if {$nid > 0} {
6792         global cached_dheads cached_dtags cached_atags
6793         catch {unset cached_dheads}
6794         catch {unset cached_dtags}
6795         catch {unset cached_atags}
6796     }
6797     if {![eof $fd]} {
6798         return [expr {$nid >= 1000? 2: 1}]
6799     }
6800     set cacheok 1
6801     if {[catch {
6802         fconfigure $fd -blocking 1
6803         close $fd
6804     } err]} {
6805         # got an error reading the list of commits
6806         # if we were updating, try rereading the whole thing again
6807         if {$allcupdate} {
6808             incr allcommits -1
6809             dropcache $err
6810             return
6811         }
6812         error_popup "Error reading commit topology information;\
6813                 branch and preceding/following tag information\
6814                 will be incomplete.\n($err)"
6815         set cacheok 0
6816     }
6817     if {[incr allcommits -1] == 0} {
6818         notbusy allcommits
6819         if {$cacheok} {
6820             run savecache
6821         }
6822     }
6823     dispneartags 0
6824     return 0
6827 proc recalcarc {a} {
6828     global arctags archeads arcids idtags idheads
6830     set at {}
6831     set ah {}
6832     foreach id [lrange $arcids($a) 0 end-1] {
6833         if {[info exists idtags($id)]} {
6834             lappend at $id
6835         }
6836         if {[info exists idheads($id)]} {
6837             lappend ah $id
6838         }
6839     }
6840     set arctags($a) $at
6841     set archeads($a) $ah
6844 proc splitarc {p} {
6845     global arcnos arcids nextarc arctags archeads idtags idheads
6846     global arcstart arcend arcout allparents growing
6848     set a $arcnos($p)
6849     if {[llength $a] != 1} {
6850         puts "oops splitarc called but [llength $a] arcs already"
6851         return
6852     }
6853     set a [lindex $a 0]
6854     set i [lsearch -exact $arcids($a) $p]
6855     if {$i < 0} {
6856         puts "oops splitarc $p not in arc $a"
6857         return
6858     }
6859     set na [incr nextarc]
6860     if {[info exists arcend($a)]} {
6861         set arcend($na) $arcend($a)
6862     } else {
6863         set l [lindex $allparents([lindex $arcids($a) end]) 0]
6864         set j [lsearch -exact $arcnos($l) $a]
6865         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6866     }
6867     set tail [lrange $arcids($a) [expr {$i+1}] end]
6868     set arcids($a) [lrange $arcids($a) 0 $i]
6869     set arcend($a) $p
6870     set arcstart($na) $p
6871     set arcout($p) $na
6872     set arcids($na) $tail
6873     if {[info exists growing($a)]} {
6874         set growing($na) 1
6875         unset growing($a)
6876     }
6878     foreach id $tail {
6879         if {[llength $arcnos($id)] == 1} {
6880             set arcnos($id) $na
6881         } else {
6882             set j [lsearch -exact $arcnos($id) $a]
6883             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6884         }
6885     }
6887     # reconstruct tags and heads lists
6888     if {$arctags($a) ne {} || $archeads($a) ne {}} {
6889         recalcarc $a
6890         recalcarc $na
6891     } else {
6892         set arctags($na) {}
6893         set archeads($na) {}
6894     }
6897 # Update things for a new commit added that is a child of one
6898 # existing commit.  Used when cherry-picking.
6899 proc addnewchild {id p} {
6900     global allparents allchildren idtags nextarc
6901     global arcnos arcids arctags arcout arcend arcstart archeads growing
6902     global seeds allcommits
6904     if {![info exists allcommits] || ![info exists arcnos($p)]} return
6905     set allparents($id) [list $p]
6906     set allchildren($id) {}
6907     set arcnos($id) {}
6908     lappend seeds $id
6909     lappend allchildren($p) $id
6910     set a [incr nextarc]
6911     set arcstart($a) $id
6912     set archeads($a) {}
6913     set arctags($a) {}
6914     set arcids($a) [list $p]
6915     set arcend($a) $p
6916     if {![info exists arcout($p)]} {
6917         splitarc $p
6918     }
6919     lappend arcnos($p) $a
6920     set arcout($id) [list $a]
6923 # This implements a cache for the topology information.
6924 # The cache saves, for each arc, the start and end of the arc,
6925 # the ids on the arc, and the outgoing arcs from the end.
6926 proc readcache {f} {
6927     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6928     global idtags idheads allparents cachedarcs possible_seeds seeds growing
6929     global allcwait
6931     set a $nextarc
6932     set lim $cachedarcs
6933     if {$lim - $a > 500} {
6934         set lim [expr {$a + 500}]
6935     }
6936     if {[catch {
6937         if {$a == $lim} {
6938             # finish reading the cache and setting up arctags, etc.
6939             set line [gets $f]
6940             if {$line ne "1"} {error "bad final version"}
6941             close $f
6942             foreach id [array names idtags] {
6943                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6944                     [llength $allparents($id)] == 1} {
6945                     set a [lindex $arcnos($id) 0]
6946                     if {$arctags($a) eq {}} {
6947                         recalcarc $a
6948                     }
6949                 }
6950             }
6951             foreach id [array names idheads] {
6952                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
6953                     [llength $allparents($id)] == 1} {
6954                     set a [lindex $arcnos($id) 0]
6955                     if {$archeads($a) eq {}} {
6956                         recalcarc $a
6957                     }
6958                 }
6959             }
6960             foreach id [lsort -unique $possible_seeds] {
6961                 if {$arcnos($id) eq {}} {
6962                     lappend seeds $id
6963                 }
6964             }
6965             set allcwait 0
6966         } else {
6967             while {[incr a] <= $lim} {
6968                 set line [gets $f]
6969                 if {[llength $line] != 3} {error "bad line"}
6970                 set s [lindex $line 0]
6971                 set arcstart($a) $s
6972                 lappend arcout($s) $a
6973                 if {![info exists arcnos($s)]} {
6974                     lappend possible_seeds $s
6975                     set arcnos($s) {}
6976                 }
6977                 set e [lindex $line 1]
6978                 if {$e eq {}} {
6979                     set growing($a) 1
6980                 } else {
6981                     set arcend($a) $e
6982                     if {![info exists arcout($e)]} {
6983                         set arcout($e) {}
6984                     }
6985                 }
6986                 set arcids($a) [lindex $line 2]
6987                 foreach id $arcids($a) {
6988                     lappend allparents($s) $id
6989                     set s $id
6990                     lappend arcnos($id) $a
6991                 }
6992                 if {![info exists allparents($s)]} {
6993                     set allparents($s) {}
6994                 }
6995                 set arctags($a) {}
6996                 set archeads($a) {}
6997             }
6998             set nextarc [expr {$a - 1}]
6999         }
7000     } err]} {
7001         dropcache $err
7002         return 0
7003     }
7004     if {!$allcwait} {
7005         getallcommits
7006     }
7007     return $allcwait
7010 proc getcache {f} {
7011     global nextarc cachedarcs possible_seeds
7013     if {[catch {
7014         set line [gets $f]
7015         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7016         # make sure it's an integer
7017         set cachedarcs [expr {int([lindex $line 1])}]
7018         if {$cachedarcs < 0} {error "bad number of arcs"}
7019         set nextarc 0
7020         set possible_seeds {}
7021         run readcache $f
7022     } err]} {
7023         dropcache $err
7024     }
7025     return 0
7028 proc dropcache {err} {
7029     global allcwait nextarc cachedarcs seeds
7031     #puts "dropping cache ($err)"
7032     foreach v {arcnos arcout arcids arcstart arcend growing \
7033                    arctags archeads allparents allchildren} {
7034         global $v
7035         catch {unset $v}
7036     }
7037     set allcwait 0
7038     set nextarc 0
7039     set cachedarcs 0
7040     set seeds {}
7041     getallcommits
7044 proc writecache {f} {
7045     global cachearc cachedarcs allccache
7046     global arcstart arcend arcnos arcids arcout
7048     set a $cachearc
7049     set lim $cachedarcs
7050     if {$lim - $a > 1000} {
7051         set lim [expr {$a + 1000}]
7052     }
7053     if {[catch {
7054         while {[incr a] <= $lim} {
7055             if {[info exists arcend($a)]} {
7056                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7057             } else {
7058                 puts $f [list $arcstart($a) {} $arcids($a)]
7059             }
7060         }
7061     } err]} {
7062         catch {close $f}
7063         catch {file delete $allccache}
7064         #puts "writing cache failed ($err)"
7065         return 0
7066     }
7067     set cachearc [expr {$a - 1}]
7068     if {$a > $cachedarcs} {
7069         puts $f "1"
7070         close $f
7071         return 0
7072     }
7073     return 1
7076 proc savecache {} {
7077     global nextarc cachedarcs cachearc allccache
7079     if {$nextarc == $cachedarcs} return
7080     set cachearc 0
7081     set cachedarcs $nextarc
7082     catch {
7083         set f [open $allccache w]
7084         puts $f [list 1 $cachedarcs]
7085         run writecache $f
7086     }
7089 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7090 # or 0 if neither is true.
7091 proc anc_or_desc {a b} {
7092     global arcout arcstart arcend arcnos cached_isanc
7094     if {$arcnos($a) eq $arcnos($b)} {
7095         # Both are on the same arc(s); either both are the same BMP,
7096         # or if one is not a BMP, the other is also not a BMP or is
7097         # the BMP at end of the arc (and it only has 1 incoming arc).
7098         # Or both can be BMPs with no incoming arcs.
7099         if {$a eq $b || $arcnos($a) eq {}} {
7100             return 0
7101         }
7102         # assert {[llength $arcnos($a)] == 1}
7103         set arc [lindex $arcnos($a) 0]
7104         set i [lsearch -exact $arcids($arc) $a]
7105         set j [lsearch -exact $arcids($arc) $b]
7106         if {$i < 0 || $i > $j} {
7107             return 1
7108         } else {
7109             return -1
7110         }
7111     }
7113     if {![info exists arcout($a)]} {
7114         set arc [lindex $arcnos($a) 0]
7115         if {[info exists arcend($arc)]} {
7116             set aend $arcend($arc)
7117         } else {
7118             set aend {}
7119         }
7120         set a $arcstart($arc)
7121     } else {
7122         set aend $a
7123     }
7124     if {![info exists arcout($b)]} {
7125         set arc [lindex $arcnos($b) 0]
7126         if {[info exists arcend($arc)]} {
7127             set bend $arcend($arc)
7128         } else {
7129             set bend {}
7130         }
7131         set b $arcstart($arc)
7132     } else {
7133         set bend $b
7134     }
7135     if {$a eq $bend} {
7136         return 1
7137     }
7138     if {$b eq $aend} {
7139         return -1
7140     }
7141     if {[info exists cached_isanc($a,$bend)]} {
7142         if {$cached_isanc($a,$bend)} {
7143             return 1
7144         }
7145     }
7146     if {[info exists cached_isanc($b,$aend)]} {
7147         if {$cached_isanc($b,$aend)} {
7148             return -1
7149         }
7150         if {[info exists cached_isanc($a,$bend)]} {
7151             return 0
7152         }
7153     }
7155     set todo [list $a $b]
7156     set anc($a) a
7157     set anc($b) b
7158     for {set i 0} {$i < [llength $todo]} {incr i} {
7159         set x [lindex $todo $i]
7160         if {$anc($x) eq {}} {
7161             continue
7162         }
7163         foreach arc $arcnos($x) {
7164             set xd $arcstart($arc)
7165             if {$xd eq $bend} {
7166                 set cached_isanc($a,$bend) 1
7167                 set cached_isanc($b,$aend) 0
7168                 return 1
7169             } elseif {$xd eq $aend} {
7170                 set cached_isanc($b,$aend) 1
7171                 set cached_isanc($a,$bend) 0
7172                 return -1
7173             }
7174             if {![info exists anc($xd)]} {
7175                 set anc($xd) $anc($x)
7176                 lappend todo $xd
7177             } elseif {$anc($xd) ne $anc($x)} {
7178                 set anc($xd) {}
7179             }
7180         }
7181     }
7182     set cached_isanc($a,$bend) 0
7183     set cached_isanc($b,$aend) 0
7184     return 0
7187 # This identifies whether $desc has an ancestor that is
7188 # a growing tip of the graph and which is not an ancestor of $anc
7189 # and returns 0 if so and 1 if not.
7190 # If we subsequently discover a tag on such a growing tip, and that
7191 # turns out to be a descendent of $anc (which it could, since we
7192 # don't necessarily see children before parents), then $desc
7193 # isn't a good choice to display as a descendent tag of
7194 # $anc (since it is the descendent of another tag which is
7195 # a descendent of $anc).  Similarly, $anc isn't a good choice to
7196 # display as a ancestor tag of $desc.
7198 proc is_certain {desc anc} {
7199     global arcnos arcout arcstart arcend growing problems
7201     set certain {}
7202     if {[llength $arcnos($anc)] == 1} {
7203         # tags on the same arc are certain
7204         if {$arcnos($desc) eq $arcnos($anc)} {
7205             return 1
7206         }
7207         if {![info exists arcout($anc)]} {
7208             # if $anc is partway along an arc, use the start of the arc instead
7209             set a [lindex $arcnos($anc) 0]
7210             set anc $arcstart($a)
7211         }
7212     }
7213     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7214         set x $desc
7215     } else {
7216         set a [lindex $arcnos($desc) 0]
7217         set x $arcend($a)
7218     }
7219     if {$x == $anc} {
7220         return 1
7221     }
7222     set anclist [list $x]
7223     set dl($x) 1
7224     set nnh 1
7225     set ngrowanc 0
7226     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7227         set x [lindex $anclist $i]
7228         if {$dl($x)} {
7229             incr nnh -1
7230         }
7231         set done($x) 1
7232         foreach a $arcout($x) {
7233             if {[info exists growing($a)]} {
7234                 if {![info exists growanc($x)] && $dl($x)} {
7235                     set growanc($x) 1
7236                     incr ngrowanc
7237                 }
7238             } else {
7239                 set y $arcend($a)
7240                 if {[info exists dl($y)]} {
7241                     if {$dl($y)} {
7242                         if {!$dl($x)} {
7243                             set dl($y) 0
7244                             if {![info exists done($y)]} {
7245                                 incr nnh -1
7246                             }
7247                             if {[info exists growanc($x)]} {
7248                                 incr ngrowanc -1
7249                             }
7250                             set xl [list $y]
7251                             for {set k 0} {$k < [llength $xl]} {incr k} {
7252                                 set z [lindex $xl $k]
7253                                 foreach c $arcout($z) {
7254                                     if {[info exists arcend($c)]} {
7255                                         set v $arcend($c)
7256                                         if {[info exists dl($v)] && $dl($v)} {
7257                                             set dl($v) 0
7258                                             if {![info exists done($v)]} {
7259                                                 incr nnh -1
7260                                             }
7261                                             if {[info exists growanc($v)]} {
7262                                                 incr ngrowanc -1
7263                                             }
7264                                             lappend xl $v
7265                                         }
7266                                     }
7267                                 }
7268                             }
7269                         }
7270                     }
7271                 } elseif {$y eq $anc || !$dl($x)} {
7272                     set dl($y) 0
7273                     lappend anclist $y
7274                 } else {
7275                     set dl($y) 1
7276                     lappend anclist $y
7277                     incr nnh
7278                 }
7279             }
7280         }
7281     }
7282     foreach x [array names growanc] {
7283         if {$dl($x)} {
7284             return 0
7285         }
7286         return 0
7287     }
7288     return 1
7291 proc validate_arctags {a} {
7292     global arctags idtags
7294     set i -1
7295     set na $arctags($a)
7296     foreach id $arctags($a) {
7297         incr i
7298         if {![info exists idtags($id)]} {
7299             set na [lreplace $na $i $i]
7300             incr i -1
7301         }
7302     }
7303     set arctags($a) $na
7306 proc validate_archeads {a} {
7307     global archeads idheads
7309     set i -1
7310     set na $archeads($a)
7311     foreach id $archeads($a) {
7312         incr i
7313         if {![info exists idheads($id)]} {
7314             set na [lreplace $na $i $i]
7315             incr i -1
7316         }
7317     }
7318     set archeads($a) $na
7321 # Return the list of IDs that have tags that are descendents of id,
7322 # ignoring IDs that are descendents of IDs already reported.
7323 proc desctags {id} {
7324     global arcnos arcstart arcids arctags idtags allparents
7325     global growing cached_dtags
7327     if {![info exists allparents($id)]} {
7328         return {}
7329     }
7330     set t1 [clock clicks -milliseconds]
7331     set argid $id
7332     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7333         # part-way along an arc; check that arc first
7334         set a [lindex $arcnos($id) 0]
7335         if {$arctags($a) ne {}} {
7336             validate_arctags $a
7337             set i [lsearch -exact $arcids($a) $id]
7338             set tid {}
7339             foreach t $arctags($a) {
7340                 set j [lsearch -exact $arcids($a) $t]
7341                 if {$j >= $i} break
7342                 set tid $t
7343             }
7344             if {$tid ne {}} {
7345                 return $tid
7346             }
7347         }
7348         set id $arcstart($a)
7349         if {[info exists idtags($id)]} {
7350             return $id
7351         }
7352     }
7353     if {[info exists cached_dtags($id)]} {
7354         return $cached_dtags($id)
7355     }
7357     set origid $id
7358     set todo [list $id]
7359     set queued($id) 1
7360     set nc 1
7361     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7362         set id [lindex $todo $i]
7363         set done($id) 1
7364         set ta [info exists hastaggedancestor($id)]
7365         if {!$ta} {
7366             incr nc -1
7367         }
7368         # ignore tags on starting node
7369         if {!$ta && $i > 0} {
7370             if {[info exists idtags($id)]} {
7371                 set tagloc($id) $id
7372                 set ta 1
7373             } elseif {[info exists cached_dtags($id)]} {
7374                 set tagloc($id) $cached_dtags($id)
7375                 set ta 1
7376             }
7377         }
7378         foreach a $arcnos($id) {
7379             set d $arcstart($a)
7380             if {!$ta && $arctags($a) ne {}} {
7381                 validate_arctags $a
7382                 if {$arctags($a) ne {}} {
7383                     lappend tagloc($id) [lindex $arctags($a) end]
7384                 }
7385             }
7386             if {$ta || $arctags($a) ne {}} {
7387                 set tomark [list $d]
7388                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7389                     set dd [lindex $tomark $j]
7390                     if {![info exists hastaggedancestor($dd)]} {
7391                         if {[info exists done($dd)]} {
7392                             foreach b $arcnos($dd) {
7393                                 lappend tomark $arcstart($b)
7394                             }
7395                             if {[info exists tagloc($dd)]} {
7396                                 unset tagloc($dd)
7397                             }
7398                         } elseif {[info exists queued($dd)]} {
7399                             incr nc -1
7400                         }
7401                         set hastaggedancestor($dd) 1
7402                     }
7403                 }
7404             }
7405             if {![info exists queued($d)]} {
7406                 lappend todo $d
7407                 set queued($d) 1
7408                 if {![info exists hastaggedancestor($d)]} {
7409                     incr nc
7410                 }
7411             }
7412         }
7413     }
7414     set tags {}
7415     foreach id [array names tagloc] {
7416         if {![info exists hastaggedancestor($id)]} {
7417             foreach t $tagloc($id) {
7418                 if {[lsearch -exact $tags $t] < 0} {
7419                     lappend tags $t
7420                 }
7421             }
7422         }
7423     }
7424     set t2 [clock clicks -milliseconds]
7425     set loopix $i
7427     # remove tags that are descendents of other tags
7428     for {set i 0} {$i < [llength $tags]} {incr i} {
7429         set a [lindex $tags $i]
7430         for {set j 0} {$j < $i} {incr j} {
7431             set b [lindex $tags $j]
7432             set r [anc_or_desc $a $b]
7433             if {$r == 1} {
7434                 set tags [lreplace $tags $j $j]
7435                 incr j -1
7436                 incr i -1
7437             } elseif {$r == -1} {
7438                 set tags [lreplace $tags $i $i]
7439                 incr i -1
7440                 break
7441             }
7442         }
7443     }
7445     if {[array names growing] ne {}} {
7446         # graph isn't finished, need to check if any tag could get
7447         # eclipsed by another tag coming later.  Simply ignore any
7448         # tags that could later get eclipsed.
7449         set ctags {}
7450         foreach t $tags {
7451             if {[is_certain $t $origid]} {
7452                 lappend ctags $t
7453             }
7454         }
7455         if {$tags eq $ctags} {
7456             set cached_dtags($origid) $tags
7457         } else {
7458             set tags $ctags
7459         }
7460     } else {
7461         set cached_dtags($origid) $tags
7462     }
7463     set t3 [clock clicks -milliseconds]
7464     if {0 && $t3 - $t1 >= 100} {
7465         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7466             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7467     }
7468     return $tags
7471 proc anctags {id} {
7472     global arcnos arcids arcout arcend arctags idtags allparents
7473     global growing cached_atags
7475     if {![info exists allparents($id)]} {
7476         return {}
7477     }
7478     set t1 [clock clicks -milliseconds]
7479     set argid $id
7480     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7481         # part-way along an arc; check that arc first
7482         set a [lindex $arcnos($id) 0]
7483         if {$arctags($a) ne {}} {
7484             validate_arctags $a
7485             set i [lsearch -exact $arcids($a) $id]
7486             foreach t $arctags($a) {
7487                 set j [lsearch -exact $arcids($a) $t]
7488                 if {$j > $i} {
7489                     return $t
7490                 }
7491             }
7492         }
7493         if {![info exists arcend($a)]} {
7494             return {}
7495         }
7496         set id $arcend($a)
7497         if {[info exists idtags($id)]} {
7498             return $id
7499         }
7500     }
7501     if {[info exists cached_atags($id)]} {
7502         return $cached_atags($id)
7503     }
7505     set origid $id
7506     set todo [list $id]
7507     set queued($id) 1
7508     set taglist {}
7509     set nc 1
7510     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7511         set id [lindex $todo $i]
7512         set done($id) 1
7513         set td [info exists hastaggeddescendent($id)]
7514         if {!$td} {
7515             incr nc -1
7516         }
7517         # ignore tags on starting node
7518         if {!$td && $i > 0} {
7519             if {[info exists idtags($id)]} {
7520                 set tagloc($id) $id
7521                 set td 1
7522             } elseif {[info exists cached_atags($id)]} {
7523                 set tagloc($id) $cached_atags($id)
7524                 set td 1
7525             }
7526         }
7527         foreach a $arcout($id) {
7528             if {!$td && $arctags($a) ne {}} {
7529                 validate_arctags $a
7530                 if {$arctags($a) ne {}} {
7531                     lappend tagloc($id) [lindex $arctags($a) 0]
7532                 }
7533             }
7534             if {![info exists arcend($a)]} continue
7535             set d $arcend($a)
7536             if {$td || $arctags($a) ne {}} {
7537                 set tomark [list $d]
7538                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7539                     set dd [lindex $tomark $j]
7540                     if {![info exists hastaggeddescendent($dd)]} {
7541                         if {[info exists done($dd)]} {
7542                             foreach b $arcout($dd) {
7543                                 if {[info exists arcend($b)]} {
7544                                     lappend tomark $arcend($b)
7545                                 }
7546                             }
7547                             if {[info exists tagloc($dd)]} {
7548                                 unset tagloc($dd)
7549                             }
7550                         } elseif {[info exists queued($dd)]} {
7551                             incr nc -1
7552                         }
7553                         set hastaggeddescendent($dd) 1
7554                     }
7555                 }
7556             }
7557             if {![info exists queued($d)]} {
7558                 lappend todo $d
7559                 set queued($d) 1
7560                 if {![info exists hastaggeddescendent($d)]} {
7561                     incr nc
7562                 }
7563             }
7564         }
7565     }
7566     set t2 [clock clicks -milliseconds]
7567     set loopix $i
7568     set tags {}
7569     foreach id [array names tagloc] {
7570         if {![info exists hastaggeddescendent($id)]} {
7571             foreach t $tagloc($id) {
7572                 if {[lsearch -exact $tags $t] < 0} {
7573                     lappend tags $t
7574                 }
7575             }
7576         }
7577     }
7579     # remove tags that are ancestors of other tags
7580     for {set i 0} {$i < [llength $tags]} {incr i} {
7581         set a [lindex $tags $i]
7582         for {set j 0} {$j < $i} {incr j} {
7583             set b [lindex $tags $j]
7584             set r [anc_or_desc $a $b]
7585             if {$r == -1} {
7586                 set tags [lreplace $tags $j $j]
7587                 incr j -1
7588                 incr i -1
7589             } elseif {$r == 1} {
7590                 set tags [lreplace $tags $i $i]
7591                 incr i -1
7592                 break
7593             }
7594         }
7595     }
7597     if {[array names growing] ne {}} {
7598         # graph isn't finished, need to check if any tag could get
7599         # eclipsed by another tag coming later.  Simply ignore any
7600         # tags that could later get eclipsed.
7601         set ctags {}
7602         foreach t $tags {
7603             if {[is_certain $origid $t]} {
7604                 lappend ctags $t
7605             }
7606         }
7607         if {$tags eq $ctags} {
7608             set cached_atags($origid) $tags
7609         } else {
7610             set tags $ctags
7611         }
7612     } else {
7613         set cached_atags($origid) $tags
7614     }
7615     set t3 [clock clicks -milliseconds]
7616     if {0 && $t3 - $t1 >= 100} {
7617         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7618             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7619     }
7620     return $tags
7623 # Return the list of IDs that have heads that are descendents of id,
7624 # including id itself if it has a head.
7625 proc descheads {id} {
7626     global arcnos arcstart arcids archeads idheads cached_dheads
7627     global allparents
7629     if {![info exists allparents($id)]} {
7630         return {}
7631     }
7632     set aret {}
7633     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7634         # part-way along an arc; check it first
7635         set a [lindex $arcnos($id) 0]
7636         if {$archeads($a) ne {}} {
7637             validate_archeads $a
7638             set i [lsearch -exact $arcids($a) $id]
7639             foreach t $archeads($a) {
7640                 set j [lsearch -exact $arcids($a) $t]
7641                 if {$j > $i} break
7642                 lappend aret $t
7643             }
7644         }
7645         set id $arcstart($a)
7646     }
7647     set origid $id
7648     set todo [list $id]
7649     set seen($id) 1
7650     set ret {}
7651     for {set i 0} {$i < [llength $todo]} {incr i} {
7652         set id [lindex $todo $i]
7653         if {[info exists cached_dheads($id)]} {
7654             set ret [concat $ret $cached_dheads($id)]
7655         } else {
7656             if {[info exists idheads($id)]} {
7657                 lappend ret $id
7658             }
7659             foreach a $arcnos($id) {
7660                 if {$archeads($a) ne {}} {
7661                     validate_archeads $a
7662                     if {$archeads($a) ne {}} {
7663                         set ret [concat $ret $archeads($a)]
7664                     }
7665                 }
7666                 set d $arcstart($a)
7667                 if {![info exists seen($d)]} {
7668                     lappend todo $d
7669                     set seen($d) 1
7670                 }
7671             }
7672         }
7673     }
7674     set ret [lsort -unique $ret]
7675     set cached_dheads($origid) $ret
7676     return [concat $ret $aret]
7679 proc addedtag {id} {
7680     global arcnos arcout cached_dtags cached_atags
7682     if {![info exists arcnos($id)]} return
7683     if {![info exists arcout($id)]} {
7684         recalcarc [lindex $arcnos($id) 0]
7685     }
7686     catch {unset cached_dtags}
7687     catch {unset cached_atags}
7690 proc addedhead {hid head} {
7691     global arcnos arcout cached_dheads
7693     if {![info exists arcnos($hid)]} return
7694     if {![info exists arcout($hid)]} {
7695         recalcarc [lindex $arcnos($hid) 0]
7696     }
7697     catch {unset cached_dheads}
7700 proc removedhead {hid head} {
7701     global cached_dheads
7703     catch {unset cached_dheads}
7706 proc movedhead {hid head} {
7707     global arcnos arcout cached_dheads
7709     if {![info exists arcnos($hid)]} return
7710     if {![info exists arcout($hid)]} {
7711         recalcarc [lindex $arcnos($hid) 0]
7712     }
7713     catch {unset cached_dheads}
7716 proc changedrefs {} {
7717     global cached_dheads cached_dtags cached_atags
7718     global arctags archeads arcnos arcout idheads idtags
7720     foreach id [concat [array names idheads] [array names idtags]] {
7721         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7722             set a [lindex $arcnos($id) 0]
7723             if {![info exists donearc($a)]} {
7724                 recalcarc $a
7725                 set donearc($a) 1
7726             }
7727         }
7728     }
7729     catch {unset cached_dtags}
7730     catch {unset cached_atags}
7731     catch {unset cached_dheads}
7734 proc rereadrefs {} {
7735     global idtags idheads idotherrefs mainhead
7737     set refids [concat [array names idtags] \
7738                     [array names idheads] [array names idotherrefs]]
7739     foreach id $refids {
7740         if {![info exists ref($id)]} {
7741             set ref($id) [listrefs $id]
7742         }
7743     }
7744     set oldmainhead $mainhead
7745     readrefs
7746     changedrefs
7747     set refids [lsort -unique [concat $refids [array names idtags] \
7748                         [array names idheads] [array names idotherrefs]]]
7749     foreach id $refids {
7750         set v [listrefs $id]
7751         if {![info exists ref($id)] || $ref($id) != $v ||
7752             ($id eq $oldmainhead && $id ne $mainhead) ||
7753             ($id eq $mainhead && $id ne $oldmainhead)} {
7754             redrawtags $id
7755         }
7756     }
7757     run refill_reflist
7760 proc listrefs {id} {
7761     global idtags idheads idotherrefs
7763     set x {}
7764     if {[info exists idtags($id)]} {
7765         set x $idtags($id)
7766     }
7767     set y {}
7768     if {[info exists idheads($id)]} {
7769         set y $idheads($id)
7770     }
7771     set z {}
7772     if {[info exists idotherrefs($id)]} {
7773         set z $idotherrefs($id)
7774     }
7775     return [list $x $y $z]
7778 proc showtag {tag isnew} {
7779     global ctext tagcontents tagids linknum tagobjid
7781     if {$isnew} {
7782         addtohistory [list showtag $tag 0]
7783     }
7784     $ctext conf -state normal
7785     clear_ctext
7786     settabs 0
7787     set linknum 0
7788     if {![info exists tagcontents($tag)]} {
7789         catch {
7790             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7791         }
7792     }
7793     if {[info exists tagcontents($tag)]} {
7794         set text $tagcontents($tag)
7795     } else {
7796         set text "Tag: $tag\nId:  $tagids($tag)"
7797     }
7798     appendwithlinks $text {}
7799     $ctext conf -state disabled
7800     init_flist {}
7803 proc doquit {} {
7804     global stopped
7805     set stopped 100
7806     savestuff .
7807     destroy .
7810 proc mkfontdisp {font top which} {
7811     global fontattr fontpref $font
7813     set fontpref($font) [set $font]
7814     button $top.${font}but -text $which -font optionfont \
7815         -command [list choosefont $font $which]
7816     label $top.$font -relief flat -font $font \
7817         -text $fontattr($font,family) -justify left
7818     grid x $top.${font}but $top.$font -sticky w
7821 proc choosefont {font which} {
7822     global fontparam fontlist fonttop fontattr
7824     set fontparam(which) $which
7825     set fontparam(font) $font
7826     set fontparam(family) [font actual $font -family]
7827     set fontparam(size) $fontattr($font,size)
7828     set fontparam(weight) $fontattr($font,weight)
7829     set fontparam(slant) $fontattr($font,slant)
7830     set top .gitkfont
7831     set fonttop $top
7832     if {![winfo exists $top]} {
7833         font create sample
7834         eval font config sample [font actual $font]
7835         toplevel $top
7836         wm title $top "Gitk font chooser"
7837         label $top.l -textvariable fontparam(which) -font uifont
7838         pack $top.l -side top
7839         set fontlist [lsort [font families]]
7840         frame $top.f
7841         listbox $top.f.fam -listvariable fontlist \
7842             -yscrollcommand [list $top.f.sb set]
7843         bind $top.f.fam <<ListboxSelect>> selfontfam
7844         scrollbar $top.f.sb -command [list $top.f.fam yview]
7845         pack $top.f.sb -side right -fill y
7846         pack $top.f.fam -side left -fill both -expand 1
7847         pack $top.f -side top -fill both -expand 1
7848         frame $top.g
7849         spinbox $top.g.size -from 4 -to 40 -width 4 \
7850             -textvariable fontparam(size) \
7851             -validatecommand {string is integer -strict %s}
7852         checkbutton $top.g.bold -padx 5 \
7853             -font {{Times New Roman} 12 bold} -text "B" -indicatoron 0 \
7854             -variable fontparam(weight) -onvalue bold -offvalue normal
7855         checkbutton $top.g.ital -padx 5 \
7856             -font {{Times New Roman} 12 italic} -text "I" -indicatoron 0  \
7857             -variable fontparam(slant) -onvalue italic -offvalue roman
7858         pack $top.g.size $top.g.bold $top.g.ital -side left
7859         pack $top.g -side top
7860         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7861             -background white
7862         $top.c create text 100 25 -anchor center -text $which -font sample \
7863             -fill black -tags text
7864         bind $top.c <Configure> [list centertext $top.c]
7865         pack $top.c -side top -fill x
7866         frame $top.buts
7867         button $top.buts.ok -text "OK" -command fontok -default active \
7868             -font uifont
7869         button $top.buts.can -text "Cancel" -command fontcan -default normal \
7870             -font uifont
7871         grid $top.buts.ok $top.buts.can
7872         grid columnconfigure $top.buts 0 -weight 1 -uniform a
7873         grid columnconfigure $top.buts 1 -weight 1 -uniform a
7874         pack $top.buts -side bottom -fill x
7875         trace add variable fontparam write chg_fontparam
7876     } else {
7877         raise $top
7878         $top.c itemconf text -text $which
7879     }
7880     set i [lsearch -exact $fontlist $fontparam(family)]
7881     if {$i >= 0} {
7882         $top.f.fam selection set $i
7883         $top.f.fam see $i
7884     }
7887 proc centertext {w} {
7888     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7891 proc fontok {} {
7892     global fontparam fontpref prefstop
7894     set f $fontparam(font)
7895     set fontpref($f) [list $fontparam(family) $fontparam(size)]
7896     if {$fontparam(weight) eq "bold"} {
7897         lappend fontpref($f) "bold"
7898     }
7899     if {$fontparam(slant) eq "italic"} {
7900         lappend fontpref($f) "italic"
7901     }
7902     set w $prefstop.$f
7903     $w conf -text $fontparam(family) -font $fontpref($f)
7904         
7905     fontcan
7908 proc fontcan {} {
7909     global fonttop fontparam
7911     if {[info exists fonttop]} {
7912         catch {destroy $fonttop}
7913         catch {font delete sample}
7914         unset fonttop
7915         unset fontparam
7916     }
7919 proc selfontfam {} {
7920     global fonttop fontparam
7922     set i [$fonttop.f.fam curselection]
7923     if {$i ne {}} {
7924         set fontparam(family) [$fonttop.f.fam get $i]
7925     }
7928 proc chg_fontparam {v sub op} {
7929     global fontparam
7931     font config sample -$sub $fontparam($sub)
7934 proc doprefs {} {
7935     global maxwidth maxgraphpct
7936     global oldprefs prefstop showneartags showlocalchanges
7937     global bgcolor fgcolor ctext diffcolors selectbgcolor
7938     global uifont tabstop limitdiffs
7940     set top .gitkprefs
7941     set prefstop $top
7942     if {[winfo exists $top]} {
7943         raise $top
7944         return
7945     }
7946     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
7947                    limitdiffs tabstop} {
7948         set oldprefs($v) [set $v]
7949     }
7950     toplevel $top
7951     wm title $top "Gitk preferences"
7952     label $top.ldisp -text "Commit list display options"
7953     $top.ldisp configure -font uifont
7954     grid $top.ldisp - -sticky w -pady 10
7955     label $top.spacer -text " "
7956     label $top.maxwidthl -text "Maximum graph width (lines)" \
7957         -font optionfont
7958     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
7959     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
7960     label $top.maxpctl -text "Maximum graph width (% of pane)" \
7961         -font optionfont
7962     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
7963     grid x $top.maxpctl $top.maxpct -sticky w
7964     frame $top.showlocal
7965     label $top.showlocal.l -text "Show local changes" -font optionfont
7966     checkbutton $top.showlocal.b -variable showlocalchanges
7967     pack $top.showlocal.b $top.showlocal.l -side left
7968     grid x $top.showlocal -sticky w
7970     label $top.ddisp -text "Diff display options"
7971     $top.ddisp configure -font uifont
7972     grid $top.ddisp - -sticky w -pady 10
7973     label $top.tabstopl -text "Tab spacing" -font optionfont
7974     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
7975     grid x $top.tabstopl $top.tabstop -sticky w
7976     frame $top.ntag
7977     label $top.ntag.l -text "Display nearby tags" -font optionfont
7978     checkbutton $top.ntag.b -variable showneartags
7979     pack $top.ntag.b $top.ntag.l -side left
7980     grid x $top.ntag -sticky w
7981     frame $top.ldiff
7982     label $top.ldiff.l -text "Limit diffs to listed paths" -font optionfont
7983     checkbutton $top.ldiff.b -variable limitdiffs
7984     pack $top.ldiff.b $top.ldiff.l -side left
7985     grid x $top.ldiff -sticky w
7987     label $top.cdisp -text "Colors: press to choose"
7988     $top.cdisp configure -font uifont
7989     grid $top.cdisp - -sticky w -pady 10
7990     label $top.bg -padx 40 -relief sunk -background $bgcolor
7991     button $top.bgbut -text "Background" -font optionfont \
7992         -command [list choosecolor bgcolor 0 $top.bg background setbg]
7993     grid x $top.bgbut $top.bg -sticky w
7994     label $top.fg -padx 40 -relief sunk -background $fgcolor
7995     button $top.fgbut -text "Foreground" -font optionfont \
7996         -command [list choosecolor fgcolor 0 $top.fg foreground setfg]
7997     grid x $top.fgbut $top.fg -sticky w
7998     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
7999     button $top.diffoldbut -text "Diff: old lines" -font optionfont \
8000         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8001                       [list $ctext tag conf d0 -foreground]]
8002     grid x $top.diffoldbut $top.diffold -sticky w
8003     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8004     button $top.diffnewbut -text "Diff: new lines" -font optionfont \
8005         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8006                       [list $ctext tag conf d1 -foreground]]
8007     grid x $top.diffnewbut $top.diffnew -sticky w
8008     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8009     button $top.hunksepbut -text "Diff: hunk header" -font optionfont \
8010         -command [list choosecolor diffcolors 2 $top.hunksep \
8011                       "diff hunk header" \
8012                       [list $ctext tag conf hunksep -foreground]]
8013     grid x $top.hunksepbut $top.hunksep -sticky w
8014     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8015     button $top.selbgbut -text "Select bg" -font optionfont \
8016         -command [list choosecolor selectbgcolor 0 $top.selbgsep background setselbg]
8017     grid x $top.selbgbut $top.selbgsep -sticky w
8019     label $top.cfont -text "Fonts: press to choose"
8020     $top.cfont configure -font uifont
8021     grid $top.cfont - -sticky w -pady 10
8022     mkfontdisp mainfont $top "Main font"
8023     mkfontdisp textfont $top "Diff display font"
8024     mkfontdisp uifont $top "User interface font"
8026     frame $top.buts
8027     button $top.buts.ok -text "OK" -command prefsok -default active
8028     $top.buts.ok configure -font uifont
8029     button $top.buts.can -text "Cancel" -command prefscan -default normal
8030     $top.buts.can configure -font uifont
8031     grid $top.buts.ok $top.buts.can
8032     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8033     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8034     grid $top.buts - - -pady 10 -sticky ew
8035     bind $top <Visibility> "focus $top.buts.ok"
8038 proc choosecolor {v vi w x cmd} {
8039     global $v
8041     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8042                -title "Gitk: choose color for $x"]
8043     if {$c eq {}} return
8044     $w conf -background $c
8045     lset $v $vi $c
8046     eval $cmd $c
8049 proc setselbg {c} {
8050     global bglist cflist
8051     foreach w $bglist {
8052         $w configure -selectbackground $c
8053     }
8054     $cflist tag configure highlight \
8055         -background [$cflist cget -selectbackground]
8056     allcanvs itemconf secsel -fill $c
8059 proc setbg {c} {
8060     global bglist
8062     foreach w $bglist {
8063         $w conf -background $c
8064     }
8067 proc setfg {c} {
8068     global fglist canv
8070     foreach w $fglist {
8071         $w conf -foreground $c
8072     }
8073     allcanvs itemconf text -fill $c
8074     $canv itemconf circle -outline $c
8077 proc prefscan {} {
8078     global oldprefs prefstop
8080     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8081                    limitdiffs tabstop} {
8082         global $v
8083         set $v $oldprefs($v)
8084     }
8085     catch {destroy $prefstop}
8086     unset prefstop
8087     fontcan
8090 proc prefsok {} {
8091     global maxwidth maxgraphpct
8092     global oldprefs prefstop showneartags showlocalchanges
8093     global fontpref mainfont textfont uifont
8094     global limitdiffs
8096     catch {destroy $prefstop}
8097     unset prefstop
8098     fontcan
8099     set fontchanged 0
8100     if {$mainfont ne $fontpref(mainfont)} {
8101         set mainfont $fontpref(mainfont)
8102         parsefont mainfont $mainfont
8103         eval font configure mainfont [fontflags mainfont]
8104         eval font configure mainfontbold [fontflags mainfont 1]
8105         setcoords
8106         set fontchanged 1
8107     }
8108     if {$textfont ne $fontpref(textfont)} {
8109         set textfont $fontpref(textfont)
8110         parsefont textfont $textfont
8111         eval font configure textfont [fontflags textfont]
8112         eval font configure textfontbold [fontflags textfont 1]
8113     }
8114     if {$uifont ne $fontpref(uifont)} {
8115         set uifont $fontpref(uifont)
8116         parsefont uifont $uifont
8117         eval font configure uifont [fontflags uifont]
8118     }
8119     settabs
8120     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8121         if {$showlocalchanges} {
8122             doshowlocalchanges
8123         } else {
8124             dohidelocalchanges
8125         }
8126     }
8127     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8128         || $maxgraphpct != $oldprefs(maxgraphpct)} {
8129         redisplay
8130     } elseif {$showneartags != $oldprefs(showneartags) ||
8131           $limitdiffs != $oldprefs(limitdiffs)} {
8132         reselectline
8133     }
8136 proc formatdate {d} {
8137     global datetimeformat
8138     if {$d ne {}} {
8139         set d [clock format $d -format $datetimeformat]
8140     }
8141     return $d
8144 # This list of encoding names and aliases is distilled from
8145 # http://www.iana.org/assignments/character-sets.
8146 # Not all of them are supported by Tcl.
8147 set encoding_aliases {
8148     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8149       ISO646-US US-ASCII us IBM367 cp367 csASCII }
8150     { ISO-10646-UTF-1 csISO10646UTF1 }
8151     { ISO_646.basic:1983 ref csISO646basic1983 }
8152     { INVARIANT csINVARIANT }
8153     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8154     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8155     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8156     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8157     { NATS-DANO iso-ir-9-1 csNATSDANO }
8158     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8159     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8160     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8161     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8162     { ISO-2022-KR csISO2022KR }
8163     { EUC-KR csEUCKR }
8164     { ISO-2022-JP csISO2022JP }
8165     { ISO-2022-JP-2 csISO2022JP2 }
8166     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8167       csISO13JISC6220jp }
8168     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8169     { IT iso-ir-15 ISO646-IT csISO15Italian }
8170     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8171     { ES iso-ir-17 ISO646-ES csISO17Spanish }
8172     { greek7-old iso-ir-18 csISO18Greek7Old }
8173     { latin-greek iso-ir-19 csISO19LatinGreek }
8174     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8175     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8176     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8177     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8178     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8179     { BS_viewdata iso-ir-47 csISO47BSViewdata }
8180     { INIS iso-ir-49 csISO49INIS }
8181     { INIS-8 iso-ir-50 csISO50INIS8 }
8182     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8183     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8184     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8185     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8186     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8187     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8188       csISO60Norwegian1 }
8189     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8190     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8191     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8192     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8193     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8194     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8195     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8196     { greek7 iso-ir-88 csISO88Greek7 }
8197     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8198     { iso-ir-90 csISO90 }
8199     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8200     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8201       csISO92JISC62991984b }
8202     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8203     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8204     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8205       csISO95JIS62291984handadd }
8206     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8207     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8208     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8209     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8210       CP819 csISOLatin1 }
8211     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8212     { T.61-7bit iso-ir-102 csISO102T617bit }
8213     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8214     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8215     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8216     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8217     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8218     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8219     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8220     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8221       arabic csISOLatinArabic }
8222     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8223     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8224     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8225       greek greek8 csISOLatinGreek }
8226     { T.101-G2 iso-ir-128 csISO128T101G2 }
8227     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8228       csISOLatinHebrew }
8229     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8230     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8231     { CSN_369103 iso-ir-139 csISO139CSN369103 }
8232     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8233     { ISO_6937-2-add iso-ir-142 csISOTextComm }
8234     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8235     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8236       csISOLatinCyrillic }
8237     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8238     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8239     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8240     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8241     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8242     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8243     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8244     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8245     { ISO_10367-box iso-ir-155 csISO10367Box }
8246     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8247     { latin-lap lap iso-ir-158 csISO158Lap }
8248     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8249     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8250     { us-dk csUSDK }
8251     { dk-us csDKUS }
8252     { JIS_X0201 X0201 csHalfWidthKatakana }
8253     { KSC5636 ISO646-KR csKSC5636 }
8254     { ISO-10646-UCS-2 csUnicode }
8255     { ISO-10646-UCS-4 csUCS4 }
8256     { DEC-MCS dec csDECMCS }
8257     { hp-roman8 roman8 r8 csHPRoman8 }
8258     { macintosh mac csMacintosh }
8259     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8260       csIBM037 }
8261     { IBM038 EBCDIC-INT cp038 csIBM038 }
8262     { IBM273 CP273 csIBM273 }
8263     { IBM274 EBCDIC-BE CP274 csIBM274 }
8264     { IBM275 EBCDIC-BR cp275 csIBM275 }
8265     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8266     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8267     { IBM280 CP280 ebcdic-cp-it csIBM280 }
8268     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8269     { IBM284 CP284 ebcdic-cp-es csIBM284 }
8270     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8271     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8272     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8273     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8274     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8275     { IBM424 cp424 ebcdic-cp-he csIBM424 }
8276     { IBM437 cp437 437 csPC8CodePage437 }
8277     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8278     { IBM775 cp775 csPC775Baltic }
8279     { IBM850 cp850 850 csPC850Multilingual }
8280     { IBM851 cp851 851 csIBM851 }
8281     { IBM852 cp852 852 csPCp852 }
8282     { IBM855 cp855 855 csIBM855 }
8283     { IBM857 cp857 857 csIBM857 }
8284     { IBM860 cp860 860 csIBM860 }
8285     { IBM861 cp861 861 cp-is csIBM861 }
8286     { IBM862 cp862 862 csPC862LatinHebrew }
8287     { IBM863 cp863 863 csIBM863 }
8288     { IBM864 cp864 csIBM864 }
8289     { IBM865 cp865 865 csIBM865 }
8290     { IBM866 cp866 866 csIBM866 }
8291     { IBM868 CP868 cp-ar csIBM868 }
8292     { IBM869 cp869 869 cp-gr csIBM869 }
8293     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8294     { IBM871 CP871 ebcdic-cp-is csIBM871 }
8295     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8296     { IBM891 cp891 csIBM891 }
8297     { IBM903 cp903 csIBM903 }
8298     { IBM904 cp904 904 csIBBM904 }
8299     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8300     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8301     { IBM1026 CP1026 csIBM1026 }
8302     { EBCDIC-AT-DE csIBMEBCDICATDE }
8303     { EBCDIC-AT-DE-A csEBCDICATDEA }
8304     { EBCDIC-CA-FR csEBCDICCAFR }
8305     { EBCDIC-DK-NO csEBCDICDKNO }
8306     { EBCDIC-DK-NO-A csEBCDICDKNOA }
8307     { EBCDIC-FI-SE csEBCDICFISE }
8308     { EBCDIC-FI-SE-A csEBCDICFISEA }
8309     { EBCDIC-FR csEBCDICFR }
8310     { EBCDIC-IT csEBCDICIT }
8311     { EBCDIC-PT csEBCDICPT }
8312     { EBCDIC-ES csEBCDICES }
8313     { EBCDIC-ES-A csEBCDICESA }
8314     { EBCDIC-ES-S csEBCDICESS }
8315     { EBCDIC-UK csEBCDICUK }
8316     { EBCDIC-US csEBCDICUS }
8317     { UNKNOWN-8BIT csUnknown8BiT }
8318     { MNEMONIC csMnemonic }
8319     { MNEM csMnem }
8320     { VISCII csVISCII }
8321     { VIQR csVIQR }
8322     { KOI8-R csKOI8R }
8323     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8324     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8325     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8326     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8327     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8328     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8329     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8330     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8331     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8332     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8333     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8334     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8335     { IBM1047 IBM-1047 }
8336     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8337     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8338     { UNICODE-1-1 csUnicode11 }
8339     { CESU-8 csCESU-8 }
8340     { BOCU-1 csBOCU-1 }
8341     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8342     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8343       l8 }
8344     { ISO-8859-15 ISO_8859-15 Latin-9 }
8345     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8346     { GBK CP936 MS936 windows-936 }
8347     { JIS_Encoding csJISEncoding }
8348     { Shift_JIS MS_Kanji csShiftJIS }
8349     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8350       EUC-JP }
8351     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8352     { ISO-10646-UCS-Basic csUnicodeASCII }
8353     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8354     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8355     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8356     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8357     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8358     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8359     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8360     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8361     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8362     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8363     { Adobe-Standard-Encoding csAdobeStandardEncoding }
8364     { Ventura-US csVenturaUS }
8365     { Ventura-International csVenturaInternational }
8366     { PC8-Danish-Norwegian csPC8DanishNorwegian }
8367     { PC8-Turkish csPC8Turkish }
8368     { IBM-Symbols csIBMSymbols }
8369     { IBM-Thai csIBMThai }
8370     { HP-Legal csHPLegal }
8371     { HP-Pi-font csHPPiFont }
8372     { HP-Math8 csHPMath8 }
8373     { Adobe-Symbol-Encoding csHPPSMath }
8374     { HP-DeskTop csHPDesktop }
8375     { Ventura-Math csVenturaMath }
8376     { Microsoft-Publishing csMicrosoftPublishing }
8377     { Windows-31J csWindows31J }
8378     { GB2312 csGB2312 }
8379     { Big5 csBig5 }
8382 proc tcl_encoding {enc} {
8383     global encoding_aliases
8384     set names [encoding names]
8385     set lcnames [string tolower $names]
8386     set enc [string tolower $enc]
8387     set i [lsearch -exact $lcnames $enc]
8388     if {$i < 0} {
8389         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8390         if {[regsub {^iso[-_]} $enc iso encx]} {
8391             set i [lsearch -exact $lcnames $encx]
8392         }
8393     }
8394     if {$i < 0} {
8395         foreach l $encoding_aliases {
8396             set ll [string tolower $l]
8397             if {[lsearch -exact $ll $enc] < 0} continue
8398             # look through the aliases for one that tcl knows about
8399             foreach e $ll {
8400                 set i [lsearch -exact $lcnames $e]
8401                 if {$i < 0} {
8402                     if {[regsub {^iso[-_]} $e iso ex]} {
8403                         set i [lsearch -exact $lcnames $ex]
8404                     }
8405                 }
8406                 if {$i >= 0} break
8407             }
8408             break
8409         }
8410     }
8411     if {$i >= 0} {
8412         return [lindex $names $i]
8413     }
8414     return {}
8417 # First check that Tcl/Tk is recent enough
8418 if {[catch {package require Tk 8.4} err]} {
8419     show_error {} . "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8420                      Gitk requires at least Tcl/Tk 8.4."
8421     exit 1
8424 # defaults...
8425 set datemode 0
8426 set wrcomcmd "git diff-tree --stdin -p --pretty"
8428 set gitencoding {}
8429 catch {
8430     set gitencoding [exec git config --get i18n.commitencoding]
8432 if {$gitencoding == ""} {
8433     set gitencoding "utf-8"
8435 set tclencoding [tcl_encoding $gitencoding]
8436 if {$tclencoding == {}} {
8437     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8440 set mainfont {Helvetica 9}
8441 set textfont {Courier 9}
8442 set uifont {Helvetica 9 bold}
8443 set tabstop 8
8444 set findmergefiles 0
8445 set maxgraphpct 50
8446 set maxwidth 16
8447 set revlistorder 0
8448 set fastdate 0
8449 set uparrowlen 5
8450 set downarrowlen 5
8451 set mingaplen 100
8452 set cmitmode "patch"
8453 set wrapcomment "none"
8454 set showneartags 1
8455 set maxrefs 20
8456 set maxlinelen 200
8457 set showlocalchanges 1
8458 set limitdiffs 1
8459 set datetimeformat "%Y-%m-%d %H:%M:%S"
8461 set colors {green red blue magenta darkgrey brown orange}
8462 set bgcolor white
8463 set fgcolor black
8464 set diffcolors {red "#00a000" blue}
8465 set diffcontext 3
8466 set selectbgcolor gray85
8468 catch {source ~/.gitk}
8470 font create optionfont -family sans-serif -size -12
8472 parsefont mainfont $mainfont
8473 eval font create mainfont [fontflags mainfont]
8474 eval font create mainfontbold [fontflags mainfont 1]
8476 parsefont textfont $textfont
8477 eval font create textfont [fontflags textfont]
8478 eval font create textfontbold [fontflags textfont 1]
8480 parsefont uifont $uifont
8481 eval font create uifont [fontflags uifont]
8483 # check that we can find a .git directory somewhere...
8484 if {[catch {set gitdir [gitdir]}]} {
8485     show_error {} . "Cannot find a git repository here."
8486     exit 1
8488 if {![file isdirectory $gitdir]} {
8489     show_error {} . "Cannot find the git directory \"$gitdir\"."
8490     exit 1
8493 set mergeonly 0
8494 set revtreeargs {}
8495 set cmdline_files {}
8496 set i 0
8497 foreach arg $argv {
8498     switch -- $arg {
8499         "" { }
8500         "-d" { set datemode 1 }
8501         "--merge" {
8502             set mergeonly 1
8503             lappend revtreeargs $arg
8504         }
8505         "--" {
8506             set cmdline_files [lrange $argv [expr {$i + 1}] end]
8507             break
8508         }
8509         default {
8510             lappend revtreeargs $arg
8511         }
8512     }
8513     incr i
8516 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8517     # no -- on command line, but some arguments (other than -d)
8518     if {[catch {
8519         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8520         set cmdline_files [split $f "\n"]
8521         set n [llength $cmdline_files]
8522         set revtreeargs [lrange $revtreeargs 0 end-$n]
8523         # Unfortunately git rev-parse doesn't produce an error when
8524         # something is both a revision and a filename.  To be consistent
8525         # with git log and git rev-list, check revtreeargs for filenames.
8526         foreach arg $revtreeargs {
8527             if {[file exists $arg]} {
8528                 show_error {} . "Ambiguous argument '$arg': both revision\
8529                                  and filename"
8530                 exit 1
8531             }
8532         }
8533     } err]} {
8534         # unfortunately we get both stdout and stderr in $err,
8535         # so look for "fatal:".
8536         set i [string first "fatal:" $err]
8537         if {$i > 0} {
8538             set err [string range $err [expr {$i + 6}] end]
8539         }
8540         show_error {} . "Bad arguments to gitk:\n$err"
8541         exit 1
8542     }
8545 if {$mergeonly} {
8546     # find the list of unmerged files
8547     set mlist {}
8548     set nr_unmerged 0
8549     if {[catch {
8550         set fd [open "| git ls-files -u" r]
8551     } err]} {
8552         show_error {} . "Couldn't get list of unmerged files: $err"
8553         exit 1
8554     }
8555     while {[gets $fd line] >= 0} {
8556         set i [string first "\t" $line]
8557         if {$i < 0} continue
8558         set fname [string range $line [expr {$i+1}] end]
8559         if {[lsearch -exact $mlist $fname] >= 0} continue
8560         incr nr_unmerged
8561         if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8562             lappend mlist $fname
8563         }
8564     }
8565     catch {close $fd}
8566     if {$mlist eq {}} {
8567         if {$nr_unmerged == 0} {
8568             show_error {} . "No files selected: --merge specified but\
8569                              no files are unmerged."
8570         } else {
8571             show_error {} . "No files selected: --merge specified but\
8572                              no unmerged files are within file limit."
8573         }
8574         exit 1
8575     }
8576     set cmdline_files $mlist
8579 set nullid "0000000000000000000000000000000000000000"
8580 set nullid2 "0000000000000000000000000000000000000001"
8582 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8584 set runq {}
8585 set history {}
8586 set historyindex 0
8587 set fh_serial 0
8588 set nhl_names {}
8589 set highlight_paths {}
8590 set findpattern {}
8591 set searchdirn -forwards
8592 set boldrows {}
8593 set boldnamerows {}
8594 set diffelide {0 0}
8595 set markingmatches 0
8596 set linkentercount 0
8597 set need_redisplay 0
8598 set nrows_drawn 0
8599 set firsttabstop 0
8601 set nextviewnum 1
8602 set curview 0
8603 set selectedview 0
8604 set selectedhlview None
8605 set highlight_related None
8606 set highlight_files {}
8607 set viewfiles(0) {}
8608 set viewperm(0) 0
8609 set viewargs(0) {}
8611 set cmdlineok 0
8612 set stopped 0
8613 set stuffsaved 0
8614 set patchnum 0
8615 set localirow -1
8616 set localfrow -1
8617 set lserial 0
8618 setcoords
8619 makewindow
8620 # wait for the window to become visible
8621 tkwait visibility .
8622 wm title . "[file tail $argv0]: [file tail [pwd]]"
8623 readrefs
8625 if {$cmdline_files ne {} || $revtreeargs ne {}} {
8626     # create a view for the files/dirs specified on the command line
8627     set curview 1
8628     set selectedview 1
8629     set nextviewnum 2
8630     set viewname(1) "Command line"
8631     set viewfiles(1) $cmdline_files
8632     set viewargs(1) $revtreeargs
8633     set viewperm(1) 0
8634     addviewmenu 1
8635     .bar.view entryconf Edit* -state normal
8636     .bar.view entryconf Delete* -state normal
8639 if {[info exists permviews]} {
8640     foreach v $permviews {
8641         set n $nextviewnum
8642         incr nextviewnum
8643         set viewname($n) [lindex $v 0]
8644         set viewfiles($n) [lindex $v 1]
8645         set viewargs($n) [lindex $v 2]
8646         set viewperm($n) 1
8647         addviewmenu $n
8648     }
8650 getcommits