Code

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