Code

gitk: Disable "Reset %s branch to here" when on a detached head
[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         if {$mainhead ne {}} {
6020             $menu entryconfigure 7 -label [mc "Reset %s branch to here" $mainhead]
6021         } else {
6022             $menu entryconfigure 7 -label [mc "Detached head: can't reset" $mainhead] -state disabled
6023         }
6024     } else {
6025         set menu $fakerowmenu
6026     }
6027     $menu entryconfigure [mc "Diff this -> selected"] -state $state
6028     $menu entryconfigure [mc "Diff selected -> this"] -state $state
6029     $menu entryconfigure [mc "Make patch"] -state $state
6030     tk_popup $menu $x $y
6033 proc diffvssel {dirn} {
6034     global rowmenuid selectedline displayorder
6036     if {![info exists selectedline]} return
6037     if {$dirn} {
6038         set oldid [lindex $displayorder $selectedline]
6039         set newid $rowmenuid
6040     } else {
6041         set oldid $rowmenuid
6042         set newid [lindex $displayorder $selectedline]
6043     }
6044     addtohistory [list doseldiff $oldid $newid]
6045     doseldiff $oldid $newid
6048 proc doseldiff {oldid newid} {
6049     global ctext
6050     global commitinfo
6052     $ctext conf -state normal
6053     clear_ctext
6054     init_flist [mc "Top"]
6055     $ctext insert end "[mc "From"] "
6056     $ctext insert end $oldid link0
6057     setlink $oldid link0
6058     $ctext insert end "\n     "
6059     $ctext insert end [lindex $commitinfo($oldid) 0]
6060     $ctext insert end "\n\n[mc "To"]   "
6061     $ctext insert end $newid link1
6062     setlink $newid link1
6063     $ctext insert end "\n     "
6064     $ctext insert end [lindex $commitinfo($newid) 0]
6065     $ctext insert end "\n"
6066     $ctext conf -state disabled
6067     $ctext tag remove found 1.0 end
6068     startdiff [list $oldid $newid]
6071 proc mkpatch {} {
6072     global rowmenuid currentid commitinfo patchtop patchnum
6074     if {![info exists currentid]} return
6075     set oldid $currentid
6076     set oldhead [lindex $commitinfo($oldid) 0]
6077     set newid $rowmenuid
6078     set newhead [lindex $commitinfo($newid) 0]
6079     set top .patch
6080     set patchtop $top
6081     catch {destroy $top}
6082     toplevel $top
6083     label $top.title -text [mc "Generate patch"]
6084     grid $top.title - -pady 10
6085     label $top.from -text [mc "From:"]
6086     entry $top.fromsha1 -width 40 -relief flat
6087     $top.fromsha1 insert 0 $oldid
6088     $top.fromsha1 conf -state readonly
6089     grid $top.from $top.fromsha1 -sticky w
6090     entry $top.fromhead -width 60 -relief flat
6091     $top.fromhead insert 0 $oldhead
6092     $top.fromhead conf -state readonly
6093     grid x $top.fromhead -sticky w
6094     label $top.to -text [mc "To:"]
6095     entry $top.tosha1 -width 40 -relief flat
6096     $top.tosha1 insert 0 $newid
6097     $top.tosha1 conf -state readonly
6098     grid $top.to $top.tosha1 -sticky w
6099     entry $top.tohead -width 60 -relief flat
6100     $top.tohead insert 0 $newhead
6101     $top.tohead conf -state readonly
6102     grid x $top.tohead -sticky w
6103     button $top.rev -text [mc "Reverse"] -command mkpatchrev -padx 5
6104     grid $top.rev x -pady 10
6105     label $top.flab -text [mc "Output file:"]
6106     entry $top.fname -width 60
6107     $top.fname insert 0 [file normalize "patch$patchnum.patch"]
6108     incr patchnum
6109     grid $top.flab $top.fname -sticky w
6110     frame $top.buts
6111     button $top.buts.gen -text [mc "Generate"] -command mkpatchgo
6112     button $top.buts.can -text [mc "Cancel"] -command mkpatchcan
6113     grid $top.buts.gen $top.buts.can
6114     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6115     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6116     grid $top.buts - -pady 10 -sticky ew
6117     focus $top.fname
6120 proc mkpatchrev {} {
6121     global patchtop
6123     set oldid [$patchtop.fromsha1 get]
6124     set oldhead [$patchtop.fromhead get]
6125     set newid [$patchtop.tosha1 get]
6126     set newhead [$patchtop.tohead get]
6127     foreach e [list fromsha1 fromhead tosha1 tohead] \
6128             v [list $newid $newhead $oldid $oldhead] {
6129         $patchtop.$e conf -state normal
6130         $patchtop.$e delete 0 end
6131         $patchtop.$e insert 0 $v
6132         $patchtop.$e conf -state readonly
6133     }
6136 proc mkpatchgo {} {
6137     global patchtop nullid nullid2
6139     set oldid [$patchtop.fromsha1 get]
6140     set newid [$patchtop.tosha1 get]
6141     set fname [$patchtop.fname get]
6142     set cmd [diffcmd [list $oldid $newid] -p]
6143     # trim off the initial "|"
6144     set cmd [lrange $cmd 1 end]
6145     lappend cmd >$fname &
6146     if {[catch {eval exec $cmd} err]} {
6147         error_popup "[mc "Error creating patch:"] $err"
6148     }
6149     catch {destroy $patchtop}
6150     unset patchtop
6153 proc mkpatchcan {} {
6154     global patchtop
6156     catch {destroy $patchtop}
6157     unset patchtop
6160 proc mktag {} {
6161     global rowmenuid mktagtop commitinfo
6163     set top .maketag
6164     set mktagtop $top
6165     catch {destroy $top}
6166     toplevel $top
6167     label $top.title -text [mc "Create tag"]
6168     grid $top.title - -pady 10
6169     label $top.id -text [mc "ID:"]
6170     entry $top.sha1 -width 40 -relief flat
6171     $top.sha1 insert 0 $rowmenuid
6172     $top.sha1 conf -state readonly
6173     grid $top.id $top.sha1 -sticky w
6174     entry $top.head -width 60 -relief flat
6175     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6176     $top.head conf -state readonly
6177     grid x $top.head -sticky w
6178     label $top.tlab -text [mc "Tag name:"]
6179     entry $top.tag -width 60
6180     grid $top.tlab $top.tag -sticky w
6181     frame $top.buts
6182     button $top.buts.gen -text [mc "Create"] -command mktaggo
6183     button $top.buts.can -text [mc "Cancel"] -command mktagcan
6184     grid $top.buts.gen $top.buts.can
6185     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6186     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6187     grid $top.buts - -pady 10 -sticky ew
6188     focus $top.tag
6191 proc domktag {} {
6192     global mktagtop env tagids idtags
6194     set id [$mktagtop.sha1 get]
6195     set tag [$mktagtop.tag get]
6196     if {$tag == {}} {
6197         error_popup [mc "No tag name specified"]
6198         return
6199     }
6200     if {[info exists tagids($tag)]} {
6201         error_popup [mc "Tag \"%s\" already exists" $tag]
6202         return
6203     }
6204     if {[catch {
6205         exec git tag $tag $id
6206     } err]} {
6207         error_popup "[mc "Error creating tag:"] $err"
6208         return
6209     }
6211     set tagids($tag) $id
6212     lappend idtags($id) $tag
6213     redrawtags $id
6214     addedtag $id
6215     dispneartags 0
6216     run refill_reflist
6219 proc redrawtags {id} {
6220     global canv linehtag commitrow idpos selectedline curview
6221     global canvxmax iddrawn
6223     if {![info exists commitrow($curview,$id)]} return
6224     if {![info exists iddrawn($id)]} return
6225     drawcommits $commitrow($curview,$id)
6226     $canv delete tag.$id
6227     set xt [eval drawtags $id $idpos($id)]
6228     $canv coords $linehtag($commitrow($curview,$id)) $xt [lindex $idpos($id) 2]
6229     set text [$canv itemcget $linehtag($commitrow($curview,$id)) -text]
6230     set xr [expr {$xt + [font measure mainfont $text]}]
6231     if {$xr > $canvxmax} {
6232         set canvxmax $xr
6233         setcanvscroll
6234     }
6235     if {[info exists selectedline]
6236         && $selectedline == $commitrow($curview,$id)} {
6237         selectline $selectedline 0
6238     }
6241 proc mktagcan {} {
6242     global mktagtop
6244     catch {destroy $mktagtop}
6245     unset mktagtop
6248 proc mktaggo {} {
6249     domktag
6250     mktagcan
6253 proc writecommit {} {
6254     global rowmenuid wrcomtop commitinfo wrcomcmd
6256     set top .writecommit
6257     set wrcomtop $top
6258     catch {destroy $top}
6259     toplevel $top
6260     label $top.title -text [mc "Write commit to file"]
6261     grid $top.title - -pady 10
6262     label $top.id -text [mc "ID:"]
6263     entry $top.sha1 -width 40 -relief flat
6264     $top.sha1 insert 0 $rowmenuid
6265     $top.sha1 conf -state readonly
6266     grid $top.id $top.sha1 -sticky w
6267     entry $top.head -width 60 -relief flat
6268     $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
6269     $top.head conf -state readonly
6270     grid x $top.head -sticky w
6271     label $top.clab -text [mc "Command:"]
6272     entry $top.cmd -width 60 -textvariable wrcomcmd
6273     grid $top.clab $top.cmd -sticky w -pady 10
6274     label $top.flab -text [mc "Output file:"]
6275     entry $top.fname -width 60
6276     $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
6277     grid $top.flab $top.fname -sticky w
6278     frame $top.buts
6279     button $top.buts.gen -text [mc "Write"] -command wrcomgo
6280     button $top.buts.can -text [mc "Cancel"] -command wrcomcan
6281     grid $top.buts.gen $top.buts.can
6282     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6283     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6284     grid $top.buts - -pady 10 -sticky ew
6285     focus $top.fname
6288 proc wrcomgo {} {
6289     global wrcomtop
6291     set id [$wrcomtop.sha1 get]
6292     set cmd "echo $id | [$wrcomtop.cmd get]"
6293     set fname [$wrcomtop.fname get]
6294     if {[catch {exec sh -c $cmd >$fname &} err]} {
6295         error_popup "[mc "Error writing commit:"] $err"
6296     }
6297     catch {destroy $wrcomtop}
6298     unset wrcomtop
6301 proc wrcomcan {} {
6302     global wrcomtop
6304     catch {destroy $wrcomtop}
6305     unset wrcomtop
6308 proc mkbranch {} {
6309     global rowmenuid mkbrtop
6311     set top .makebranch
6312     catch {destroy $top}
6313     toplevel $top
6314     label $top.title -text [mc "Create new branch"]
6315     grid $top.title - -pady 10
6316     label $top.id -text [mc "ID:"]
6317     entry $top.sha1 -width 40 -relief flat
6318     $top.sha1 insert 0 $rowmenuid
6319     $top.sha1 conf -state readonly
6320     grid $top.id $top.sha1 -sticky w
6321     label $top.nlab -text [mc "Name:"]
6322     entry $top.name -width 40
6323     grid $top.nlab $top.name -sticky w
6324     frame $top.buts
6325     button $top.buts.go -text [mc "Create"] -command [list mkbrgo $top]
6326     button $top.buts.can -text [mc "Cancel"] -command "catch {destroy $top}"
6327     grid $top.buts.go $top.buts.can
6328     grid columnconfigure $top.buts 0 -weight 1 -uniform a
6329     grid columnconfigure $top.buts 1 -weight 1 -uniform a
6330     grid $top.buts - -pady 10 -sticky ew
6331     focus $top.name
6334 proc mkbrgo {top} {
6335     global headids idheads
6337     set name [$top.name get]
6338     set id [$top.sha1 get]
6339     if {$name eq {}} {
6340         error_popup [mc "Please specify a name for the new branch"]
6341         return
6342     }
6343     catch {destroy $top}
6344     nowbusy newbranch
6345     update
6346     if {[catch {
6347         exec git branch $name $id
6348     } err]} {
6349         notbusy newbranch
6350         error_popup $err
6351     } else {
6352         set headids($name) $id
6353         lappend idheads($id) $name
6354         addedhead $id $name
6355         notbusy newbranch
6356         redrawtags $id
6357         dispneartags 0
6358         run refill_reflist
6359     }
6362 proc cherrypick {} {
6363     global rowmenuid curview commitrow
6364     global mainhead
6366     set oldhead [exec git rev-parse HEAD]
6367     set dheads [descheads $rowmenuid]
6368     if {$dheads ne {} && [lsearch -exact $dheads $oldhead] >= 0} {
6369         set ok [confirm_popup [mc "Commit %s is already\
6370                 included in branch %s -- really re-apply it?" \
6371                                    [string range $rowmenuid 0 7] $mainhead]]
6372         if {!$ok} return
6373     }
6374     nowbusy cherrypick [mc "Cherry-picking"]
6375     update
6376     # Unfortunately git-cherry-pick writes stuff to stderr even when
6377     # no error occurs, and exec takes that as an indication of error...
6378     if {[catch {exec sh -c "git cherry-pick -r $rowmenuid 2>&1"} err]} {
6379         notbusy cherrypick
6380         error_popup $err
6381         return
6382     }
6383     set newhead [exec git rev-parse HEAD]
6384     if {$newhead eq $oldhead} {
6385         notbusy cherrypick
6386         error_popup [mc "No changes committed"]
6387         return
6388     }
6389     addnewchild $newhead $oldhead
6390     if {[info exists commitrow($curview,$oldhead)]} {
6391         insertrow $commitrow($curview,$oldhead) $newhead
6392         if {$mainhead ne {}} {
6393             movehead $newhead $mainhead
6394             movedhead $newhead $mainhead
6395         }
6396         redrawtags $oldhead
6397         redrawtags $newhead
6398     }
6399     notbusy cherrypick
6402 proc resethead {} {
6403     global mainheadid mainhead rowmenuid confirm_ok resettype
6405     set confirm_ok 0
6406     set w ".confirmreset"
6407     toplevel $w
6408     wm transient $w .
6409     wm title $w [mc "Confirm reset"]
6410     message $w.m -text \
6411         [mc "Reset branch %s to %s?" $mainhead [string range $rowmenuid 0 7]] \
6412         -justify center -aspect 1000
6413     pack $w.m -side top -fill x -padx 20 -pady 20
6414     frame $w.f -relief sunken -border 2
6415     message $w.f.rt -text [mc "Reset type:"] -aspect 1000
6416     grid $w.f.rt -sticky w
6417     set resettype mixed
6418     radiobutton $w.f.soft -value soft -variable resettype -justify left \
6419         -text [mc "Soft: Leave working tree and index untouched"]
6420     grid $w.f.soft -sticky w
6421     radiobutton $w.f.mixed -value mixed -variable resettype -justify left \
6422         -text [mc "Mixed: Leave working tree untouched, reset index"]
6423     grid $w.f.mixed -sticky w
6424     radiobutton $w.f.hard -value hard -variable resettype -justify left \
6425         -text [mc "Hard: Reset working tree and index\n(discard ALL local changes)"]
6426     grid $w.f.hard -sticky w
6427     pack $w.f -side top -fill x
6428     button $w.ok -text [mc OK] -command "set confirm_ok 1; destroy $w"
6429     pack $w.ok -side left -fill x -padx 20 -pady 20
6430     button $w.cancel -text [mc Cancel] -command "destroy $w"
6431     pack $w.cancel -side right -fill x -padx 20 -pady 20
6432     bind $w <Visibility> "grab $w; focus $w"
6433     tkwait window $w
6434     if {!$confirm_ok} return
6435     if {[catch {set fd [open \
6436             [list | sh -c "git reset --$resettype $rowmenuid 2>&1"] r]} err]} {
6437         error_popup $err
6438     } else {
6439         dohidelocalchanges
6440         filerun $fd [list readresetstat $fd]
6441         nowbusy reset [mc "Resetting"]
6442     }
6445 proc readresetstat {fd} {
6446     global mainhead mainheadid showlocalchanges rprogcoord
6448     if {[gets $fd line] >= 0} {
6449         if {[regexp {([0-9]+)% \(([0-9]+)/([0-9]+)\)} $line match p m n]} {
6450             set rprogcoord [expr {1.0 * $m / $n}]
6451             adjustprogress
6452         }
6453         return 1
6454     }
6455     set rprogcoord 0
6456     adjustprogress
6457     notbusy reset
6458     if {[catch {close $fd} err]} {
6459         error_popup $err
6460     }
6461     set oldhead $mainheadid
6462     set newhead [exec git rev-parse HEAD]
6463     if {$newhead ne $oldhead} {
6464         movehead $newhead $mainhead
6465         movedhead $newhead $mainhead
6466         set mainheadid $newhead
6467         redrawtags $oldhead
6468         redrawtags $newhead
6469     }
6470     if {$showlocalchanges} {
6471         doshowlocalchanges
6472     }
6473     return 0
6476 # context menu for a head
6477 proc headmenu {x y id head} {
6478     global headmenuid headmenuhead headctxmenu mainhead
6480     stopfinding
6481     set headmenuid $id
6482     set headmenuhead $head
6483     set state normal
6484     if {$head eq $mainhead} {
6485         set state disabled
6486     }
6487     $headctxmenu entryconfigure 0 -state $state
6488     $headctxmenu entryconfigure 1 -state $state
6489     tk_popup $headctxmenu $x $y
6492 proc cobranch {} {
6493     global headmenuid headmenuhead mainhead headids
6494     global showlocalchanges mainheadid
6496     # check the tree is clean first??
6497     set oldmainhead $mainhead
6498     nowbusy checkout [mc "Checking out"]
6499     update
6500     dohidelocalchanges
6501     if {[catch {
6502         exec git checkout -q $headmenuhead
6503     } err]} {
6504         notbusy checkout
6505         error_popup $err
6506     } else {
6507         notbusy checkout
6508         set mainhead $headmenuhead
6509         set mainheadid $headmenuid
6510         if {[info exists headids($oldmainhead)]} {
6511             redrawtags $headids($oldmainhead)
6512         }
6513         redrawtags $headmenuid
6514     }
6515     if {$showlocalchanges} {
6516         dodiffindex
6517     }
6520 proc rmbranch {} {
6521     global headmenuid headmenuhead mainhead
6522     global idheads
6524     set head $headmenuhead
6525     set id $headmenuid
6526     # this check shouldn't be needed any more...
6527     if {$head eq $mainhead} {
6528         error_popup [mc "Cannot delete the currently checked-out branch"]
6529         return
6530     }
6531     set dheads [descheads $id]
6532     if {[llength $dheads] == 1 && $idheads($dheads) eq $head} {
6533         # the stuff on this branch isn't on any other branch
6534         if {![confirm_popup [mc "The commits on branch %s aren't on any other\
6535                         branch.\nReally delete branch %s?" $head $head]]} return
6536     }
6537     nowbusy rmbranch
6538     update
6539     if {[catch {exec git branch -D $head} err]} {
6540         notbusy rmbranch
6541         error_popup $err
6542         return
6543     }
6544     removehead $id $head
6545     removedhead $id $head
6546     redrawtags $id
6547     notbusy rmbranch
6548     dispneartags 0
6549     run refill_reflist
6552 # Display a list of tags and heads
6553 proc showrefs {} {
6554     global showrefstop bgcolor fgcolor selectbgcolor
6555     global bglist fglist reflistfilter reflist maincursor
6557     set top .showrefs
6558     set showrefstop $top
6559     if {[winfo exists $top]} {
6560         raise $top
6561         refill_reflist
6562         return
6563     }
6564     toplevel $top
6565     wm title $top [mc "Tags and heads: %s" [file tail [pwd]]]
6566     text $top.list -background $bgcolor -foreground $fgcolor \
6567         -selectbackground $selectbgcolor -font mainfont \
6568         -xscrollcommand "$top.xsb set" -yscrollcommand "$top.ysb set" \
6569         -width 30 -height 20 -cursor $maincursor \
6570         -spacing1 1 -spacing3 1 -state disabled
6571     $top.list tag configure highlight -background $selectbgcolor
6572     lappend bglist $top.list
6573     lappend fglist $top.list
6574     scrollbar $top.ysb -command "$top.list yview" -orient vertical
6575     scrollbar $top.xsb -command "$top.list xview" -orient horizontal
6576     grid $top.list $top.ysb -sticky nsew
6577     grid $top.xsb x -sticky ew
6578     frame $top.f
6579     label $top.f.l -text "[mc "Filter"]: "
6580     entry $top.f.e -width 20 -textvariable reflistfilter
6581     set reflistfilter "*"
6582     trace add variable reflistfilter write reflistfilter_change
6583     pack $top.f.e -side right -fill x -expand 1
6584     pack $top.f.l -side left
6585     grid $top.f - -sticky ew -pady 2
6586     button $top.close -command [list destroy $top] -text [mc "Close"]
6587     grid $top.close -
6588     grid columnconfigure $top 0 -weight 1
6589     grid rowconfigure $top 0 -weight 1
6590     bind $top.list <1> {break}
6591     bind $top.list <B1-Motion> {break}
6592     bind $top.list <ButtonRelease-1> {sel_reflist %W %x %y; break}
6593     set reflist {}
6594     refill_reflist
6597 proc sel_reflist {w x y} {
6598     global showrefstop reflist headids tagids otherrefids
6600     if {![winfo exists $showrefstop]} return
6601     set l [lindex [split [$w index "@$x,$y"] "."] 0]
6602     set ref [lindex $reflist [expr {$l-1}]]
6603     set n [lindex $ref 0]
6604     switch -- [lindex $ref 1] {
6605         "H" {selbyid $headids($n)}
6606         "T" {selbyid $tagids($n)}
6607         "o" {selbyid $otherrefids($n)}
6608     }
6609     $showrefstop.list tag add highlight $l.0 "$l.0 lineend"
6612 proc unsel_reflist {} {
6613     global showrefstop
6615     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6616     $showrefstop.list tag remove highlight 0.0 end
6619 proc reflistfilter_change {n1 n2 op} {
6620     global reflistfilter
6622     after cancel refill_reflist
6623     after 200 refill_reflist
6626 proc refill_reflist {} {
6627     global reflist reflistfilter showrefstop headids tagids otherrefids
6628     global commitrow curview commitinterest
6630     if {![info exists showrefstop] || ![winfo exists $showrefstop]} return
6631     set refs {}
6632     foreach n [array names headids] {
6633         if {[string match $reflistfilter $n]} {
6634             if {[info exists commitrow($curview,$headids($n))]} {
6635                 lappend refs [list $n H]
6636             } else {
6637                 set commitinterest($headids($n)) {run refill_reflist}
6638             }
6639         }
6640     }
6641     foreach n [array names tagids] {
6642         if {[string match $reflistfilter $n]} {
6643             if {[info exists commitrow($curview,$tagids($n))]} {
6644                 lappend refs [list $n T]
6645             } else {
6646                 set commitinterest($tagids($n)) {run refill_reflist}
6647             }
6648         }
6649     }
6650     foreach n [array names otherrefids] {
6651         if {[string match $reflistfilter $n]} {
6652             if {[info exists commitrow($curview,$otherrefids($n))]} {
6653                 lappend refs [list $n o]
6654             } else {
6655                 set commitinterest($otherrefids($n)) {run refill_reflist}
6656             }
6657         }
6658     }
6659     set refs [lsort -index 0 $refs]
6660     if {$refs eq $reflist} return
6662     # Update the contents of $showrefstop.list according to the
6663     # differences between $reflist (old) and $refs (new)
6664     $showrefstop.list conf -state normal
6665     $showrefstop.list insert end "\n"
6666     set i 0
6667     set j 0
6668     while {$i < [llength $reflist] || $j < [llength $refs]} {
6669         if {$i < [llength $reflist]} {
6670             if {$j < [llength $refs]} {
6671                 set cmp [string compare [lindex $reflist $i 0] \
6672                              [lindex $refs $j 0]]
6673                 if {$cmp == 0} {
6674                     set cmp [string compare [lindex $reflist $i 1] \
6675                                  [lindex $refs $j 1]]
6676                 }
6677             } else {
6678                 set cmp -1
6679             }
6680         } else {
6681             set cmp 1
6682         }
6683         switch -- $cmp {
6684             -1 {
6685                 $showrefstop.list delete "[expr {$j+1}].0" "[expr {$j+2}].0"
6686                 incr i
6687             }
6688             0 {
6689                 incr i
6690                 incr j
6691             }
6692             1 {
6693                 set l [expr {$j + 1}]
6694                 $showrefstop.list image create $l.0 -align baseline \
6695                     -image reficon-[lindex $refs $j 1] -padx 2
6696                 $showrefstop.list insert $l.1 "[lindex $refs $j 0]\n"
6697                 incr j
6698             }
6699         }
6700     }
6701     set reflist $refs
6702     # delete last newline
6703     $showrefstop.list delete end-2c end-1c
6704     $showrefstop.list conf -state disabled
6707 # Stuff for finding nearby tags
6708 proc getallcommits {} {
6709     global allcommits nextarc seeds allccache allcwait cachedarcs allcupdate
6710     global idheads idtags idotherrefs allparents tagobjid
6712     if {![info exists allcommits]} {
6713         set nextarc 0
6714         set allcommits 0
6715         set seeds {}
6716         set allcwait 0
6717         set cachedarcs 0
6718         set allccache [file join [gitdir] "gitk.cache"]
6719         if {![catch {
6720             set f [open $allccache r]
6721             set allcwait 1
6722             getcache $f
6723         }]} return
6724     }
6726     if {$allcwait} {
6727         return
6728     }
6729     set cmd [list | git rev-list --parents]
6730     set allcupdate [expr {$seeds ne {}}]
6731     if {!$allcupdate} {
6732         set ids "--all"
6733     } else {
6734         set refs [concat [array names idheads] [array names idtags] \
6735                       [array names idotherrefs]]
6736         set ids {}
6737         set tagobjs {}
6738         foreach name [array names tagobjid] {
6739             lappend tagobjs $tagobjid($name)
6740         }
6741         foreach id [lsort -unique $refs] {
6742             if {![info exists allparents($id)] &&
6743                 [lsearch -exact $tagobjs $id] < 0} {
6744                 lappend ids $id
6745             }
6746         }
6747         if {$ids ne {}} {
6748             foreach id $seeds {
6749                 lappend ids "^$id"
6750             }
6751         }
6752     }
6753     if {$ids ne {}} {
6754         set fd [open [concat $cmd $ids] r]
6755         fconfigure $fd -blocking 0
6756         incr allcommits
6757         nowbusy allcommits
6758         filerun $fd [list getallclines $fd]
6759     } else {
6760         dispneartags 0
6761     }
6764 # Since most commits have 1 parent and 1 child, we group strings of
6765 # such commits into "arcs" joining branch/merge points (BMPs), which
6766 # are commits that either don't have 1 parent or don't have 1 child.
6768 # arcnos(id) - incoming arcs for BMP, arc we're on for other nodes
6769 # arcout(id) - outgoing arcs for BMP
6770 # arcids(a) - list of IDs on arc including end but not start
6771 # arcstart(a) - BMP ID at start of arc
6772 # arcend(a) - BMP ID at end of arc
6773 # growing(a) - arc a is still growing
6774 # arctags(a) - IDs out of arcids (excluding end) that have tags
6775 # archeads(a) - IDs out of arcids (excluding end) that have heads
6776 # The start of an arc is at the descendent end, so "incoming" means
6777 # coming from descendents, and "outgoing" means going towards ancestors.
6779 proc getallclines {fd} {
6780     global allparents allchildren idtags idheads nextarc
6781     global arcnos arcids arctags arcout arcend arcstart archeads growing
6782     global seeds allcommits cachedarcs allcupdate
6783     
6784     set nid 0
6785     while {[incr nid] <= 1000 && [gets $fd line] >= 0} {
6786         set id [lindex $line 0]
6787         if {[info exists allparents($id)]} {
6788             # seen it already
6789             continue
6790         }
6791         set cachedarcs 0
6792         set olds [lrange $line 1 end]
6793         set allparents($id) $olds
6794         if {![info exists allchildren($id)]} {
6795             set allchildren($id) {}
6796             set arcnos($id) {}
6797             lappend seeds $id
6798         } else {
6799             set a $arcnos($id)
6800             if {[llength $olds] == 1 && [llength $a] == 1} {
6801                 lappend arcids($a) $id
6802                 if {[info exists idtags($id)]} {
6803                     lappend arctags($a) $id
6804                 }
6805                 if {[info exists idheads($id)]} {
6806                     lappend archeads($a) $id
6807                 }
6808                 if {[info exists allparents($olds)]} {
6809                     # seen parent already
6810                     if {![info exists arcout($olds)]} {
6811                         splitarc $olds
6812                     }
6813                     lappend arcids($a) $olds
6814                     set arcend($a) $olds
6815                     unset growing($a)
6816                 }
6817                 lappend allchildren($olds) $id
6818                 lappend arcnos($olds) $a
6819                 continue
6820             }
6821         }
6822         foreach a $arcnos($id) {
6823             lappend arcids($a) $id
6824             set arcend($a) $id
6825             unset growing($a)
6826         }
6828         set ao {}
6829         foreach p $olds {
6830             lappend allchildren($p) $id
6831             set a [incr nextarc]
6832             set arcstart($a) $id
6833             set archeads($a) {}
6834             set arctags($a) {}
6835             set archeads($a) {}
6836             set arcids($a) {}
6837             lappend ao $a
6838             set growing($a) 1
6839             if {[info exists allparents($p)]} {
6840                 # seen it already, may need to make a new branch
6841                 if {![info exists arcout($p)]} {
6842                     splitarc $p
6843                 }
6844                 lappend arcids($a) $p
6845                 set arcend($a) $p
6846                 unset growing($a)
6847             }
6848             lappend arcnos($p) $a
6849         }
6850         set arcout($id) $ao
6851     }
6852     if {$nid > 0} {
6853         global cached_dheads cached_dtags cached_atags
6854         catch {unset cached_dheads}
6855         catch {unset cached_dtags}
6856         catch {unset cached_atags}
6857     }
6858     if {![eof $fd]} {
6859         return [expr {$nid >= 1000? 2: 1}]
6860     }
6861     set cacheok 1
6862     if {[catch {
6863         fconfigure $fd -blocking 1
6864         close $fd
6865     } err]} {
6866         # got an error reading the list of commits
6867         # if we were updating, try rereading the whole thing again
6868         if {$allcupdate} {
6869             incr allcommits -1
6870             dropcache $err
6871             return
6872         }
6873         error_popup "[mc "Error reading commit topology information;\
6874                 branch and preceding/following tag information\
6875                 will be incomplete."]\n($err)"
6876         set cacheok 0
6877     }
6878     if {[incr allcommits -1] == 0} {
6879         notbusy allcommits
6880         if {$cacheok} {
6881             run savecache
6882         }
6883     }
6884     dispneartags 0
6885     return 0
6888 proc recalcarc {a} {
6889     global arctags archeads arcids idtags idheads
6891     set at {}
6892     set ah {}
6893     foreach id [lrange $arcids($a) 0 end-1] {
6894         if {[info exists idtags($id)]} {
6895             lappend at $id
6896         }
6897         if {[info exists idheads($id)]} {
6898             lappend ah $id
6899         }
6900     }
6901     set arctags($a) $at
6902     set archeads($a) $ah
6905 proc splitarc {p} {
6906     global arcnos arcids nextarc arctags archeads idtags idheads
6907     global arcstart arcend arcout allparents growing
6909     set a $arcnos($p)
6910     if {[llength $a] != 1} {
6911         puts "oops splitarc called but [llength $a] arcs already"
6912         return
6913     }
6914     set a [lindex $a 0]
6915     set i [lsearch -exact $arcids($a) $p]
6916     if {$i < 0} {
6917         puts "oops splitarc $p not in arc $a"
6918         return
6919     }
6920     set na [incr nextarc]
6921     if {[info exists arcend($a)]} {
6922         set arcend($na) $arcend($a)
6923     } else {
6924         set l [lindex $allparents([lindex $arcids($a) end]) 0]
6925         set j [lsearch -exact $arcnos($l) $a]
6926         set arcnos($l) [lreplace $arcnos($l) $j $j $na]
6927     }
6928     set tail [lrange $arcids($a) [expr {$i+1}] end]
6929     set arcids($a) [lrange $arcids($a) 0 $i]
6930     set arcend($a) $p
6931     set arcstart($na) $p
6932     set arcout($p) $na
6933     set arcids($na) $tail
6934     if {[info exists growing($a)]} {
6935         set growing($na) 1
6936         unset growing($a)
6937     }
6939     foreach id $tail {
6940         if {[llength $arcnos($id)] == 1} {
6941             set arcnos($id) $na
6942         } else {
6943             set j [lsearch -exact $arcnos($id) $a]
6944             set arcnos($id) [lreplace $arcnos($id) $j $j $na]
6945         }
6946     }
6948     # reconstruct tags and heads lists
6949     if {$arctags($a) ne {} || $archeads($a) ne {}} {
6950         recalcarc $a
6951         recalcarc $na
6952     } else {
6953         set arctags($na) {}
6954         set archeads($na) {}
6955     }
6958 # Update things for a new commit added that is a child of one
6959 # existing commit.  Used when cherry-picking.
6960 proc addnewchild {id p} {
6961     global allparents allchildren idtags nextarc
6962     global arcnos arcids arctags arcout arcend arcstart archeads growing
6963     global seeds allcommits
6965     if {![info exists allcommits] || ![info exists arcnos($p)]} return
6966     set allparents($id) [list $p]
6967     set allchildren($id) {}
6968     set arcnos($id) {}
6969     lappend seeds $id
6970     lappend allchildren($p) $id
6971     set a [incr nextarc]
6972     set arcstart($a) $id
6973     set archeads($a) {}
6974     set arctags($a) {}
6975     set arcids($a) [list $p]
6976     set arcend($a) $p
6977     if {![info exists arcout($p)]} {
6978         splitarc $p
6979     }
6980     lappend arcnos($p) $a
6981     set arcout($id) [list $a]
6984 # This implements a cache for the topology information.
6985 # The cache saves, for each arc, the start and end of the arc,
6986 # the ids on the arc, and the outgoing arcs from the end.
6987 proc readcache {f} {
6988     global arcnos arcids arcout arcstart arcend arctags archeads nextarc
6989     global idtags idheads allparents cachedarcs possible_seeds seeds growing
6990     global allcwait
6992     set a $nextarc
6993     set lim $cachedarcs
6994     if {$lim - $a > 500} {
6995         set lim [expr {$a + 500}]
6996     }
6997     if {[catch {
6998         if {$a == $lim} {
6999             # finish reading the cache and setting up arctags, etc.
7000             set line [gets $f]
7001             if {$line ne "1"} {error "bad final version"}
7002             close $f
7003             foreach id [array names idtags] {
7004                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7005                     [llength $allparents($id)] == 1} {
7006                     set a [lindex $arcnos($id) 0]
7007                     if {$arctags($a) eq {}} {
7008                         recalcarc $a
7009                     }
7010                 }
7011             }
7012             foreach id [array names idheads] {
7013                 if {[info exists arcnos($id)] && [llength $arcnos($id)] == 1 &&
7014                     [llength $allparents($id)] == 1} {
7015                     set a [lindex $arcnos($id) 0]
7016                     if {$archeads($a) eq {}} {
7017                         recalcarc $a
7018                     }
7019                 }
7020             }
7021             foreach id [lsort -unique $possible_seeds] {
7022                 if {$arcnos($id) eq {}} {
7023                     lappend seeds $id
7024                 }
7025             }
7026             set allcwait 0
7027         } else {
7028             while {[incr a] <= $lim} {
7029                 set line [gets $f]
7030                 if {[llength $line] != 3} {error "bad line"}
7031                 set s [lindex $line 0]
7032                 set arcstart($a) $s
7033                 lappend arcout($s) $a
7034                 if {![info exists arcnos($s)]} {
7035                     lappend possible_seeds $s
7036                     set arcnos($s) {}
7037                 }
7038                 set e [lindex $line 1]
7039                 if {$e eq {}} {
7040                     set growing($a) 1
7041                 } else {
7042                     set arcend($a) $e
7043                     if {![info exists arcout($e)]} {
7044                         set arcout($e) {}
7045                     }
7046                 }
7047                 set arcids($a) [lindex $line 2]
7048                 foreach id $arcids($a) {
7049                     lappend allparents($s) $id
7050                     set s $id
7051                     lappend arcnos($id) $a
7052                 }
7053                 if {![info exists allparents($s)]} {
7054                     set allparents($s) {}
7055                 }
7056                 set arctags($a) {}
7057                 set archeads($a) {}
7058             }
7059             set nextarc [expr {$a - 1}]
7060         }
7061     } err]} {
7062         dropcache $err
7063         return 0
7064     }
7065     if {!$allcwait} {
7066         getallcommits
7067     }
7068     return $allcwait
7071 proc getcache {f} {
7072     global nextarc cachedarcs possible_seeds
7074     if {[catch {
7075         set line [gets $f]
7076         if {[llength $line] != 2 || [lindex $line 0] ne "1"} {error "bad version"}
7077         # make sure it's an integer
7078         set cachedarcs [expr {int([lindex $line 1])}]
7079         if {$cachedarcs < 0} {error "bad number of arcs"}
7080         set nextarc 0
7081         set possible_seeds {}
7082         run readcache $f
7083     } err]} {
7084         dropcache $err
7085     }
7086     return 0
7089 proc dropcache {err} {
7090     global allcwait nextarc cachedarcs seeds
7092     #puts "dropping cache ($err)"
7093     foreach v {arcnos arcout arcids arcstart arcend growing \
7094                    arctags archeads allparents allchildren} {
7095         global $v
7096         catch {unset $v}
7097     }
7098     set allcwait 0
7099     set nextarc 0
7100     set cachedarcs 0
7101     set seeds {}
7102     getallcommits
7105 proc writecache {f} {
7106     global cachearc cachedarcs allccache
7107     global arcstart arcend arcnos arcids arcout
7109     set a $cachearc
7110     set lim $cachedarcs
7111     if {$lim - $a > 1000} {
7112         set lim [expr {$a + 1000}]
7113     }
7114     if {[catch {
7115         while {[incr a] <= $lim} {
7116             if {[info exists arcend($a)]} {
7117                 puts $f [list $arcstart($a) $arcend($a) $arcids($a)]
7118             } else {
7119                 puts $f [list $arcstart($a) {} $arcids($a)]
7120             }
7121         }
7122     } err]} {
7123         catch {close $f}
7124         catch {file delete $allccache}
7125         #puts "writing cache failed ($err)"
7126         return 0
7127     }
7128     set cachearc [expr {$a - 1}]
7129     if {$a > $cachedarcs} {
7130         puts $f "1"
7131         close $f
7132         return 0
7133     }
7134     return 1
7137 proc savecache {} {
7138     global nextarc cachedarcs cachearc allccache
7140     if {$nextarc == $cachedarcs} return
7141     set cachearc 0
7142     set cachedarcs $nextarc
7143     catch {
7144         set f [open $allccache w]
7145         puts $f [list 1 $cachedarcs]
7146         run writecache $f
7147     }
7150 # Returns 1 if a is an ancestor of b, -1 if b is an ancestor of a,
7151 # or 0 if neither is true.
7152 proc anc_or_desc {a b} {
7153     global arcout arcstart arcend arcnos cached_isanc
7155     if {$arcnos($a) eq $arcnos($b)} {
7156         # Both are on the same arc(s); either both are the same BMP,
7157         # or if one is not a BMP, the other is also not a BMP or is
7158         # the BMP at end of the arc (and it only has 1 incoming arc).
7159         # Or both can be BMPs with no incoming arcs.
7160         if {$a eq $b || $arcnos($a) eq {}} {
7161             return 0
7162         }
7163         # assert {[llength $arcnos($a)] == 1}
7164         set arc [lindex $arcnos($a) 0]
7165         set i [lsearch -exact $arcids($arc) $a]
7166         set j [lsearch -exact $arcids($arc) $b]
7167         if {$i < 0 || $i > $j} {
7168             return 1
7169         } else {
7170             return -1
7171         }
7172     }
7174     if {![info exists arcout($a)]} {
7175         set arc [lindex $arcnos($a) 0]
7176         if {[info exists arcend($arc)]} {
7177             set aend $arcend($arc)
7178         } else {
7179             set aend {}
7180         }
7181         set a $arcstart($arc)
7182     } else {
7183         set aend $a
7184     }
7185     if {![info exists arcout($b)]} {
7186         set arc [lindex $arcnos($b) 0]
7187         if {[info exists arcend($arc)]} {
7188             set bend $arcend($arc)
7189         } else {
7190             set bend {}
7191         }
7192         set b $arcstart($arc)
7193     } else {
7194         set bend $b
7195     }
7196     if {$a eq $bend} {
7197         return 1
7198     }
7199     if {$b eq $aend} {
7200         return -1
7201     }
7202     if {[info exists cached_isanc($a,$bend)]} {
7203         if {$cached_isanc($a,$bend)} {
7204             return 1
7205         }
7206     }
7207     if {[info exists cached_isanc($b,$aend)]} {
7208         if {$cached_isanc($b,$aend)} {
7209             return -1
7210         }
7211         if {[info exists cached_isanc($a,$bend)]} {
7212             return 0
7213         }
7214     }
7216     set todo [list $a $b]
7217     set anc($a) a
7218     set anc($b) b
7219     for {set i 0} {$i < [llength $todo]} {incr i} {
7220         set x [lindex $todo $i]
7221         if {$anc($x) eq {}} {
7222             continue
7223         }
7224         foreach arc $arcnos($x) {
7225             set xd $arcstart($arc)
7226             if {$xd eq $bend} {
7227                 set cached_isanc($a,$bend) 1
7228                 set cached_isanc($b,$aend) 0
7229                 return 1
7230             } elseif {$xd eq $aend} {
7231                 set cached_isanc($b,$aend) 1
7232                 set cached_isanc($a,$bend) 0
7233                 return -1
7234             }
7235             if {![info exists anc($xd)]} {
7236                 set anc($xd) $anc($x)
7237                 lappend todo $xd
7238             } elseif {$anc($xd) ne $anc($x)} {
7239                 set anc($xd) {}
7240             }
7241         }
7242     }
7243     set cached_isanc($a,$bend) 0
7244     set cached_isanc($b,$aend) 0
7245     return 0
7248 # This identifies whether $desc has an ancestor that is
7249 # a growing tip of the graph and which is not an ancestor of $anc
7250 # and returns 0 if so and 1 if not.
7251 # If we subsequently discover a tag on such a growing tip, and that
7252 # turns out to be a descendent of $anc (which it could, since we
7253 # don't necessarily see children before parents), then $desc
7254 # isn't a good choice to display as a descendent tag of
7255 # $anc (since it is the descendent of another tag which is
7256 # a descendent of $anc).  Similarly, $anc isn't a good choice to
7257 # display as a ancestor tag of $desc.
7259 proc is_certain {desc anc} {
7260     global arcnos arcout arcstart arcend growing problems
7262     set certain {}
7263     if {[llength $arcnos($anc)] == 1} {
7264         # tags on the same arc are certain
7265         if {$arcnos($desc) eq $arcnos($anc)} {
7266             return 1
7267         }
7268         if {![info exists arcout($anc)]} {
7269             # if $anc is partway along an arc, use the start of the arc instead
7270             set a [lindex $arcnos($anc) 0]
7271             set anc $arcstart($a)
7272         }
7273     }
7274     if {[llength $arcnos($desc)] > 1 || [info exists arcout($desc)]} {
7275         set x $desc
7276     } else {
7277         set a [lindex $arcnos($desc) 0]
7278         set x $arcend($a)
7279     }
7280     if {$x == $anc} {
7281         return 1
7282     }
7283     set anclist [list $x]
7284     set dl($x) 1
7285     set nnh 1
7286     set ngrowanc 0
7287     for {set i 0} {$i < [llength $anclist] && ($nnh > 0 || $ngrowanc > 0)} {incr i} {
7288         set x [lindex $anclist $i]
7289         if {$dl($x)} {
7290             incr nnh -1
7291         }
7292         set done($x) 1
7293         foreach a $arcout($x) {
7294             if {[info exists growing($a)]} {
7295                 if {![info exists growanc($x)] && $dl($x)} {
7296                     set growanc($x) 1
7297                     incr ngrowanc
7298                 }
7299             } else {
7300                 set y $arcend($a)
7301                 if {[info exists dl($y)]} {
7302                     if {$dl($y)} {
7303                         if {!$dl($x)} {
7304                             set dl($y) 0
7305                             if {![info exists done($y)]} {
7306                                 incr nnh -1
7307                             }
7308                             if {[info exists growanc($x)]} {
7309                                 incr ngrowanc -1
7310                             }
7311                             set xl [list $y]
7312                             for {set k 0} {$k < [llength $xl]} {incr k} {
7313                                 set z [lindex $xl $k]
7314                                 foreach c $arcout($z) {
7315                                     if {[info exists arcend($c)]} {
7316                                         set v $arcend($c)
7317                                         if {[info exists dl($v)] && $dl($v)} {
7318                                             set dl($v) 0
7319                                             if {![info exists done($v)]} {
7320                                                 incr nnh -1
7321                                             }
7322                                             if {[info exists growanc($v)]} {
7323                                                 incr ngrowanc -1
7324                                             }
7325                                             lappend xl $v
7326                                         }
7327                                     }
7328                                 }
7329                             }
7330                         }
7331                     }
7332                 } elseif {$y eq $anc || !$dl($x)} {
7333                     set dl($y) 0
7334                     lappend anclist $y
7335                 } else {
7336                     set dl($y) 1
7337                     lappend anclist $y
7338                     incr nnh
7339                 }
7340             }
7341         }
7342     }
7343     foreach x [array names growanc] {
7344         if {$dl($x)} {
7345             return 0
7346         }
7347         return 0
7348     }
7349     return 1
7352 proc validate_arctags {a} {
7353     global arctags idtags
7355     set i -1
7356     set na $arctags($a)
7357     foreach id $arctags($a) {
7358         incr i
7359         if {![info exists idtags($id)]} {
7360             set na [lreplace $na $i $i]
7361             incr i -1
7362         }
7363     }
7364     set arctags($a) $na
7367 proc validate_archeads {a} {
7368     global archeads idheads
7370     set i -1
7371     set na $archeads($a)
7372     foreach id $archeads($a) {
7373         incr i
7374         if {![info exists idheads($id)]} {
7375             set na [lreplace $na $i $i]
7376             incr i -1
7377         }
7378     }
7379     set archeads($a) $na
7382 # Return the list of IDs that have tags that are descendents of id,
7383 # ignoring IDs that are descendents of IDs already reported.
7384 proc desctags {id} {
7385     global arcnos arcstart arcids arctags idtags allparents
7386     global growing cached_dtags
7388     if {![info exists allparents($id)]} {
7389         return {}
7390     }
7391     set t1 [clock clicks -milliseconds]
7392     set argid $id
7393     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7394         # part-way along an arc; check that arc first
7395         set a [lindex $arcnos($id) 0]
7396         if {$arctags($a) ne {}} {
7397             validate_arctags $a
7398             set i [lsearch -exact $arcids($a) $id]
7399             set tid {}
7400             foreach t $arctags($a) {
7401                 set j [lsearch -exact $arcids($a) $t]
7402                 if {$j >= $i} break
7403                 set tid $t
7404             }
7405             if {$tid ne {}} {
7406                 return $tid
7407             }
7408         }
7409         set id $arcstart($a)
7410         if {[info exists idtags($id)]} {
7411             return $id
7412         }
7413     }
7414     if {[info exists cached_dtags($id)]} {
7415         return $cached_dtags($id)
7416     }
7418     set origid $id
7419     set todo [list $id]
7420     set queued($id) 1
7421     set nc 1
7422     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7423         set id [lindex $todo $i]
7424         set done($id) 1
7425         set ta [info exists hastaggedancestor($id)]
7426         if {!$ta} {
7427             incr nc -1
7428         }
7429         # ignore tags on starting node
7430         if {!$ta && $i > 0} {
7431             if {[info exists idtags($id)]} {
7432                 set tagloc($id) $id
7433                 set ta 1
7434             } elseif {[info exists cached_dtags($id)]} {
7435                 set tagloc($id) $cached_dtags($id)
7436                 set ta 1
7437             }
7438         }
7439         foreach a $arcnos($id) {
7440             set d $arcstart($a)
7441             if {!$ta && $arctags($a) ne {}} {
7442                 validate_arctags $a
7443                 if {$arctags($a) ne {}} {
7444                     lappend tagloc($id) [lindex $arctags($a) end]
7445                 }
7446             }
7447             if {$ta || $arctags($a) ne {}} {
7448                 set tomark [list $d]
7449                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7450                     set dd [lindex $tomark $j]
7451                     if {![info exists hastaggedancestor($dd)]} {
7452                         if {[info exists done($dd)]} {
7453                             foreach b $arcnos($dd) {
7454                                 lappend tomark $arcstart($b)
7455                             }
7456                             if {[info exists tagloc($dd)]} {
7457                                 unset tagloc($dd)
7458                             }
7459                         } elseif {[info exists queued($dd)]} {
7460                             incr nc -1
7461                         }
7462                         set hastaggedancestor($dd) 1
7463                     }
7464                 }
7465             }
7466             if {![info exists queued($d)]} {
7467                 lappend todo $d
7468                 set queued($d) 1
7469                 if {![info exists hastaggedancestor($d)]} {
7470                     incr nc
7471                 }
7472             }
7473         }
7474     }
7475     set tags {}
7476     foreach id [array names tagloc] {
7477         if {![info exists hastaggedancestor($id)]} {
7478             foreach t $tagloc($id) {
7479                 if {[lsearch -exact $tags $t] < 0} {
7480                     lappend tags $t
7481                 }
7482             }
7483         }
7484     }
7485     set t2 [clock clicks -milliseconds]
7486     set loopix $i
7488     # remove tags that are descendents of other tags
7489     for {set i 0} {$i < [llength $tags]} {incr i} {
7490         set a [lindex $tags $i]
7491         for {set j 0} {$j < $i} {incr j} {
7492             set b [lindex $tags $j]
7493             set r [anc_or_desc $a $b]
7494             if {$r == 1} {
7495                 set tags [lreplace $tags $j $j]
7496                 incr j -1
7497                 incr i -1
7498             } elseif {$r == -1} {
7499                 set tags [lreplace $tags $i $i]
7500                 incr i -1
7501                 break
7502             }
7503         }
7504     }
7506     if {[array names growing] ne {}} {
7507         # graph isn't finished, need to check if any tag could get
7508         # eclipsed by another tag coming later.  Simply ignore any
7509         # tags that could later get eclipsed.
7510         set ctags {}
7511         foreach t $tags {
7512             if {[is_certain $t $origid]} {
7513                 lappend ctags $t
7514             }
7515         }
7516         if {$tags eq $ctags} {
7517             set cached_dtags($origid) $tags
7518         } else {
7519             set tags $ctags
7520         }
7521     } else {
7522         set cached_dtags($origid) $tags
7523     }
7524     set t3 [clock clicks -milliseconds]
7525     if {0 && $t3 - $t1 >= 100} {
7526         puts "iterating descendents ($loopix/[llength $todo] nodes) took\
7527             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7528     }
7529     return $tags
7532 proc anctags {id} {
7533     global arcnos arcids arcout arcend arctags idtags allparents
7534     global growing cached_atags
7536     if {![info exists allparents($id)]} {
7537         return {}
7538     }
7539     set t1 [clock clicks -milliseconds]
7540     set argid $id
7541     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7542         # part-way along an arc; check that arc first
7543         set a [lindex $arcnos($id) 0]
7544         if {$arctags($a) ne {}} {
7545             validate_arctags $a
7546             set i [lsearch -exact $arcids($a) $id]
7547             foreach t $arctags($a) {
7548                 set j [lsearch -exact $arcids($a) $t]
7549                 if {$j > $i} {
7550                     return $t
7551                 }
7552             }
7553         }
7554         if {![info exists arcend($a)]} {
7555             return {}
7556         }
7557         set id $arcend($a)
7558         if {[info exists idtags($id)]} {
7559             return $id
7560         }
7561     }
7562     if {[info exists cached_atags($id)]} {
7563         return $cached_atags($id)
7564     }
7566     set origid $id
7567     set todo [list $id]
7568     set queued($id) 1
7569     set taglist {}
7570     set nc 1
7571     for {set i 0} {$i < [llength $todo] && $nc > 0} {incr i} {
7572         set id [lindex $todo $i]
7573         set done($id) 1
7574         set td [info exists hastaggeddescendent($id)]
7575         if {!$td} {
7576             incr nc -1
7577         }
7578         # ignore tags on starting node
7579         if {!$td && $i > 0} {
7580             if {[info exists idtags($id)]} {
7581                 set tagloc($id) $id
7582                 set td 1
7583             } elseif {[info exists cached_atags($id)]} {
7584                 set tagloc($id) $cached_atags($id)
7585                 set td 1
7586             }
7587         }
7588         foreach a $arcout($id) {
7589             if {!$td && $arctags($a) ne {}} {
7590                 validate_arctags $a
7591                 if {$arctags($a) ne {}} {
7592                     lappend tagloc($id) [lindex $arctags($a) 0]
7593                 }
7594             }
7595             if {![info exists arcend($a)]} continue
7596             set d $arcend($a)
7597             if {$td || $arctags($a) ne {}} {
7598                 set tomark [list $d]
7599                 for {set j 0} {$j < [llength $tomark]} {incr j} {
7600                     set dd [lindex $tomark $j]
7601                     if {![info exists hastaggeddescendent($dd)]} {
7602                         if {[info exists done($dd)]} {
7603                             foreach b $arcout($dd) {
7604                                 if {[info exists arcend($b)]} {
7605                                     lappend tomark $arcend($b)
7606                                 }
7607                             }
7608                             if {[info exists tagloc($dd)]} {
7609                                 unset tagloc($dd)
7610                             }
7611                         } elseif {[info exists queued($dd)]} {
7612                             incr nc -1
7613                         }
7614                         set hastaggeddescendent($dd) 1
7615                     }
7616                 }
7617             }
7618             if {![info exists queued($d)]} {
7619                 lappend todo $d
7620                 set queued($d) 1
7621                 if {![info exists hastaggeddescendent($d)]} {
7622                     incr nc
7623                 }
7624             }
7625         }
7626     }
7627     set t2 [clock clicks -milliseconds]
7628     set loopix $i
7629     set tags {}
7630     foreach id [array names tagloc] {
7631         if {![info exists hastaggeddescendent($id)]} {
7632             foreach t $tagloc($id) {
7633                 if {[lsearch -exact $tags $t] < 0} {
7634                     lappend tags $t
7635                 }
7636             }
7637         }
7638     }
7640     # remove tags that are ancestors of other tags
7641     for {set i 0} {$i < [llength $tags]} {incr i} {
7642         set a [lindex $tags $i]
7643         for {set j 0} {$j < $i} {incr j} {
7644             set b [lindex $tags $j]
7645             set r [anc_or_desc $a $b]
7646             if {$r == -1} {
7647                 set tags [lreplace $tags $j $j]
7648                 incr j -1
7649                 incr i -1
7650             } elseif {$r == 1} {
7651                 set tags [lreplace $tags $i $i]
7652                 incr i -1
7653                 break
7654             }
7655         }
7656     }
7658     if {[array names growing] ne {}} {
7659         # graph isn't finished, need to check if any tag could get
7660         # eclipsed by another tag coming later.  Simply ignore any
7661         # tags that could later get eclipsed.
7662         set ctags {}
7663         foreach t $tags {
7664             if {[is_certain $origid $t]} {
7665                 lappend ctags $t
7666             }
7667         }
7668         if {$tags eq $ctags} {
7669             set cached_atags($origid) $tags
7670         } else {
7671             set tags $ctags
7672         }
7673     } else {
7674         set cached_atags($origid) $tags
7675     }
7676     set t3 [clock clicks -milliseconds]
7677     if {0 && $t3 - $t1 >= 100} {
7678         puts "iterating ancestors ($loopix/[llength $todo] nodes) took\
7679             [expr {$t2-$t1}]+[expr {$t3-$t2}]ms, $nc candidates left"
7680     }
7681     return $tags
7684 # Return the list of IDs that have heads that are descendents of id,
7685 # including id itself if it has a head.
7686 proc descheads {id} {
7687     global arcnos arcstart arcids archeads idheads cached_dheads
7688     global allparents
7690     if {![info exists allparents($id)]} {
7691         return {}
7692     }
7693     set aret {}
7694     if {[llength $arcnos($id)] == 1 && [llength $allparents($id)] == 1} {
7695         # part-way along an arc; check it first
7696         set a [lindex $arcnos($id) 0]
7697         if {$archeads($a) ne {}} {
7698             validate_archeads $a
7699             set i [lsearch -exact $arcids($a) $id]
7700             foreach t $archeads($a) {
7701                 set j [lsearch -exact $arcids($a) $t]
7702                 if {$j > $i} break
7703                 lappend aret $t
7704             }
7705         }
7706         set id $arcstart($a)
7707     }
7708     set origid $id
7709     set todo [list $id]
7710     set seen($id) 1
7711     set ret {}
7712     for {set i 0} {$i < [llength $todo]} {incr i} {
7713         set id [lindex $todo $i]
7714         if {[info exists cached_dheads($id)]} {
7715             set ret [concat $ret $cached_dheads($id)]
7716         } else {
7717             if {[info exists idheads($id)]} {
7718                 lappend ret $id
7719             }
7720             foreach a $arcnos($id) {
7721                 if {$archeads($a) ne {}} {
7722                     validate_archeads $a
7723                     if {$archeads($a) ne {}} {
7724                         set ret [concat $ret $archeads($a)]
7725                     }
7726                 }
7727                 set d $arcstart($a)
7728                 if {![info exists seen($d)]} {
7729                     lappend todo $d
7730                     set seen($d) 1
7731                 }
7732             }
7733         }
7734     }
7735     set ret [lsort -unique $ret]
7736     set cached_dheads($origid) $ret
7737     return [concat $ret $aret]
7740 proc addedtag {id} {
7741     global arcnos arcout cached_dtags cached_atags
7743     if {![info exists arcnos($id)]} return
7744     if {![info exists arcout($id)]} {
7745         recalcarc [lindex $arcnos($id) 0]
7746     }
7747     catch {unset cached_dtags}
7748     catch {unset cached_atags}
7751 proc addedhead {hid head} {
7752     global arcnos arcout cached_dheads
7754     if {![info exists arcnos($hid)]} return
7755     if {![info exists arcout($hid)]} {
7756         recalcarc [lindex $arcnos($hid) 0]
7757     }
7758     catch {unset cached_dheads}
7761 proc removedhead {hid head} {
7762     global cached_dheads
7764     catch {unset cached_dheads}
7767 proc movedhead {hid head} {
7768     global arcnos arcout cached_dheads
7770     if {![info exists arcnos($hid)]} return
7771     if {![info exists arcout($hid)]} {
7772         recalcarc [lindex $arcnos($hid) 0]
7773     }
7774     catch {unset cached_dheads}
7777 proc changedrefs {} {
7778     global cached_dheads cached_dtags cached_atags
7779     global arctags archeads arcnos arcout idheads idtags
7781     foreach id [concat [array names idheads] [array names idtags]] {
7782         if {[info exists arcnos($id)] && ![info exists arcout($id)]} {
7783             set a [lindex $arcnos($id) 0]
7784             if {![info exists donearc($a)]} {
7785                 recalcarc $a
7786                 set donearc($a) 1
7787             }
7788         }
7789     }
7790     catch {unset cached_dtags}
7791     catch {unset cached_atags}
7792     catch {unset cached_dheads}
7795 proc rereadrefs {} {
7796     global idtags idheads idotherrefs mainhead
7798     set refids [concat [array names idtags] \
7799                     [array names idheads] [array names idotherrefs]]
7800     foreach id $refids {
7801         if {![info exists ref($id)]} {
7802             set ref($id) [listrefs $id]
7803         }
7804     }
7805     set oldmainhead $mainhead
7806     readrefs
7807     changedrefs
7808     set refids [lsort -unique [concat $refids [array names idtags] \
7809                         [array names idheads] [array names idotherrefs]]]
7810     foreach id $refids {
7811         set v [listrefs $id]
7812         if {![info exists ref($id)] || $ref($id) != $v ||
7813             ($id eq $oldmainhead && $id ne $mainhead) ||
7814             ($id eq $mainhead && $id ne $oldmainhead)} {
7815             redrawtags $id
7816         }
7817     }
7818     run refill_reflist
7821 proc listrefs {id} {
7822     global idtags idheads idotherrefs
7824     set x {}
7825     if {[info exists idtags($id)]} {
7826         set x $idtags($id)
7827     }
7828     set y {}
7829     if {[info exists idheads($id)]} {
7830         set y $idheads($id)
7831     }
7832     set z {}
7833     if {[info exists idotherrefs($id)]} {
7834         set z $idotherrefs($id)
7835     }
7836     return [list $x $y $z]
7839 proc showtag {tag isnew} {
7840     global ctext tagcontents tagids linknum tagobjid
7842     if {$isnew} {
7843         addtohistory [list showtag $tag 0]
7844     }
7845     $ctext conf -state normal
7846     clear_ctext
7847     settabs 0
7848     set linknum 0
7849     if {![info exists tagcontents($tag)]} {
7850         catch {
7851             set tagcontents($tag) [exec git cat-file tag $tagobjid($tag)]
7852         }
7853     }
7854     if {[info exists tagcontents($tag)]} {
7855         set text $tagcontents($tag)
7856     } else {
7857         set text "[mc "Tag"]: $tag\n[mc "Id"]:  $tagids($tag)"
7858     }
7859     appendwithlinks $text {}
7860     $ctext conf -state disabled
7861     init_flist {}
7864 proc doquit {} {
7865     global stopped
7866     set stopped 100
7867     savestuff .
7868     destroy .
7871 proc mkfontdisp {font top which} {
7872     global fontattr fontpref $font
7874     set fontpref($font) [set $font]
7875     button $top.${font}but -text $which -font optionfont \
7876         -command [list choosefont $font $which]
7877     label $top.$font -relief flat -font $font \
7878         -text $fontattr($font,family) -justify left
7879     grid x $top.${font}but $top.$font -sticky w
7882 proc choosefont {font which} {
7883     global fontparam fontlist fonttop fontattr
7885     set fontparam(which) $which
7886     set fontparam(font) $font
7887     set fontparam(family) [font actual $font -family]
7888     set fontparam(size) $fontattr($font,size)
7889     set fontparam(weight) $fontattr($font,weight)
7890     set fontparam(slant) $fontattr($font,slant)
7891     set top .gitkfont
7892     set fonttop $top
7893     if {![winfo exists $top]} {
7894         font create sample
7895         eval font config sample [font actual $font]
7896         toplevel $top
7897         wm title $top [mc "Gitk font chooser"]
7898         label $top.l -textvariable fontparam(which)
7899         pack $top.l -side top
7900         set fontlist [lsort [font families]]
7901         frame $top.f
7902         listbox $top.f.fam -listvariable fontlist \
7903             -yscrollcommand [list $top.f.sb set]
7904         bind $top.f.fam <<ListboxSelect>> selfontfam
7905         scrollbar $top.f.sb -command [list $top.f.fam yview]
7906         pack $top.f.sb -side right -fill y
7907         pack $top.f.fam -side left -fill both -expand 1
7908         pack $top.f -side top -fill both -expand 1
7909         frame $top.g
7910         spinbox $top.g.size -from 4 -to 40 -width 4 \
7911             -textvariable fontparam(size) \
7912             -validatecommand {string is integer -strict %s}
7913         checkbutton $top.g.bold -padx 5 \
7914             -font {{Times New Roman} 12 bold} -text [mc "B"] -indicatoron 0 \
7915             -variable fontparam(weight) -onvalue bold -offvalue normal
7916         checkbutton $top.g.ital -padx 5 \
7917             -font {{Times New Roman} 12 italic} -text [mc "I"] -indicatoron 0  \
7918             -variable fontparam(slant) -onvalue italic -offvalue roman
7919         pack $top.g.size $top.g.bold $top.g.ital -side left
7920         pack $top.g -side top
7921         canvas $top.c -width 150 -height 50 -border 2 -relief sunk \
7922             -background white
7923         $top.c create text 100 25 -anchor center -text $which -font sample \
7924             -fill black -tags text
7925         bind $top.c <Configure> [list centertext $top.c]
7926         pack $top.c -side top -fill x
7927         frame $top.buts
7928         button $top.buts.ok -text [mc "OK"] -command fontok -default active
7929         button $top.buts.can -text [mc "Cancel"] -command fontcan -default normal
7930         grid $top.buts.ok $top.buts.can
7931         grid columnconfigure $top.buts 0 -weight 1 -uniform a
7932         grid columnconfigure $top.buts 1 -weight 1 -uniform a
7933         pack $top.buts -side bottom -fill x
7934         trace add variable fontparam write chg_fontparam
7935     } else {
7936         raise $top
7937         $top.c itemconf text -text $which
7938     }
7939     set i [lsearch -exact $fontlist $fontparam(family)]
7940     if {$i >= 0} {
7941         $top.f.fam selection set $i
7942         $top.f.fam see $i
7943     }
7946 proc centertext {w} {
7947     $w coords text [expr {[winfo width $w] / 2}] [expr {[winfo height $w] / 2}]
7950 proc fontok {} {
7951     global fontparam fontpref prefstop
7953     set f $fontparam(font)
7954     set fontpref($f) [list $fontparam(family) $fontparam(size)]
7955     if {$fontparam(weight) eq "bold"} {
7956         lappend fontpref($f) "bold"
7957     }
7958     if {$fontparam(slant) eq "italic"} {
7959         lappend fontpref($f) "italic"
7960     }
7961     set w $prefstop.$f
7962     $w conf -text $fontparam(family) -font $fontpref($f)
7963         
7964     fontcan
7967 proc fontcan {} {
7968     global fonttop fontparam
7970     if {[info exists fonttop]} {
7971         catch {destroy $fonttop}
7972         catch {font delete sample}
7973         unset fonttop
7974         unset fontparam
7975     }
7978 proc selfontfam {} {
7979     global fonttop fontparam
7981     set i [$fonttop.f.fam curselection]
7982     if {$i ne {}} {
7983         set fontparam(family) [$fonttop.f.fam get $i]
7984     }
7987 proc chg_fontparam {v sub op} {
7988     global fontparam
7990     font config sample -$sub $fontparam($sub)
7993 proc doprefs {} {
7994     global maxwidth maxgraphpct
7995     global oldprefs prefstop showneartags showlocalchanges
7996     global bgcolor fgcolor ctext diffcolors selectbgcolor
7997     global tabstop limitdiffs autoselect
7999     set top .gitkprefs
8000     set prefstop $top
8001     if {[winfo exists $top]} {
8002         raise $top
8003         return
8004     }
8005     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8006                    limitdiffs tabstop} {
8007         set oldprefs($v) [set $v]
8008     }
8009     toplevel $top
8010     wm title $top [mc "Gitk preferences"]
8011     label $top.ldisp -text [mc "Commit list display options"]
8012     grid $top.ldisp - -sticky w -pady 10
8013     label $top.spacer -text " "
8014     label $top.maxwidthl -text [mc "Maximum graph width (lines)"] \
8015         -font optionfont
8016     spinbox $top.maxwidth -from 0 -to 100 -width 4 -textvariable maxwidth
8017     grid $top.spacer $top.maxwidthl $top.maxwidth -sticky w
8018     label $top.maxpctl -text [mc "Maximum graph width (% of pane)"] \
8019         -font optionfont
8020     spinbox $top.maxpct -from 1 -to 100 -width 4 -textvariable maxgraphpct
8021     grid x $top.maxpctl $top.maxpct -sticky w
8022     frame $top.showlocal
8023     label $top.showlocal.l -text [mc "Show local changes"] -font optionfont
8024     checkbutton $top.showlocal.b -variable showlocalchanges
8025     pack $top.showlocal.b $top.showlocal.l -side left
8026     grid x $top.showlocal -sticky w
8027     frame $top.autoselect
8028     label $top.autoselect.l -text [mc "Auto-select SHA1"] -font optionfont
8029     checkbutton $top.autoselect.b -variable autoselect
8030     pack $top.autoselect.b $top.autoselect.l -side left
8031     grid x $top.autoselect -sticky w
8033     label $top.ddisp -text [mc "Diff display options"]
8034     grid $top.ddisp - -sticky w -pady 10
8035     label $top.tabstopl -text [mc "Tab spacing"] -font optionfont
8036     spinbox $top.tabstop -from 1 -to 20 -width 4 -textvariable tabstop
8037     grid x $top.tabstopl $top.tabstop -sticky w
8038     frame $top.ntag
8039     label $top.ntag.l -text [mc "Display nearby tags"] -font optionfont
8040     checkbutton $top.ntag.b -variable showneartags
8041     pack $top.ntag.b $top.ntag.l -side left
8042     grid x $top.ntag -sticky w
8043     frame $top.ldiff
8044     label $top.ldiff.l -text [mc "Limit diffs to listed paths"] -font optionfont
8045     checkbutton $top.ldiff.b -variable limitdiffs
8046     pack $top.ldiff.b $top.ldiff.l -side left
8047     grid x $top.ldiff -sticky w
8049     label $top.cdisp -text [mc "Colors: press to choose"]
8050     grid $top.cdisp - -sticky w -pady 10
8051     label $top.bg -padx 40 -relief sunk -background $bgcolor
8052     button $top.bgbut -text [mc "Background"] -font optionfont \
8053         -command [list choosecolor bgcolor {} $top.bg background setbg]
8054     grid x $top.bgbut $top.bg -sticky w
8055     label $top.fg -padx 40 -relief sunk -background $fgcolor
8056     button $top.fgbut -text [mc "Foreground"] -font optionfont \
8057         -command [list choosecolor fgcolor {} $top.fg foreground setfg]
8058     grid x $top.fgbut $top.fg -sticky w
8059     label $top.diffold -padx 40 -relief sunk -background [lindex $diffcolors 0]
8060     button $top.diffoldbut -text [mc "Diff: old lines"] -font optionfont \
8061         -command [list choosecolor diffcolors 0 $top.diffold "diff old lines" \
8062                       [list $ctext tag conf d0 -foreground]]
8063     grid x $top.diffoldbut $top.diffold -sticky w
8064     label $top.diffnew -padx 40 -relief sunk -background [lindex $diffcolors 1]
8065     button $top.diffnewbut -text [mc "Diff: new lines"] -font optionfont \
8066         -command [list choosecolor diffcolors 1 $top.diffnew "diff new lines" \
8067                       [list $ctext tag conf d1 -foreground]]
8068     grid x $top.diffnewbut $top.diffnew -sticky w
8069     label $top.hunksep -padx 40 -relief sunk -background [lindex $diffcolors 2]
8070     button $top.hunksepbut -text [mc "Diff: hunk header"] -font optionfont \
8071         -command [list choosecolor diffcolors 2 $top.hunksep \
8072                       "diff hunk header" \
8073                       [list $ctext tag conf hunksep -foreground]]
8074     grid x $top.hunksepbut $top.hunksep -sticky w
8075     label $top.selbgsep -padx 40 -relief sunk -background $selectbgcolor
8076     button $top.selbgbut -text [mc "Select bg"] -font optionfont \
8077         -command [list choosecolor selectbgcolor {} $top.selbgsep background setselbg]
8078     grid x $top.selbgbut $top.selbgsep -sticky w
8080     label $top.cfont -text [mc "Fonts: press to choose"]
8081     grid $top.cfont - -sticky w -pady 10
8082     mkfontdisp mainfont $top [mc "Main font"]
8083     mkfontdisp textfont $top [mc "Diff display font"]
8084     mkfontdisp uifont $top [mc "User interface font"]
8086     frame $top.buts
8087     button $top.buts.ok -text [mc "OK"] -command prefsok -default active
8088     button $top.buts.can -text [mc "Cancel"] -command prefscan -default normal
8089     grid $top.buts.ok $top.buts.can
8090     grid columnconfigure $top.buts 0 -weight 1 -uniform a
8091     grid columnconfigure $top.buts 1 -weight 1 -uniform a
8092     grid $top.buts - - -pady 10 -sticky ew
8093     bind $top <Visibility> "focus $top.buts.ok"
8096 proc choosecolor {v vi w x cmd} {
8097     global $v
8099     set c [tk_chooseColor -initialcolor [lindex [set $v] $vi] \
8100                -title [mc "Gitk: choose color for %s" $x]]
8101     if {$c eq {}} return
8102     $w conf -background $c
8103     lset $v $vi $c
8104     eval $cmd $c
8107 proc setselbg {c} {
8108     global bglist cflist
8109     foreach w $bglist {
8110         $w configure -selectbackground $c
8111     }
8112     $cflist tag configure highlight \
8113         -background [$cflist cget -selectbackground]
8114     allcanvs itemconf secsel -fill $c
8117 proc setbg {c} {
8118     global bglist
8120     foreach w $bglist {
8121         $w conf -background $c
8122     }
8125 proc setfg {c} {
8126     global fglist canv
8128     foreach w $fglist {
8129         $w conf -foreground $c
8130     }
8131     allcanvs itemconf text -fill $c
8132     $canv itemconf circle -outline $c
8135 proc prefscan {} {
8136     global oldprefs prefstop
8138     foreach v {maxwidth maxgraphpct showneartags showlocalchanges \
8139                    limitdiffs tabstop} {
8140         global $v
8141         set $v $oldprefs($v)
8142     }
8143     catch {destroy $prefstop}
8144     unset prefstop
8145     fontcan
8148 proc prefsok {} {
8149     global maxwidth maxgraphpct
8150     global oldprefs prefstop showneartags showlocalchanges
8151     global fontpref mainfont textfont uifont
8152     global limitdiffs treediffs
8154     catch {destroy $prefstop}
8155     unset prefstop
8156     fontcan
8157     set fontchanged 0
8158     if {$mainfont ne $fontpref(mainfont)} {
8159         set mainfont $fontpref(mainfont)
8160         parsefont mainfont $mainfont
8161         eval font configure mainfont [fontflags mainfont]
8162         eval font configure mainfontbold [fontflags mainfont 1]
8163         setcoords
8164         set fontchanged 1
8165     }
8166     if {$textfont ne $fontpref(textfont)} {
8167         set textfont $fontpref(textfont)
8168         parsefont textfont $textfont
8169         eval font configure textfont [fontflags textfont]
8170         eval font configure textfontbold [fontflags textfont 1]
8171     }
8172     if {$uifont ne $fontpref(uifont)} {
8173         set uifont $fontpref(uifont)
8174         parsefont uifont $uifont
8175         eval font configure uifont [fontflags uifont]
8176     }
8177     settabs
8178     if {$showlocalchanges != $oldprefs(showlocalchanges)} {
8179         if {$showlocalchanges} {
8180             doshowlocalchanges
8181         } else {
8182             dohidelocalchanges
8183         }
8184     }
8185     if {$limitdiffs != $oldprefs(limitdiffs)} {
8186         # treediffs elements are limited by path
8187         catch {unset treediffs}
8188     }
8189     if {$fontchanged || $maxwidth != $oldprefs(maxwidth)
8190         || $maxgraphpct != $oldprefs(maxgraphpct)} {
8191         redisplay
8192     } elseif {$showneartags != $oldprefs(showneartags) ||
8193           $limitdiffs != $oldprefs(limitdiffs)} {
8194         reselectline
8195     }
8198 proc formatdate {d} {
8199     global datetimeformat
8200     if {$d ne {}} {
8201         set d [clock format $d -format $datetimeformat]
8202     }
8203     return $d
8206 # This list of encoding names and aliases is distilled from
8207 # http://www.iana.org/assignments/character-sets.
8208 # Not all of them are supported by Tcl.
8209 set encoding_aliases {
8210     { ANSI_X3.4-1968 iso-ir-6 ANSI_X3.4-1986 ISO_646.irv:1991 ASCII
8211       ISO646-US US-ASCII us IBM367 cp367 csASCII }
8212     { ISO-10646-UTF-1 csISO10646UTF1 }
8213     { ISO_646.basic:1983 ref csISO646basic1983 }
8214     { INVARIANT csINVARIANT }
8215     { ISO_646.irv:1983 iso-ir-2 irv csISO2IntlRefVersion }
8216     { BS_4730 iso-ir-4 ISO646-GB gb uk csISO4UnitedKingdom }
8217     { NATS-SEFI iso-ir-8-1 csNATSSEFI }
8218     { NATS-SEFI-ADD iso-ir-8-2 csNATSSEFIADD }
8219     { NATS-DANO iso-ir-9-1 csNATSDANO }
8220     { NATS-DANO-ADD iso-ir-9-2 csNATSDANOADD }
8221     { SEN_850200_B iso-ir-10 FI ISO646-FI ISO646-SE se csISO10Swedish }
8222     { SEN_850200_C iso-ir-11 ISO646-SE2 se2 csISO11SwedishForNames }
8223     { KS_C_5601-1987 iso-ir-149 KS_C_5601-1989 KSC_5601 korean csKSC56011987 }
8224     { ISO-2022-KR csISO2022KR }
8225     { EUC-KR csEUCKR }
8226     { ISO-2022-JP csISO2022JP }
8227     { ISO-2022-JP-2 csISO2022JP2 }
8228     { JIS_C6220-1969-jp JIS_C6220-1969 iso-ir-13 katakana x0201-7
8229       csISO13JISC6220jp }
8230     { JIS_C6220-1969-ro iso-ir-14 jp ISO646-JP csISO14JISC6220ro }
8231     { IT iso-ir-15 ISO646-IT csISO15Italian }
8232     { PT iso-ir-16 ISO646-PT csISO16Portuguese }
8233     { ES iso-ir-17 ISO646-ES csISO17Spanish }
8234     { greek7-old iso-ir-18 csISO18Greek7Old }
8235     { latin-greek iso-ir-19 csISO19LatinGreek }
8236     { DIN_66003 iso-ir-21 de ISO646-DE csISO21German }
8237     { NF_Z_62-010_(1973) iso-ir-25 ISO646-FR1 csISO25French }
8238     { Latin-greek-1 iso-ir-27 csISO27LatinGreek1 }
8239     { ISO_5427 iso-ir-37 csISO5427Cyrillic }
8240     { JIS_C6226-1978 iso-ir-42 csISO42JISC62261978 }
8241     { BS_viewdata iso-ir-47 csISO47BSViewdata }
8242     { INIS iso-ir-49 csISO49INIS }
8243     { INIS-8 iso-ir-50 csISO50INIS8 }
8244     { INIS-cyrillic iso-ir-51 csISO51INISCyrillic }
8245     { ISO_5427:1981 iso-ir-54 ISO5427Cyrillic1981 }
8246     { ISO_5428:1980 iso-ir-55 csISO5428Greek }
8247     { GB_1988-80 iso-ir-57 cn ISO646-CN csISO57GB1988 }
8248     { GB_2312-80 iso-ir-58 chinese csISO58GB231280 }
8249     { NS_4551-1 iso-ir-60 ISO646-NO no csISO60DanishNorwegian
8250       csISO60Norwegian1 }
8251     { NS_4551-2 ISO646-NO2 iso-ir-61 no2 csISO61Norwegian2 }
8252     { NF_Z_62-010 iso-ir-69 ISO646-FR fr csISO69French }
8253     { videotex-suppl iso-ir-70 csISO70VideotexSupp1 }
8254     { PT2 iso-ir-84 ISO646-PT2 csISO84Portuguese2 }
8255     { ES2 iso-ir-85 ISO646-ES2 csISO85Spanish2 }
8256     { MSZ_7795.3 iso-ir-86 ISO646-HU hu csISO86Hungarian }
8257     { JIS_C6226-1983 iso-ir-87 x0208 JIS_X0208-1983 csISO87JISX0208 }
8258     { greek7 iso-ir-88 csISO88Greek7 }
8259     { ASMO_449 ISO_9036 arabic7 iso-ir-89 csISO89ASMO449 }
8260     { iso-ir-90 csISO90 }
8261     { JIS_C6229-1984-a iso-ir-91 jp-ocr-a csISO91JISC62291984a }
8262     { JIS_C6229-1984-b iso-ir-92 ISO646-JP-OCR-B jp-ocr-b
8263       csISO92JISC62991984b }
8264     { JIS_C6229-1984-b-add iso-ir-93 jp-ocr-b-add csISO93JIS62291984badd }
8265     { JIS_C6229-1984-hand iso-ir-94 jp-ocr-hand csISO94JIS62291984hand }
8266     { JIS_C6229-1984-hand-add iso-ir-95 jp-ocr-hand-add
8267       csISO95JIS62291984handadd }
8268     { JIS_C6229-1984-kana iso-ir-96 csISO96JISC62291984kana }
8269     { ISO_2033-1983 iso-ir-98 e13b csISO2033 }
8270     { ANSI_X3.110-1983 iso-ir-99 CSA_T500-1983 NAPLPS csISO99NAPLPS }
8271     { ISO_8859-1:1987 iso-ir-100 ISO_8859-1 ISO-8859-1 latin1 l1 IBM819
8272       CP819 csISOLatin1 }
8273     { ISO_8859-2:1987 iso-ir-101 ISO_8859-2 ISO-8859-2 latin2 l2 csISOLatin2 }
8274     { T.61-7bit iso-ir-102 csISO102T617bit }
8275     { T.61-8bit T.61 iso-ir-103 csISO103T618bit }
8276     { ISO_8859-3:1988 iso-ir-109 ISO_8859-3 ISO-8859-3 latin3 l3 csISOLatin3 }
8277     { ISO_8859-4:1988 iso-ir-110 ISO_8859-4 ISO-8859-4 latin4 l4 csISOLatin4 }
8278     { ECMA-cyrillic iso-ir-111 KOI8-E csISO111ECMACyrillic }
8279     { CSA_Z243.4-1985-1 iso-ir-121 ISO646-CA csa7-1 ca csISO121Canadian1 }
8280     { CSA_Z243.4-1985-2 iso-ir-122 ISO646-CA2 csa7-2 csISO122Canadian2 }
8281     { CSA_Z243.4-1985-gr iso-ir-123 csISO123CSAZ24341985gr }
8282     { ISO_8859-6:1987 iso-ir-127 ISO_8859-6 ISO-8859-6 ECMA-114 ASMO-708
8283       arabic csISOLatinArabic }
8284     { ISO_8859-6-E csISO88596E ISO-8859-6-E }
8285     { ISO_8859-6-I csISO88596I ISO-8859-6-I }
8286     { ISO_8859-7:1987 iso-ir-126 ISO_8859-7 ISO-8859-7 ELOT_928 ECMA-118
8287       greek greek8 csISOLatinGreek }
8288     { T.101-G2 iso-ir-128 csISO128T101G2 }
8289     { ISO_8859-8:1988 iso-ir-138 ISO_8859-8 ISO-8859-8 hebrew
8290       csISOLatinHebrew }
8291     { ISO_8859-8-E csISO88598E ISO-8859-8-E }
8292     { ISO_8859-8-I csISO88598I ISO-8859-8-I }
8293     { CSN_369103 iso-ir-139 csISO139CSN369103 }
8294     { JUS_I.B1.002 iso-ir-141 ISO646-YU js yu csISO141JUSIB1002 }
8295     { ISO_6937-2-add iso-ir-142 csISOTextComm }
8296     { IEC_P27-1 iso-ir-143 csISO143IECP271 }
8297     { ISO_8859-5:1988 iso-ir-144 ISO_8859-5 ISO-8859-5 cyrillic
8298       csISOLatinCyrillic }
8299     { JUS_I.B1.003-serb iso-ir-146 serbian csISO146Serbian }
8300     { JUS_I.B1.003-mac macedonian iso-ir-147 csISO147Macedonian }
8301     { ISO_8859-9:1989 iso-ir-148 ISO_8859-9 ISO-8859-9 latin5 l5 csISOLatin5 }
8302     { greek-ccitt iso-ir-150 csISO150 csISO150GreekCCITT }
8303     { NC_NC00-10:81 cuba iso-ir-151 ISO646-CU csISO151Cuba }
8304     { ISO_6937-2-25 iso-ir-152 csISO6937Add }
8305     { GOST_19768-74 ST_SEV_358-88 iso-ir-153 csISO153GOST1976874 }
8306     { ISO_8859-supp iso-ir-154 latin1-2-5 csISO8859Supp }
8307     { ISO_10367-box iso-ir-155 csISO10367Box }
8308     { ISO-8859-10 iso-ir-157 l6 ISO_8859-10:1992 csISOLatin6 latin6 }
8309     { latin-lap lap iso-ir-158 csISO158Lap }
8310     { JIS_X0212-1990 x0212 iso-ir-159 csISO159JISX02121990 }
8311     { DS_2089 DS2089 ISO646-DK dk csISO646Danish }
8312     { us-dk csUSDK }
8313     { dk-us csDKUS }
8314     { JIS_X0201 X0201 csHalfWidthKatakana }
8315     { KSC5636 ISO646-KR csKSC5636 }
8316     { ISO-10646-UCS-2 csUnicode }
8317     { ISO-10646-UCS-4 csUCS4 }
8318     { DEC-MCS dec csDECMCS }
8319     { hp-roman8 roman8 r8 csHPRoman8 }
8320     { macintosh mac csMacintosh }
8321     { IBM037 cp037 ebcdic-cp-us ebcdic-cp-ca ebcdic-cp-wt ebcdic-cp-nl
8322       csIBM037 }
8323     { IBM038 EBCDIC-INT cp038 csIBM038 }
8324     { IBM273 CP273 csIBM273 }
8325     { IBM274 EBCDIC-BE CP274 csIBM274 }
8326     { IBM275 EBCDIC-BR cp275 csIBM275 }
8327     { IBM277 EBCDIC-CP-DK EBCDIC-CP-NO csIBM277 }
8328     { IBM278 CP278 ebcdic-cp-fi ebcdic-cp-se csIBM278 }
8329     { IBM280 CP280 ebcdic-cp-it csIBM280 }
8330     { IBM281 EBCDIC-JP-E cp281 csIBM281 }
8331     { IBM284 CP284 ebcdic-cp-es csIBM284 }
8332     { IBM285 CP285 ebcdic-cp-gb csIBM285 }
8333     { IBM290 cp290 EBCDIC-JP-kana csIBM290 }
8334     { IBM297 cp297 ebcdic-cp-fr csIBM297 }
8335     { IBM420 cp420 ebcdic-cp-ar1 csIBM420 }
8336     { IBM423 cp423 ebcdic-cp-gr csIBM423 }
8337     { IBM424 cp424 ebcdic-cp-he csIBM424 }
8338     { IBM437 cp437 437 csPC8CodePage437 }
8339     { IBM500 CP500 ebcdic-cp-be ebcdic-cp-ch csIBM500 }
8340     { IBM775 cp775 csPC775Baltic }
8341     { IBM850 cp850 850 csPC850Multilingual }
8342     { IBM851 cp851 851 csIBM851 }
8343     { IBM852 cp852 852 csPCp852 }
8344     { IBM855 cp855 855 csIBM855 }
8345     { IBM857 cp857 857 csIBM857 }
8346     { IBM860 cp860 860 csIBM860 }
8347     { IBM861 cp861 861 cp-is csIBM861 }
8348     { IBM862 cp862 862 csPC862LatinHebrew }
8349     { IBM863 cp863 863 csIBM863 }
8350     { IBM864 cp864 csIBM864 }
8351     { IBM865 cp865 865 csIBM865 }
8352     { IBM866 cp866 866 csIBM866 }
8353     { IBM868 CP868 cp-ar csIBM868 }
8354     { IBM869 cp869 869 cp-gr csIBM869 }
8355     { IBM870 CP870 ebcdic-cp-roece ebcdic-cp-yu csIBM870 }
8356     { IBM871 CP871 ebcdic-cp-is csIBM871 }
8357     { IBM880 cp880 EBCDIC-Cyrillic csIBM880 }
8358     { IBM891 cp891 csIBM891 }
8359     { IBM903 cp903 csIBM903 }
8360     { IBM904 cp904 904 csIBBM904 }
8361     { IBM905 CP905 ebcdic-cp-tr csIBM905 }
8362     { IBM918 CP918 ebcdic-cp-ar2 csIBM918 }
8363     { IBM1026 CP1026 csIBM1026 }
8364     { EBCDIC-AT-DE csIBMEBCDICATDE }
8365     { EBCDIC-AT-DE-A csEBCDICATDEA }
8366     { EBCDIC-CA-FR csEBCDICCAFR }
8367     { EBCDIC-DK-NO csEBCDICDKNO }
8368     { EBCDIC-DK-NO-A csEBCDICDKNOA }
8369     { EBCDIC-FI-SE csEBCDICFISE }
8370     { EBCDIC-FI-SE-A csEBCDICFISEA }
8371     { EBCDIC-FR csEBCDICFR }
8372     { EBCDIC-IT csEBCDICIT }
8373     { EBCDIC-PT csEBCDICPT }
8374     { EBCDIC-ES csEBCDICES }
8375     { EBCDIC-ES-A csEBCDICESA }
8376     { EBCDIC-ES-S csEBCDICESS }
8377     { EBCDIC-UK csEBCDICUK }
8378     { EBCDIC-US csEBCDICUS }
8379     { UNKNOWN-8BIT csUnknown8BiT }
8380     { MNEMONIC csMnemonic }
8381     { MNEM csMnem }
8382     { VISCII csVISCII }
8383     { VIQR csVIQR }
8384     { KOI8-R csKOI8R }
8385     { IBM00858 CCSID00858 CP00858 PC-Multilingual-850+euro }
8386     { IBM00924 CCSID00924 CP00924 ebcdic-Latin9--euro }
8387     { IBM01140 CCSID01140 CP01140 ebcdic-us-37+euro }
8388     { IBM01141 CCSID01141 CP01141 ebcdic-de-273+euro }
8389     { IBM01142 CCSID01142 CP01142 ebcdic-dk-277+euro ebcdic-no-277+euro }
8390     { IBM01143 CCSID01143 CP01143 ebcdic-fi-278+euro ebcdic-se-278+euro }
8391     { IBM01144 CCSID01144 CP01144 ebcdic-it-280+euro }
8392     { IBM01145 CCSID01145 CP01145 ebcdic-es-284+euro }
8393     { IBM01146 CCSID01146 CP01146 ebcdic-gb-285+euro }
8394     { IBM01147 CCSID01147 CP01147 ebcdic-fr-297+euro }
8395     { IBM01148 CCSID01148 CP01148 ebcdic-international-500+euro }
8396     { IBM01149 CCSID01149 CP01149 ebcdic-is-871+euro }
8397     { IBM1047 IBM-1047 }
8398     { PTCP154 csPTCP154 PT154 CP154 Cyrillic-Asian }
8399     { Amiga-1251 Ami1251 Amiga1251 Ami-1251 }
8400     { UNICODE-1-1 csUnicode11 }
8401     { CESU-8 csCESU-8 }
8402     { BOCU-1 csBOCU-1 }
8403     { UNICODE-1-1-UTF-7 csUnicode11UTF7 }
8404     { ISO-8859-14 iso-ir-199 ISO_8859-14:1998 ISO_8859-14 latin8 iso-celtic
8405       l8 }
8406     { ISO-8859-15 ISO_8859-15 Latin-9 }
8407     { ISO-8859-16 iso-ir-226 ISO_8859-16:2001 ISO_8859-16 latin10 l10 }
8408     { GBK CP936 MS936 windows-936 }
8409     { JIS_Encoding csJISEncoding }
8410     { Shift_JIS MS_Kanji csShiftJIS }
8411     { Extended_UNIX_Code_Packed_Format_for_Japanese csEUCPkdFmtJapanese
8412       EUC-JP }
8413     { Extended_UNIX_Code_Fixed_Width_for_Japanese csEUCFixWidJapanese }
8414     { ISO-10646-UCS-Basic csUnicodeASCII }
8415     { ISO-10646-Unicode-Latin1 csUnicodeLatin1 ISO-10646 }
8416     { ISO-Unicode-IBM-1261 csUnicodeIBM1261 }
8417     { ISO-Unicode-IBM-1268 csUnicodeIBM1268 }
8418     { ISO-Unicode-IBM-1276 csUnicodeIBM1276 }
8419     { ISO-Unicode-IBM-1264 csUnicodeIBM1264 }
8420     { ISO-Unicode-IBM-1265 csUnicodeIBM1265 }
8421     { ISO-8859-1-Windows-3.0-Latin-1 csWindows30Latin1 }
8422     { ISO-8859-1-Windows-3.1-Latin-1 csWindows31Latin1 }
8423     { ISO-8859-2-Windows-Latin-2 csWindows31Latin2 }
8424     { ISO-8859-9-Windows-Latin-5 csWindows31Latin5 }
8425     { Adobe-Standard-Encoding csAdobeStandardEncoding }
8426     { Ventura-US csVenturaUS }
8427     { Ventura-International csVenturaInternational }
8428     { PC8-Danish-Norwegian csPC8DanishNorwegian }
8429     { PC8-Turkish csPC8Turkish }
8430     { IBM-Symbols csIBMSymbols }
8431     { IBM-Thai csIBMThai }
8432     { HP-Legal csHPLegal }
8433     { HP-Pi-font csHPPiFont }
8434     { HP-Math8 csHPMath8 }
8435     { Adobe-Symbol-Encoding csHPPSMath }
8436     { HP-DeskTop csHPDesktop }
8437     { Ventura-Math csVenturaMath }
8438     { Microsoft-Publishing csMicrosoftPublishing }
8439     { Windows-31J csWindows31J }
8440     { GB2312 csGB2312 }
8441     { Big5 csBig5 }
8444 proc tcl_encoding {enc} {
8445     global encoding_aliases
8446     set names [encoding names]
8447     set lcnames [string tolower $names]
8448     set enc [string tolower $enc]
8449     set i [lsearch -exact $lcnames $enc]
8450     if {$i < 0} {
8451         # look for "isonnn" instead of "iso-nnn" or "iso_nnn"
8452         if {[regsub {^iso[-_]} $enc iso encx]} {
8453             set i [lsearch -exact $lcnames $encx]
8454         }
8455     }
8456     if {$i < 0} {
8457         foreach l $encoding_aliases {
8458             set ll [string tolower $l]
8459             if {[lsearch -exact $ll $enc] < 0} continue
8460             # look through the aliases for one that tcl knows about
8461             foreach e $ll {
8462                 set i [lsearch -exact $lcnames $e]
8463                 if {$i < 0} {
8464                     if {[regsub {^iso[-_]} $e iso ex]} {
8465                         set i [lsearch -exact $lcnames $ex]
8466                     }
8467                 }
8468                 if {$i >= 0} break
8469             }
8470             break
8471         }
8472     }
8473     if {$i >= 0} {
8474         return [lindex $names $i]
8475     }
8476     return {}
8479 # First check that Tcl/Tk is recent enough
8480 if {[catch {package require Tk 8.4} err]} {
8481     show_error {} . [mc "Sorry, gitk cannot run with this version of Tcl/Tk.\n\
8482                      Gitk requires at least Tcl/Tk 8.4."]
8483     exit 1
8486 # defaults...
8487 set datemode 0
8488 set wrcomcmd "git diff-tree --stdin -p --pretty"
8490 set gitencoding {}
8491 catch {
8492     set gitencoding [exec git config --get i18n.commitencoding]
8494 if {$gitencoding == ""} {
8495     set gitencoding "utf-8"
8497 set tclencoding [tcl_encoding $gitencoding]
8498 if {$tclencoding == {}} {
8499     puts stderr "Warning: encoding $gitencoding is not supported by Tcl/Tk"
8502 set mainfont {Helvetica 9}
8503 set textfont {Courier 9}
8504 set uifont {Helvetica 9 bold}
8505 set tabstop 8
8506 set findmergefiles 0
8507 set maxgraphpct 50
8508 set maxwidth 16
8509 set revlistorder 0
8510 set fastdate 0
8511 set uparrowlen 5
8512 set downarrowlen 5
8513 set mingaplen 100
8514 set cmitmode "patch"
8515 set wrapcomment "none"
8516 set showneartags 1
8517 set maxrefs 20
8518 set maxlinelen 200
8519 set showlocalchanges 1
8520 set limitdiffs 1
8521 set datetimeformat "%Y-%m-%d %H:%M:%S"
8522 set autoselect 1
8524 set colors {green red blue magenta darkgrey brown orange}
8525 set bgcolor white
8526 set fgcolor black
8527 set diffcolors {red "#00a000" blue}
8528 set diffcontext 3
8529 set ignorespace 0
8530 set selectbgcolor gray85
8532 ## For msgcat loading, first locate the installation location.
8533 if { [info exists ::env(GITK_MSGSDIR)] } {
8534     ## Msgsdir was manually set in the environment.
8535     set gitk_msgsdir $::env(GITK_MSGSDIR)
8536 } else {
8537     ## Let's guess the prefix from argv0.
8538     set gitk_prefix [file dirname [file dirname [file normalize $argv0]]]
8539     set gitk_libdir [file join $gitk_prefix share gitk lib]
8540     set gitk_msgsdir [file join $gitk_libdir msgs]
8541     unset gitk_prefix
8544 ## Internationalization (i18n) through msgcat and gettext. See
8545 ## http://www.gnu.org/software/gettext/manual/html_node/Tcl.html
8546 package require msgcat
8547 namespace import ::msgcat::mc
8548 ## And eventually load the actual message catalog
8549 ::msgcat::mcload $gitk_msgsdir
8551 catch {source ~/.gitk}
8553 font create optionfont -family sans-serif -size -12
8555 parsefont mainfont $mainfont
8556 eval font create mainfont [fontflags mainfont]
8557 eval font create mainfontbold [fontflags mainfont 1]
8559 parsefont textfont $textfont
8560 eval font create textfont [fontflags textfont]
8561 eval font create textfontbold [fontflags textfont 1]
8563 parsefont uifont $uifont
8564 eval font create uifont [fontflags uifont]
8566 setoptions
8568 # check that we can find a .git directory somewhere...
8569 if {[catch {set gitdir [gitdir]}]} {
8570     show_error {} . [mc "Cannot find a git repository here."]
8571     exit 1
8573 if {![file isdirectory $gitdir]} {
8574     show_error {} . [mc "Cannot find the git directory \"%s\"." $gitdir]
8575     exit 1
8578 set mergeonly 0
8579 set revtreeargs {}
8580 set cmdline_files {}
8581 set i 0
8582 set revtreeargscmd {}
8583 foreach arg $argv {
8584     switch -glob -- $arg {
8585         "" { }
8586         "-d" { set datemode 1 }
8587         "--merge" {
8588             set mergeonly 1
8589             lappend revtreeargs $arg
8590         }
8591         "--" {
8592             set cmdline_files [lrange $argv [expr {$i + 1}] end]
8593             break
8594         }
8595         "--argscmd=*" {
8596             set revtreeargscmd [string range $arg 10 end]
8597         }
8598         default {
8599             lappend revtreeargs $arg
8600         }
8601     }
8602     incr i
8605 if {$i >= [llength $argv] && $revtreeargs ne {}} {
8606     # no -- on command line, but some arguments (other than -d)
8607     if {[catch {
8608         set f [eval exec git rev-parse --no-revs --no-flags $revtreeargs]
8609         set cmdline_files [split $f "\n"]
8610         set n [llength $cmdline_files]
8611         set revtreeargs [lrange $revtreeargs 0 end-$n]
8612         # Unfortunately git rev-parse doesn't produce an error when
8613         # something is both a revision and a filename.  To be consistent
8614         # with git log and git rev-list, check revtreeargs for filenames.
8615         foreach arg $revtreeargs {
8616             if {[file exists $arg]} {
8617                 show_error {} . [mc "Ambiguous argument '%s': both revision\
8618                                  and filename" $arg]
8619                 exit 1
8620             }
8621         }
8622     } err]} {
8623         # unfortunately we get both stdout and stderr in $err,
8624         # so look for "fatal:".
8625         set i [string first "fatal:" $err]
8626         if {$i > 0} {
8627             set err [string range $err [expr {$i + 6}] end]
8628         }
8629         show_error {} . "[mc "Bad arguments to gitk:"]\n$err"
8630         exit 1
8631     }
8634 if {$mergeonly} {
8635     # find the list of unmerged files
8636     set mlist {}
8637     set nr_unmerged 0
8638     if {[catch {
8639         set fd [open "| git ls-files -u" r]
8640     } err]} {
8641         show_error {} . "[mc "Couldn't get list of unmerged files:"] $err"
8642         exit 1
8643     }
8644     while {[gets $fd line] >= 0} {
8645         set i [string first "\t" $line]
8646         if {$i < 0} continue
8647         set fname [string range $line [expr {$i+1}] end]
8648         if {[lsearch -exact $mlist $fname] >= 0} continue
8649         incr nr_unmerged
8650         if {$cmdline_files eq {} || [path_filter $cmdline_files $fname]} {
8651             lappend mlist $fname
8652         }
8653     }
8654     catch {close $fd}
8655     if {$mlist eq {}} {
8656         if {$nr_unmerged == 0} {
8657             show_error {} . [mc "No files selected: --merge specified but\
8658                              no files are unmerged."]
8659         } else {
8660             show_error {} . [mc "No files selected: --merge specified but\
8661                              no unmerged files are within file limit."]
8662         }
8663         exit 1
8664     }
8665     set cmdline_files $mlist
8668 set nullid "0000000000000000000000000000000000000000"
8669 set nullid2 "0000000000000000000000000000000000000001"
8671 set have_tk85 [expr {[package vcompare $tk_version "8.5"] >= 0}]
8673 set runq {}
8674 set history {}
8675 set historyindex 0
8676 set fh_serial 0
8677 set nhl_names {}
8678 set highlight_paths {}
8679 set findpattern {}
8680 set searchdirn -forwards
8681 set boldrows {}
8682 set boldnamerows {}
8683 set diffelide {0 0}
8684 set markingmatches 0
8685 set linkentercount 0
8686 set need_redisplay 0
8687 set nrows_drawn 0
8688 set firsttabstop 0
8690 set nextviewnum 1
8691 set curview 0
8692 set selectedview 0
8693 set selectedhlview [mc "None"]
8694 set highlight_related [mc "None"]
8695 set highlight_files {}
8696 set viewfiles(0) {}
8697 set viewperm(0) 0
8698 set viewargs(0) {}
8699 set viewargscmd(0) {}
8701 set cmdlineok 0
8702 set stopped 0
8703 set stuffsaved 0
8704 set patchnum 0
8705 set localirow -1
8706 set localfrow -1
8707 set lserial 0
8708 set isworktree [expr {[exec git rev-parse --is-inside-work-tree] == "true"}]
8709 setcoords
8710 makewindow
8711 # wait for the window to become visible
8712 tkwait visibility .
8713 wm title . "[file tail $argv0]: [file tail [pwd]]"
8714 readrefs
8716 if {$cmdline_files ne {} || $revtreeargs ne {} || $revtreeargscmd ne {}} {
8717     # create a view for the files/dirs specified on the command line
8718     set curview 1
8719     set selectedview 1
8720     set nextviewnum 2
8721     set viewname(1) [mc "Command line"]
8722     set viewfiles(1) $cmdline_files
8723     set viewargs(1) $revtreeargs
8724     set viewargscmd(1) $revtreeargscmd
8725     set viewperm(1) 0
8726     addviewmenu 1
8727     .bar.view entryconf [mc "Edit view..."] -state normal
8728     .bar.view entryconf [mc "Delete view"] -state normal
8731 if {[info exists permviews]} {
8732     foreach v $permviews {
8733         set n $nextviewnum
8734         incr nextviewnum
8735         set viewname($n) [lindex $v 0]
8736         set viewfiles($n) [lindex $v 1]
8737         set viewargs($n) [lindex $v 2]
8738         set viewargscmd($n) [lindex $v 3]
8739         set viewperm($n) 1
8740         addviewmenu $n
8741     }
8743 getcommits