Code

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