Code

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