Code

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