##// END OF EJS Templates
Convert hgk to use the hgit extension, and upate to the latest gitk
mason@suse.com -
r1240:cc756ffd default
parent child Browse files
Show More
This diff has been collapsed as it changes many lines, (3241 lines changed) Show them Hide them
@@ -1,1448 +1,3651 b''
1 #!/bin/sh
1 #!/bin/sh
2 # Tcl ignores the next line -*- tcl -*- \
2 # Tcl ignores the next line -*- tcl -*- \
3 exec wish "$0" -- "${1+$@}"
3 exec wish "$0" -- "${1+$@}"
4
4
5 # Copyright (C) 2005 Paul Mackerras. All rights reserved.
5 # Copyright (C) 2005 Paul Mackerras. All rights reserved.
6 # This program is free software; it may be used, copied, modified
6 # This program is free software; it may be used, copied, modified
7 # and distributed under the terms of the GNU General Public Licence,
7 # and distributed under the terms of the GNU General Public Licence,
8 # either version 2, or (at your option) any later version.
8 # either version 2, or (at your option) any later version.
9
9
10 # CVS $Revision: 1.20 $
10 proc gitdir {} {
11 global env
12 if {[info exists env(GIT_DIR)]} {
13 return $env(GIT_DIR)
14 } else {
15 return ".hg"
16 }
17 }
11
18
12 proc readfullcommits {rargs} {
19 proc getcommits {rargs} {
13 global commits commfd phase canv mainfont curcommit allcommitstate
20 global commits commfd phase canv mainfont env
14 if {$rargs == {}} {
21 global startmsecs nextupdate ncmupdate
15 set rargs HEAD
22 global ctext maincursor textcursor leftover
23
24 # check that we can find a .git directory somewhere...
25 set gitdir [gitdir]
26 if {![file isdirectory $gitdir]} {
27 error_popup "Cannot find the git directory \"$gitdir\"."
28 exit 1
16 }
29 }
17 set commits {}
30 set commits {}
18 set curcommit {}
19 set allcommitstate none
20 set phase getcommits
31 set phase getcommits
21 if [catch {set commfd [open "|hgit rev-list -c $rargs" r]} err] {
32 set startmsecs [clock clicks -milliseconds]
22 puts stderr "Error executing hgit rev-list: $err"
33 set nextupdate [expr $startmsecs + 100]
34 set ncmupdate 1
35 if [catch {
36 set parse_args [concat --default HEAD $rargs]
37 set parsed_args [split [eval exec hg git-rev-parse $parse_args] "\n"]
38 }] {
39 # if git-rev-parse failed for some reason...
40 if {$rargs == {}} {
41 set rargs HEAD
42 }
43 set parsed_args $rargs
44 }
45 if [catch {
46 set commfd [open "|hg git-rev-list --header --topo-order --parents $parsed_args" r]
47 } err] {
48 puts stderr "Error executing hg git-rev-list: $err"
23 exit 1
49 exit 1
24 }
50 }
25 fconfigure $commfd -blocking 0
51 set leftover {}
26 fileevent $commfd readable "getallcommitline $commfd"
52 fconfigure $commfd -blocking 0 -translation lf
53 fileevent $commfd readable [list getcommitlines $commfd]
27 $canv delete all
54 $canv delete all
28 $canv create text 3 3 -anchor nw -text "Reading all commits..." \
55 $canv create text 3 3 -anchor nw -text "Reading commits..." \
29 -font $mainfont -tags textitems
56 -font $mainfont -tags textitems
57 . config -cursor watch
58 settextcursor watch
30 }
59 }
31
60
32 proc getcommitline {commfd} {
61 proc getcommitlines {commfd} {
33 global commits parents cdate nparents children nchildren
62 global commits parents cdate children
34 set n [gets $commfd line]
63 global commitlisted phase commitinfo nextupdate
35 if {$n < 0} {
64 global stopped redisplaying leftover
65
66 set stuff [read $commfd]
67 if {$stuff == {}} {
36 if {![eof $commfd]} return
68 if {![eof $commfd]} return
37 # this works around what is apparently a bug in Tcl...
69 # set it blocking so we wait for the process to terminate
38 fconfigure $commfd -blocking 1
70 fconfigure $commfd -blocking 1
39 if {![catch {close $commfd} err]} {
71 if {![catch {close $commfd} err]} {
40 after idle readallcommits
72 after idle finishcommits
41 return
73 return
42 }
74 }
43 if {[string range $err 0 4] == "usage"} {
75 if {[string range $err 0 4] == "usage"} {
44 set err "\
76 set err \
45 Gitk: error reading commits: bad arguments to hgit rev-list.\n\
77 {Gitk: error reading commits: bad arguments to git-rev-list.
46 (Note: arguments to gitk are passed to hgit rev-list\
78 (Note: arguments to gitk are passed to git-rev-list
47 to allow selection of commits to be displayed.)"
79 to allow selection of commits to be displayed.)}
48 } else {
80 } else {
49 set err "Error reading commits: $err"
81 set err "Error reading commits: $err"
50 }
82 }
51 error_popup $err
83 error_popup $err
52 exit 1
84 exit 1
53 }
85 }
54 if {![regexp {^[0-9a-f]{40}$} $line]} {
86 set start 0
55 error_popup "Can't parse hgit rev-tree output: {$line}"
87 while 1 {
88 set i [string first "\0" $stuff $start]
89 if {$i < 0} {
90 append leftover [string range $stuff $start end]
91 return
92 }
93 set cmit [string range $stuff $start [expr {$i - 1}]]
94 if {$start == 0} {
95 set cmit "$leftover$cmit"
96 set leftover {}
97 }
98 set start [expr {$i + 1}]
99 set j [string first "\n" $cmit]
100 set ok 0
101 if {$j >= 0} {
102 set ids [string range $cmit 0 [expr {$j - 1}]]
103 set ok 1
104 foreach id $ids {
105 if {![regexp {^[0-9a-f]{40}$} $id]} {
106 set ok 0
107 break
108 }
109 }
110 }
111 if {!$ok} {
112 set shortcmit $cmit
113 if {[string length $shortcmit] > 80} {
114 set shortcmit "[string range $shortcmit 0 80]..."
115 }
116 error_popup "Can't parse hg git-rev-list output: {$shortcmit}"
56 exit 1
117 exit 1
57 }
118 }
58 lappend commits $line
119 set id [lindex $ids 0]
120 set olds [lrange $ids 1 end]
121 set cmit [string range $cmit [expr {$j + 1}] end]
122 lappend commits $id
123 set commitlisted($id) 1
124 parsecommit $id $cmit 1 [lrange $ids 1 end]
125 drawcommit $id
126 if {[clock clicks -milliseconds] >= $nextupdate} {
127 doupdate 1
128 }
129 while {$redisplaying} {
130 set redisplaying 0
131 if {$stopped == 1} {
132 set stopped 0
133 set phase "getcommits"
134 foreach id $commits {
135 drawcommit $id
136 if {$stopped} break
137 if {[clock clicks -milliseconds] >= $nextupdate} {
138 doupdate 1
139 }
140 }
141 }
142 }
143 }
59 }
144 }
60
145
61 proc readallcommits {} {
146 proc doupdate {reading} {
62 global commits
147 global commfd nextupdate numcommits ncmupdate
63 foreach id $commits {
148
64 readcommit $id
149 if {$reading} {
150 fileevent $commfd readable {}
151 }
65 update
152 update
66 }
153 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
67 drawgraph
154 if {$numcommits < 100} {
155 set ncmupdate [expr {$numcommits + 1}]
156 } elseif {$numcommits < 10000} {
157 set ncmupdate [expr {$numcommits + 10}]
158 } else {
159 set ncmupdate [expr {$numcommits + 100}]
160 }
161 if {$reading} {
162 fileevent $commfd readable [list getcommitlines $commfd]
163 }
68 }
164 }
69
165
70 proc readonecommit {id contents} {
166 proc readcommit {id} {
71 global commitinfo children nchildren parents nparents cdate
167 if [catch {set contents [exec hg git-cat-file commit $id]}] return
168 parsecommit $id $contents 0 {}
169 }
170
171 proc parsecommit {id contents listed olds} {
172 global commitinfo children nchildren parents nparents cdate ncleft
173
72 set inhdr 1
174 set inhdr 1
73 set comment {}
175 set comment {}
74 set headline {}
176 set headline {}
75 set auname {}
177 set auname {}
76 set audate {}
178 set audate {}
77 set comname {}
179 set comname {}
78 set comdate {}
180 set comdate {}
79 if {![info exists nchildren($id)]} {
181 if {![info exists nchildren($id)]} {
80 set children($id) {}
182 set children($id) {}
81 set nchildren($id) 0
183 set nchildren($id) 0
82 }
184 set ncleft($id) 0
83 set parents($id) {}
185 }
84 set nparents($id) 0
186 set parents($id) $olds
187 set nparents($id) [llength $olds]
188 foreach p $olds {
189 if {![info exists nchildren($p)]} {
190 set children($p) [list $id]
191 set nchildren($p) 1
192 set ncleft($p) 1
193 } elseif {[lsearch -exact $children($p) $id] < 0} {
194 lappend children($p) $id
195 incr nchildren($p)
196 incr ncleft($p)
197 }
198 }
85 foreach line [split $contents "\n"] {
199 foreach line [split $contents "\n"] {
86 if {$inhdr} {
200 if {$inhdr} {
87 if {$line == {}} {
201 if {$line == {}} {
88 set inhdr 0
202 set inhdr 0
89 } else {
203 } else {
90 set tag [lindex $line 0]
204 set tag [lindex $line 0]
91 if {$tag == "parent"} {
205 if {$tag == "author"} {
92 set p [lindex $line 1]
93 if {![info exists nchildren($p)]} {
94 set children($p) {}
95 set nchildren($p) 0
96 }
97 lappend parents($id) $p
98 incr nparents($id)
99 if {[lsearch -exact $children($p) $id] < 0} {
100 lappend children($p) $id
101 incr nchildren($p)
102 }
103 } elseif {$tag == "author"} {
104 set x [expr {[llength $line] - 2}]
206 set x [expr {[llength $line] - 2}]
105 set audate [lindex $line $x]
207 set audate [lindex $line $x]
106 set auname [lrange $line 1 [expr {$x - 1}]]
208 set auname [lrange $line 1 [expr {$x - 1}]]
107 } elseif {$tag == "committer"} {
209 } elseif {$tag == "committer"} {
108 set x [expr {[llength $line] - 2}]
210 set x [expr {[llength $line] - 2}]
109 set comdate [lindex $line $x]
211 set comdate [lindex $line $x]
110 set comname [lrange $line 1 [expr {$x - 1}]]
212 set comname [lrange $line 1 [expr {$x - 1}]]
111 }
213 }
112 }
214 }
113 } else {
215 } else {
114 if {$comment == {}} {
216 if {$comment == {}} {
115 set headline $line
217 set headline [string trim $line]
116 } else {
218 } else {
117 append comment "\n"
219 append comment "\n"
118 }
220 }
221 if {!$listed} {
222 # git-rev-list indents the comment by 4 spaces;
223 # if we got this via git-cat-file, add the indentation
224 append comment " "
225 }
119 append comment $line
226 append comment $line
120 }
227 }
121 }
228 }
122 if {$audate != {}} {
229 if {$audate != {}} {
123 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
230 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
124 }
231 }
125 if {$comdate != {}} {
232 if {$comdate != {}} {
126 set cdate($id) $comdate
233 set cdate($id) $comdate
127 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
234 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
128 }
235 }
129 set commitinfo($id) [list $headline $auname $audate \
236 set commitinfo($id) [list $headline $auname $audate \
130 $comname $comdate $comment]
237 $comname $comdate $comment]
131 }
238 }
132
239
133 proc getallcommitline {commfd} {
240 proc readrefs {} {
134 global commits allcommitstate curcommit curcommitid
241 global tagids idtags headids idheads tagcontents
135 set n [gets $commfd line]
242
136 set s "\n"
243 set tags [exec hg tags]
137 if {$n < 0} {
244 set lines [split $tags '\n']
138 if {![eof $commfd]} return
245 foreach f $lines {
139 # this works around what is apparently a bug in Tcl...
246 set f [regexp -all -inline {\S+} $f]
140 fconfigure $commfd -blocking 1
247 set direct [lindex $f 0]
141 if {![catch {close $commfd} err]} {
248 set full [lindex $f 1]
142 if {$allcommitstate == "indent"} {
249 set sha [split $full ':']
143 readonecommit $curcommitid $curcommit
250 set tag [lindex $sha 1]
144 }
251 lappend tagids($direct) $tag
145 after idle drawgraph
252 lappend idtags($tag) $direct
146 return
147 }
148 if {[string range $err 0 4] == "usage"} {
149 set err "\
150 Gitk: error reading commits: bad arguments to hgit rev-list.\n\
151 (Note: arguments to gitk are passed to hgit rev-list\
152 to allow selection of commits to be displayed.)"
153 } else {
154 set err "Error reading commits: $err"
155 }
156 error_popup $err
157 exit 1
158 }
159 if {[string range $line 0 1] != " "} {
160 if {$allcommitstate == "indent"} {
161 readonecommit $curcommitid $curcommit
162 }
163 if {$allcommitstate == "start"} {
164 set curcommit $curcommit$line$s
165 set allcommitstate "indent"
166 } else {
167 set curcommitid $line
168 set curcommit {}
169 set allcommitstate "start"
170 lappend commits $line
171 }
172 } else {
173 set d [string range $line 2 end]
174 set curcommit $curcommit$d$s
175 }
253 }
176 }
254 }
177
255
178 proc getcommits {rargs} {
256 proc readotherrefs {base dname excl} {
179 global commits commfd phase canv mainfont
257 global otherrefids idotherrefs
180 if {$rargs == {}} {
181 set rargs HEAD
182 }
183 set commits {}
184 set phase getcommits
185 if [catch {set commfd [open "|hgit rev-list $rargs" r]} err] {
186 puts stderr "Error executing hgit rev-list: $err"
187 exit 1
188 }
189 fconfigure $commfd -blocking 0
190 fileevent $commfd readable "getcommitline $commfd"
191 $canv delete all
192 $canv create text 3 3 -anchor nw -text "Reading commits..." \
193 -font $mainfont -tags textitems
194 }
195
258
196 proc readcommit {id} {
259 set git [gitdir]
197 global commitinfo children nchildren parents nparents cdate
260 set files [glob -nocomplain -types f [file join $git $base *]]
198 set inhdr 1
261 foreach f $files {
199 set comment {}
200 set headline {}
201 set auname {}
202 set audate {}
203 set comname {}
204 set comdate {}
205 if {![info exists nchildren($id)]} {
206 set children($id) {}
207 set nchildren($id) 0
208 }
209 set parents($id) {}
210 set nparents($id) 0
211 if [catch {set contents [exec hgit cat-file commit $id]}] return
212 readonecommit $id $contents
213 }
214
215 proc readrefs {} {
216 global tagids idtags
217 set tags [glob -nocomplain -types f .git/refs/tags/*]
218 foreach f $tags {
219 catch {
262 catch {
220 set fd [open $f r]
263 set fd [open $f r]
221 set line [read $fd]
264 set line [read $fd 40]
222 if {[regexp {^[0-9a-f]{40}} $line id]} {
265 if {[regexp {^[0-9a-f]{40}} $line id]} {
223 set contents [split [exec hgit cat-file tag $id] "\n"]
266 set name "$dname[file tail $f]"
224 set obj {}
267 set otherrefids($name) $id
225 set type {}
268 lappend idotherrefs($id) $name
226 set tag {}
269 }
227 foreach l $contents {
270 close $fd
228 if {$l == {}} break
271 }
229 switch -- [lindex $l 0] {
272 }
230 "object" {set obj [lindex $l 1]}
273 set dirs [glob -nocomplain -types d [file join $git $base *]]
231 "type" {set type [lindex $l 1]}
274 foreach d $dirs {
232 "tag" {set tag [string range $l 4 end]}
275 set dir [file tail $d]
233 }
276 if {[lsearch -exact $excl $dir] >= 0} continue
234 }
277 readotherrefs [file join $base $dir] "$dname$dir/" {}
235 if {$obj != {} && $type == "commit" && $tag != {}} {
236 set tagids($tag) $obj
237 lappend idtags($obj) $tag
238 }
239 }
240 }
241 }
278 }
242 }
279 }
243
280
244 proc error_popup msg {
281 proc error_popup msg {
245 set w .error
282 set w .error
246 toplevel $w
283 toplevel $w
247 wm transient $w .
284 wm transient $w .
248 message $w.m -text $msg -justify center -aspect 400
285 message $w.m -text $msg -justify center -aspect 400
249 pack $w.m -side top -fill x -padx 20 -pady 20
286 pack $w.m -side top -fill x -padx 20 -pady 20
250 button $w.ok -text OK -command "destroy $w"
287 button $w.ok -text OK -command "destroy $w"
251 pack $w.ok -side bottom -fill x
288 pack $w.ok -side bottom -fill x
252 bind $w <Visibility> "grab $w; focus $w"
289 bind $w <Visibility> "grab $w; focus $w"
253 tkwait window $w
290 tkwait window $w
254 }
291 }
255
292
256 proc makewindow {} {
293 proc makewindow {} {
257 global canv canv2 canv3 linespc charspc ctext cflist textfont
294 global canv canv2 canv3 linespc charspc ctext cflist textfont
258 global findtype findloc findstring fstring geometry
295 global findtype findtypemenu findloc findstring fstring geometry
259 global entries sha1entry sha1string sha1but
296 global entries sha1entry sha1string sha1but
297 global maincursor textcursor curtextcursor
298 global rowctxmenu gaudydiff mergemax
260
299
261 menu .bar
300 menu .bar
262 .bar add cascade -label "File" -menu .bar.file
301 .bar add cascade -label "File" -menu .bar.file
263 menu .bar.file
302 menu .bar.file
303 .bar.file add command -label "Reread references" -command rereadrefs
264 .bar.file add command -label "Quit" -command doquit
304 .bar.file add command -label "Quit" -command doquit
265 menu .bar.help
305 menu .bar.help
266 .bar add cascade -label "Help" -menu .bar.help
306 .bar add cascade -label "Help" -menu .bar.help
267 .bar.help add command -label "About gitk" -command about
307 .bar.help add command -label "About gitk" -command about
268 . configure -menu .bar
308 . configure -menu .bar
269
309
270 if {![info exists geometry(canv1)]} {
310 if {![info exists geometry(canv1)]} {
271 set geometry(canv1) [expr 45 * $charspc]
311 set geometry(canv1) [expr 45 * $charspc]
272 set geometry(canv2) [expr 30 * $charspc]
312 set geometry(canv2) [expr 30 * $charspc]
273 set geometry(canv3) [expr 15 * $charspc]
313 set geometry(canv3) [expr 15 * $charspc]
274 set geometry(canvh) [expr 25 * $linespc + 4]
314 set geometry(canvh) [expr 25 * $linespc + 4]
275 set geometry(ctextw) 80
315 set geometry(ctextw) 80
276 set geometry(ctexth) 30
316 set geometry(ctexth) 30
277 set geometry(cflistw) 30
317 set geometry(cflistw) 30
278 }
318 }
279 panedwindow .ctop -orient vertical
319 panedwindow .ctop -orient vertical
280 if {[info exists geometry(width)]} {
320 if {[info exists geometry(width)]} {
281 .ctop conf -width $geometry(width) -height $geometry(height)
321 .ctop conf -width $geometry(width) -height $geometry(height)
282 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
322 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
283 set geometry(ctexth) [expr {($texth - 8) /
323 set geometry(ctexth) [expr {($texth - 8) /
284 [font metrics $textfont -linespace]}]
324 [font metrics $textfont -linespace]}]
285 }
325 }
286 frame .ctop.top
326 frame .ctop.top
287 frame .ctop.top.bar
327 frame .ctop.top.bar
288 pack .ctop.top.bar -side bottom -fill x
328 pack .ctop.top.bar -side bottom -fill x
289 set cscroll .ctop.top.csb
329 set cscroll .ctop.top.csb
290 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
330 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
291 pack $cscroll -side right -fill y
331 pack $cscroll -side right -fill y
292 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
332 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
293 pack .ctop.top.clist -side top -fill both -expand 1
333 pack .ctop.top.clist -side top -fill both -expand 1
294 .ctop add .ctop.top
334 .ctop add .ctop.top
295 set canv .ctop.top.clist.canv
335 set canv .ctop.top.clist.canv
296 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
336 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
297 -bg white -bd 0 \
337 -bg white -bd 0 \
298 -yscrollincr $linespc -yscrollcommand "$cscroll set"
338 -yscrollincr $linespc -yscrollcommand "$cscroll set"
299 .ctop.top.clist add $canv
339 .ctop.top.clist add $canv
300 set canv2 .ctop.top.clist.canv2
340 set canv2 .ctop.top.clist.canv2
301 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
341 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
302 -bg white -bd 0 -yscrollincr $linespc
342 -bg white -bd 0 -yscrollincr $linespc
303 .ctop.top.clist add $canv2
343 .ctop.top.clist add $canv2
304 set canv3 .ctop.top.clist.canv3
344 set canv3 .ctop.top.clist.canv3
305 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
345 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
306 -bg white -bd 0 -yscrollincr $linespc
346 -bg white -bd 0 -yscrollincr $linespc
307 .ctop.top.clist add $canv3
347 .ctop.top.clist add $canv3
308 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
348 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
309
349
310 set sha1entry .ctop.top.bar.sha1
350 set sha1entry .ctop.top.bar.sha1
311 set entries $sha1entry
351 set entries $sha1entry
312 set sha1but .ctop.top.bar.sha1label
352 set sha1but .ctop.top.bar.sha1label
313 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
353 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
314 -command gotocommit -width 8
354 -command gotocommit -width 8
315 $sha1but conf -disabledforeground [$sha1but cget -foreground]
355 $sha1but conf -disabledforeground [$sha1but cget -foreground]
316 pack .ctop.top.bar.sha1label -side left
356 pack .ctop.top.bar.sha1label -side left
317 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
357 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
318 trace add variable sha1string write sha1change
358 trace add variable sha1string write sha1change
319 pack $sha1entry -side left -pady 2
359 pack $sha1entry -side left -pady 2
360
361 image create bitmap bm-left -data {
362 #define left_width 16
363 #define left_height 16
364 static unsigned char left_bits[] = {
365 0x00, 0x00, 0xc0, 0x01, 0xe0, 0x00, 0x70, 0x00, 0x38, 0x00, 0x1c, 0x00,
366 0x0e, 0x00, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x0e, 0x00, 0x1c, 0x00,
367 0x38, 0x00, 0x70, 0x00, 0xe0, 0x00, 0xc0, 0x01};
368 }
369 image create bitmap bm-right -data {
370 #define right_width 16
371 #define right_height 16
372 static unsigned char right_bits[] = {
373 0x00, 0x00, 0xc0, 0x01, 0x80, 0x03, 0x00, 0x07, 0x00, 0x0e, 0x00, 0x1c,
374 0x00, 0x38, 0xff, 0x7f, 0xff, 0x7f, 0xff, 0x7f, 0x00, 0x38, 0x00, 0x1c,
375 0x00, 0x0e, 0x00, 0x07, 0x80, 0x03, 0xc0, 0x01};
376 }
377 button .ctop.top.bar.leftbut -image bm-left -command goback \
378 -state disabled -width 26
379 pack .ctop.top.bar.leftbut -side left -fill y
380 button .ctop.top.bar.rightbut -image bm-right -command goforw \
381 -state disabled -width 26
382 pack .ctop.top.bar.rightbut -side left -fill y
383
320 button .ctop.top.bar.findbut -text "Find" -command dofind
384 button .ctop.top.bar.findbut -text "Find" -command dofind
321 pack .ctop.top.bar.findbut -side left
385 pack .ctop.top.bar.findbut -side left
322 set findstring {}
386 set findstring {}
323 set fstring .ctop.top.bar.findstring
387 set fstring .ctop.top.bar.findstring
324 lappend entries $fstring
388 lappend entries $fstring
325 entry $fstring -width 30 -font $textfont -textvariable findstring
389 entry $fstring -width 30 -font $textfont -textvariable findstring
326 pack $fstring -side left -expand 1 -fill x
390 pack $fstring -side left -expand 1 -fill x
327 set findtype Exact
391 set findtype Exact
328 tk_optionMenu .ctop.top.bar.findtype findtype Exact IgnCase Regexp
392 set findtypemenu [tk_optionMenu .ctop.top.bar.findtype \
393 findtype Exact IgnCase Regexp]
329 set findloc "All fields"
394 set findloc "All fields"
330 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
395 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
331 Comments Author Committer
396 Comments Author Committer Files Pickaxe
332 pack .ctop.top.bar.findloc -side right
397 pack .ctop.top.bar.findloc -side right
333 pack .ctop.top.bar.findtype -side right
398 pack .ctop.top.bar.findtype -side right
399 # for making sure type==Exact whenever loc==Pickaxe
400 trace add variable findloc write findlocchange
334
401
335 panedwindow .ctop.cdet -orient horizontal
402 panedwindow .ctop.cdet -orient horizontal
336 .ctop add .ctop.cdet
403 .ctop add .ctop.cdet
337 frame .ctop.cdet.left
404 frame .ctop.cdet.left
338 set ctext .ctop.cdet.left.ctext
405 set ctext .ctop.cdet.left.ctext
339 text $ctext -bg white -state disabled -font $textfont \
406 text $ctext -bg white -state disabled -font $textfont \
340 -width $geometry(ctextw) -height $geometry(ctexth) \
407 -width $geometry(ctextw) -height $geometry(ctexth) \
341 -yscrollcommand ".ctop.cdet.left.sb set"
408 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
342 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
409 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
343 pack .ctop.cdet.left.sb -side right -fill y
410 pack .ctop.cdet.left.sb -side right -fill y
344 pack $ctext -side left -fill both -expand 1
411 pack $ctext -side left -fill both -expand 1
345 .ctop.cdet add .ctop.cdet.left
412 .ctop.cdet add .ctop.cdet.left
346
413
347 $ctext tag conf filesep -font [concat $textfont bold]
414 $ctext tag conf filesep -font [concat $textfont bold] -back "#aaaaaa"
415 if {$gaudydiff} {
348 $ctext tag conf hunksep -back blue -fore white
416 $ctext tag conf hunksep -back blue -fore white
349 $ctext tag conf d0 -back "#ff8080"
417 $ctext tag conf d0 -back "#ff8080"
350 $ctext tag conf d1 -back green
418 $ctext tag conf d1 -back green
419 } else {
420 $ctext tag conf hunksep -fore blue
421 $ctext tag conf d0 -fore red
422 $ctext tag conf d1 -fore "#00a000"
423 $ctext tag conf m0 -fore red
424 $ctext tag conf m1 -fore blue
425 $ctext tag conf m2 -fore green
426 $ctext tag conf m3 -fore purple
427 $ctext tag conf m4 -fore brown
428 $ctext tag conf mmax -fore darkgrey
429 set mergemax 5
430 $ctext tag conf mresult -font [concat $textfont bold]
431 $ctext tag conf msep -font [concat $textfont bold]
351 $ctext tag conf found -back yellow
432 $ctext tag conf found -back yellow
433 }
352
434
353 frame .ctop.cdet.right
435 frame .ctop.cdet.right
354 set cflist .ctop.cdet.right.cfiles
436 set cflist .ctop.cdet.right.cfiles
355 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
437 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
356 -yscrollcommand ".ctop.cdet.right.sb set"
438 -yscrollcommand ".ctop.cdet.right.sb set"
357 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
439 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
358 pack .ctop.cdet.right.sb -side right -fill y
440 pack .ctop.cdet.right.sb -side right -fill y
359 pack $cflist -side left -fill both -expand 1
441 pack $cflist -side left -fill both -expand 1
360 .ctop.cdet add .ctop.cdet.right
442 .ctop.cdet add .ctop.cdet.right
361 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
443 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
362
444
363 pack .ctop -side top -fill both -expand 1
445 pack .ctop -side top -fill both -expand 1
364
446
365 bindall <1> {selcanvline %x %y}
447 bindall <1> {selcanvline %W %x %y}
366 bindall <B1-Motion> {selcanvline %x %y}
448 #bindall <B1-Motion> {selcanvline %W %x %y}
367 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
449 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
368 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
450 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
369 bindall <2> "allcanvs scan mark 0 %y"
451 bindall <2> "allcanvs scan mark 0 %y"
370 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
452 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
371 bind . <Key-Up> "selnextline -1"
453 bind . <Key-Up> "selnextline -1"
372 bind . <Key-Down> "selnextline 1"
454 bind . <Key-Down> "selnextline 1"
373 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
455 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
374 bind . <Key-Next> "allcanvs yview scroll 1 pages"
456 bind . <Key-Next> "allcanvs yview scroll 1 pages"
375 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
457 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
376 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
458 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
377 bindkey <Key-space> "$ctext yview scroll 1 pages"
459 bindkey <Key-space> "$ctext yview scroll 1 pages"
378 bindkey p "selnextline -1"
460 bindkey p "selnextline -1"
379 bindkey n "selnextline 1"
461 bindkey n "selnextline 1"
380 bindkey b "$ctext yview scroll -1 pages"
462 bindkey b "$ctext yview scroll -1 pages"
381 bindkey d "$ctext yview scroll 18 units"
463 bindkey d "$ctext yview scroll 18 units"
382 bindkey u "$ctext yview scroll -18 units"
464 bindkey u "$ctext yview scroll -18 units"
383 bindkey / findnext
465 bindkey / {findnext 1}
466 bindkey <Key-Return> {findnext 0}
384 bindkey ? findprev
467 bindkey ? findprev
385 bindkey f nextfile
468 bindkey f nextfile
386 bind . <Control-q> doquit
469 bind . <Control-q> doquit
387 bind . <Control-f> dofind
470 bind . <Control-f> dofind
388 bind . <Control-g> findnext
471 bind . <Control-g> {findnext 0}
389 bind . <Control-r> findprev
472 bind . <Control-r> findprev
390 bind . <Control-equal> {incrfont 1}
473 bind . <Control-equal> {incrfont 1}
391 bind . <Control-KP_Add> {incrfont 1}
474 bind . <Control-KP_Add> {incrfont 1}
392 bind . <Control-minus> {incrfont -1}
475 bind . <Control-minus> {incrfont -1}
393 bind . <Control-KP_Subtract> {incrfont -1}
476 bind . <Control-KP_Subtract> {incrfont -1}
394 bind $cflist <<ListboxSelect>> listboxsel
477 bind $cflist <<ListboxSelect>> listboxsel
395 bind . <Destroy> {savestuff %W}
478 bind . <Destroy> {savestuff %W}
396 bind . <Button-1> "click %W"
479 bind . <Button-1> "click %W"
397 bind $fstring <Key-Return> dofind
480 bind $fstring <Key-Return> dofind
398 bind $sha1entry <Key-Return> gotocommit
481 bind $sha1entry <Key-Return> gotocommit
482 bind $sha1entry <<PasteSelection>> clearsha1
483
484 set maincursor [. cget -cursor]
485 set textcursor [$ctext cget -cursor]
486 set curtextcursor $textcursor
487
488 set rowctxmenu .rowctxmenu
489 menu $rowctxmenu -tearoff 0
490 $rowctxmenu add command -label "Diff this -> selected" \
491 -command {diffvssel 0}
492 $rowctxmenu add command -label "Diff selected -> this" \
493 -command {diffvssel 1}
494 $rowctxmenu add command -label "Make patch" -command mkpatch
495 $rowctxmenu add command -label "Create tag" -command mktag
496 $rowctxmenu add command -label "Write commit to file" -command writecommit
399 }
497 }
400
498
401 # when we make a key binding for the toplevel, make sure
499 # when we make a key binding for the toplevel, make sure
402 # it doesn't get triggered when that key is pressed in the
500 # it doesn't get triggered when that key is pressed in the
403 # find string entry widget.
501 # find string entry widget.
404 proc bindkey {ev script} {
502 proc bindkey {ev script} {
405 global entries
503 global entries
406 bind . $ev $script
504 bind . $ev $script
407 set escript [bind Entry $ev]
505 set escript [bind Entry $ev]
408 if {$escript == {}} {
506 if {$escript == {}} {
409 set escript [bind Entry <Key>]
507 set escript [bind Entry <Key>]
410 }
508 }
411 foreach e $entries {
509 foreach e $entries {
412 bind $e $ev "$escript; break"
510 bind $e $ev "$escript; break"
413 }
511 }
414 }
512 }
415
513
416 # set the focus back to the toplevel for any click outside
514 # set the focus back to the toplevel for any click outside
417 # the entry widgets
515 # the entry widgets
418 proc click {w} {
516 proc click {w} {
419 global entries
517 global entries
420 foreach e $entries {
518 foreach e $entries {
421 if {$w == $e} return
519 if {$w == $e} return
422 }
520 }
423 focus .
521 focus .
424 }
522 }
425
523
426 proc savestuff {w} {
524 proc savestuff {w} {
427 global canv canv2 canv3 ctext cflist mainfont textfont
525 global canv canv2 canv3 ctext cflist mainfont textfont
428 global stuffsaved
526 global stuffsaved findmergefiles gaudydiff maxgraphpct
527 global maxwidth
528
429 if {$stuffsaved} return
529 if {$stuffsaved} return
430 if {![winfo viewable .]} return
530 if {![winfo viewable .]} return
431 catch {
531 catch {
432 set f [open "~/.gitk-new" w]
532 set f [open "~/.gitk-new" w]
433 puts $f "set mainfont {$mainfont}"
533 puts $f [list set mainfont $mainfont]
434 puts $f "set textfont {$textfont}"
534 puts $f [list set textfont $textfont]
535 puts $f [list set findmergefiles $findmergefiles]
536 puts $f [list set gaudydiff $gaudydiff]
537 puts $f [list set maxgraphpct $maxgraphpct]
538 puts $f [list set maxwidth $maxwidth]
435 puts $f "set geometry(width) [winfo width .ctop]"
539 puts $f "set geometry(width) [winfo width .ctop]"
436 puts $f "set geometry(height) [winfo height .ctop]"
540 puts $f "set geometry(height) [winfo height .ctop]"
437 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
541 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
438 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
542 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
439 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
543 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
440 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
544 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
441 set wid [expr {([winfo width $ctext] - 8) \
545 set wid [expr {([winfo width $ctext] - 8) \
442 / [font measure $textfont "0"]}]
546 / [font measure $textfont "0"]}]
443 puts $f "set geometry(ctextw) $wid"
547 puts $f "set geometry(ctextw) $wid"
444 set wid [expr {([winfo width $cflist] - 11) \
548 set wid [expr {([winfo width $cflist] - 11) \
445 / [font measure [$cflist cget -font] "0"]}]
549 / [font measure [$cflist cget -font] "0"]}]
446 puts $f "set geometry(cflistw) $wid"
550 puts $f "set geometry(cflistw) $wid"
447 close $f
551 close $f
448 file rename -force "~/.gitk-new" "~/.gitk"
552 file rename -force "~/.gitk-new" "~/.gitk"
449 }
553 }
450 set stuffsaved 1
554 set stuffsaved 1
451 }
555 }
452
556
453 proc resizeclistpanes {win w} {
557 proc resizeclistpanes {win w} {
454 global oldwidth
558 global oldwidth
455 if [info exists oldwidth($win)] {
559 if [info exists oldwidth($win)] {
456 set s0 [$win sash coord 0]
560 set s0 [$win sash coord 0]
457 set s1 [$win sash coord 1]
561 set s1 [$win sash coord 1]
458 if {$w < 60} {
562 if {$w < 60} {
459 set sash0 [expr {int($w/2 - 2)}]
563 set sash0 [expr {int($w/2 - 2)}]
460 set sash1 [expr {int($w*5/6 - 2)}]
564 set sash1 [expr {int($w*5/6 - 2)}]
461 } else {
565 } else {
462 set factor [expr {1.0 * $w / $oldwidth($win)}]
566 set factor [expr {1.0 * $w / $oldwidth($win)}]
463 set sash0 [expr {int($factor * [lindex $s0 0])}]
567 set sash0 [expr {int($factor * [lindex $s0 0])}]
464 set sash1 [expr {int($factor * [lindex $s1 0])}]
568 set sash1 [expr {int($factor * [lindex $s1 0])}]
465 if {$sash0 < 30} {
569 if {$sash0 < 30} {
466 set sash0 30
570 set sash0 30
467 }
571 }
468 if {$sash1 < $sash0 + 20} {
572 if {$sash1 < $sash0 + 20} {
469 set sash1 [expr $sash0 + 20]
573 set sash1 [expr $sash0 + 20]
470 }
574 }
471 if {$sash1 > $w - 10} {
575 if {$sash1 > $w - 10} {
472 set sash1 [expr $w - 10]
576 set sash1 [expr $w - 10]
473 if {$sash0 > $sash1 - 20} {
577 if {$sash0 > $sash1 - 20} {
474 set sash0 [expr $sash1 - 20]
578 set sash0 [expr $sash1 - 20]
475 }
579 }
476 }
580 }
477 }
581 }
478 $win sash place 0 $sash0 [lindex $s0 1]
582 $win sash place 0 $sash0 [lindex $s0 1]
479 $win sash place 1 $sash1 [lindex $s1 1]
583 $win sash place 1 $sash1 [lindex $s1 1]
480 }
584 }
481 set oldwidth($win) $w
585 set oldwidth($win) $w
482 }
586 }
483
587
484 proc resizecdetpanes {win w} {
588 proc resizecdetpanes {win w} {
485 global oldwidth
589 global oldwidth
486 if [info exists oldwidth($win)] {
590 if [info exists oldwidth($win)] {
487 set s0 [$win sash coord 0]
591 set s0 [$win sash coord 0]
488 if {$w < 60} {
592 if {$w < 60} {
489 set sash0 [expr {int($w*3/4 - 2)}]
593 set sash0 [expr {int($w*3/4 - 2)}]
490 } else {
594 } else {
491 set factor [expr {1.0 * $w / $oldwidth($win)}]
595 set factor [expr {1.0 * $w / $oldwidth($win)}]
492 set sash0 [expr {int($factor * [lindex $s0 0])}]
596 set sash0 [expr {int($factor * [lindex $s0 0])}]
493 if {$sash0 < 45} {
597 if {$sash0 < 45} {
494 set sash0 45
598 set sash0 45
495 }
599 }
496 if {$sash0 > $w - 15} {
600 if {$sash0 > $w - 15} {
497 set sash0 [expr $w - 15]
601 set sash0 [expr $w - 15]
498 }
602 }
499 }
603 }
500 $win sash place 0 $sash0 [lindex $s0 1]
604 $win sash place 0 $sash0 [lindex $s0 1]
501 }
605 }
502 set oldwidth($win) $w
606 set oldwidth($win) $w
503 }
607 }
504
608
505 proc allcanvs args {
609 proc allcanvs args {
506 global canv canv2 canv3
610 global canv canv2 canv3
507 eval $canv $args
611 eval $canv $args
508 eval $canv2 $args
612 eval $canv2 $args
509 eval $canv3 $args
613 eval $canv3 $args
510 }
614 }
511
615
512 proc bindall {event action} {
616 proc bindall {event action} {
513 global canv canv2 canv3
617 global canv canv2 canv3
514 bind $canv $event $action
618 bind $canv $event $action
515 bind $canv2 $event $action
619 bind $canv2 $event $action
516 bind $canv3 $event $action
620 bind $canv3 $event $action
517 }
621 }
518
622
519 proc about {} {
623 proc about {} {
520 set w .about
624 set w .about
521 if {[winfo exists $w]} {
625 if {[winfo exists $w]} {
522 raise $w
626 raise $w
523 return
627 return
524 }
628 }
525 toplevel $w
629 toplevel $w
526 wm title $w "About gitk"
630 wm title $w "About gitk"
527 message $w.m -text {
631 message $w.m -text {
528 Gitk version 1.1
632 Gitk version 1.2
529
633
530 Copyright οΏ½ 2005 Paul Mackerras
634 Copyright οΏ½ 2005 Paul Mackerras
531
635
532 Use and redistribute under the terms of the GNU General Public License
636 Use and redistribute under the terms of the GNU General Public License} \
533
534 (CVS $Revision: 1.20 $)} \
535 -justify center -aspect 400
637 -justify center -aspect 400
536 pack $w.m -side top -fill x -padx 20 -pady 20
638 pack $w.m -side top -fill x -padx 20 -pady 20
537 button $w.ok -text Close -command "destroy $w"
639 button $w.ok -text Close -command "destroy $w"
538 pack $w.ok -side bottom
640 pack $w.ok -side bottom
539 }
641 }
540
642
541 proc truncatetofit {str width font} {
542 if {[font measure $font $str] <= $width} {
543 return $str
544 }
545 set best 0
546 set bad [string length $str]
547 set tmp $str
548 while {$best < $bad - 1} {
549 set try [expr {int(($best + $bad) / 2)}]
550 set tmp "[string range $str 0 [expr $try-1]]..."
551 if {[font measure $font $tmp] <= $width} {
552 set best $try
553 } else {
554 set bad $try
555 }
556 }
557 return $tmp
558 }
559
560 proc assigncolor {id} {
643 proc assigncolor {id} {
561 global commitinfo colormap commcolors colors nextcolor
644 global commitinfo colormap commcolors colors nextcolor
562 global colorbycommitter
563 global parents nparents children nchildren
645 global parents nparents children nchildren
646 global cornercrossings crossings
647
564 if [info exists colormap($id)] return
648 if [info exists colormap($id)] return
565 set ncolors [llength $colors]
649 set ncolors [llength $colors]
566 if {$colorbycommitter} {
650 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
567 if {![info exists commitinfo($id)]} {
568 readcommit $id
569 }
570 set comm [lindex $commitinfo($id) 3]
571 if {![info exists commcolors($comm)]} {
572 set commcolors($comm) [lindex $colors $nextcolor]
573 if {[incr nextcolor] >= $ncolors} {
574 set nextcolor 0
575 }
576 }
577 set colormap($id) $commcolors($comm)
578 } else {
579 if {$nparents($id) == 1 && $nchildren($id) == 1} {
580 set child [lindex $children($id) 0]
651 set child [lindex $children($id) 0]
581 if {[info exists colormap($child)]
652 if {[info exists colormap($child)]
582 && $nparents($child) == 1} {
653 && $nparents($child) == 1} {
583 set colormap($id) $colormap($child)
654 set colormap($id) $colormap($child)
584 return
655 return
585 }
656 }
586 }
657 }
587 set badcolors {}
658 set badcolors {}
659 if {[info exists cornercrossings($id)]} {
660 foreach x $cornercrossings($id) {
661 if {[info exists colormap($x)]
662 && [lsearch -exact $badcolors $colormap($x)] < 0} {
663 lappend badcolors $colormap($x)
664 }
665 }
666 if {[llength $badcolors] >= $ncolors} {
667 set badcolors {}
668 }
669 }
670 set origbad $badcolors
671 if {[llength $badcolors] < $ncolors - 1} {
672 if {[info exists crossings($id)]} {
673 foreach x $crossings($id) {
674 if {[info exists colormap($x)]
675 && [lsearch -exact $badcolors $colormap($x)] < 0} {
676 lappend badcolors $colormap($x)
677 }
678 }
679 if {[llength $badcolors] >= $ncolors} {
680 set badcolors $origbad
681 }
682 }
683 set origbad $badcolors
684 }
685 if {[llength $badcolors] < $ncolors - 1} {
588 foreach child $children($id) {
686 foreach child $children($id) {
589 if {[info exists colormap($child)]
687 if {[info exists colormap($child)]
590 && [lsearch -exact $badcolors $colormap($child)] < 0} {
688 && [lsearch -exact $badcolors $colormap($child)] < 0} {
591 lappend badcolors $colormap($child)
689 lappend badcolors $colormap($child)
592 }
690 }
593 if {[info exists parents($child)]} {
691 if {[info exists parents($child)]} {
594 foreach p $parents($child) {
692 foreach p $parents($child) {
595 if {[info exists colormap($p)]
693 if {[info exists colormap($p)]
596 && [lsearch -exact $badcolors $colormap($p)] < 0} {
694 && [lsearch -exact $badcolors $colormap($p)] < 0} {
597 lappend badcolors $colormap($p)
695 lappend badcolors $colormap($p)
598 }
696 }
599 }
697 }
600 }
698 }
601 }
699 }
602 if {[llength $badcolors] >= $ncolors} {
700 if {[llength $badcolors] >= $ncolors} {
603 set badcolors {}
701 set badcolors $origbad
702 }
604 }
703 }
605 for {set i 0} {$i <= $ncolors} {incr i} {
704 for {set i 0} {$i <= $ncolors} {incr i} {
606 set c [lindex $colors $nextcolor]
705 set c [lindex $colors $nextcolor]
607 if {[incr nextcolor] >= $ncolors} {
706 if {[incr nextcolor] >= $ncolors} {
608 set nextcolor 0
707 set nextcolor 0
609 }
708 }
610 if {[lsearch -exact $badcolors $c]} break
709 if {[lsearch -exact $badcolors $c]} break
611 }
710 }
612 set colormap($id) $c
711 set colormap($id) $c
613 }
712 }
614 }
615
713
616 proc drawgraph {} {
714 proc initgraph {} {
617 global parents children nparents nchildren commits
715 global canvy canvy0 lineno numcommits nextcolor linespc
618 global canv canv2 canv3 mainfont namefont canvx0 canvy0 canvy linespc
716 global mainline mainlinearrow sidelines
619 global datemode cdate
717 global nchildren ncleft
620 global lineid linehtag linentag linedtag commitinfo
718 global displist nhyperspace
621 global nextcolor colormap numcommits
622 global stopped phase redisplaying selectedline idtags idline
623
719
624 allcanvs delete all
720 allcanvs delete all
625 set start {}
721 set nextcolor 0
722 set canvy $canvy0
723 set lineno -1
724 set numcommits 0
725 catch {unset mainline}
726 catch {unset mainlinearrow}
727 catch {unset sidelines}
626 foreach id [array names nchildren] {
728 foreach id [array names nchildren] {
627 if {$nchildren($id) == 0} {
628 lappend start $id
629 }
630 set ncleft($id) $nchildren($id)
729 set ncleft($id) $nchildren($id)
631 if {![info exists nparents($id)]} {
730 }
632 set nparents($id) 0
731 set displist {}
633 }
732 set nhyperspace 0
634 }
733 }
635 if {$start == {}} {
734
636 error_popup "Gitk: ERROR: No starting commits found"
735 proc bindline {t id} {
637 exit 1
736 global canv
737
738 $canv bind $t <Enter> "lineenter %x %y $id"
739 $canv bind $t <Motion> "linemotion %x %y $id"
740 $canv bind $t <Leave> "lineleave $id"
741 $canv bind $t <Button-1> "lineclick %x %y $id 1"
638 }
742 }
639
743
640 set nextcolor 0
744 proc drawlines {id xtra} {
641 foreach id $start {
745 global mainline mainlinearrow sidelines lthickness colormap canv
642 assigncolor $id
746
643 }
747 $canv delete lines.$id
644 set todo $start
748 if {[info exists mainline($id)]} {
645 set level [expr [llength $todo] - 1]
749 set t [$canv create line $mainline($id) \
646 set y2 $canvy0
750 -width [expr {($xtra + 1) * $lthickness}] \
647 set nullentry -1
751 -fill $colormap($id) -tags lines.$id \
648 set lineno -1
752 -arrow $mainlinearrow($id)]
649 set numcommits 0
753 $canv lower $t
650 set phase drawgraph
754 bindline $t $id
651 set lthickness [expr {($linespc / 9) + 1}]
755 }
652 while 1 {
756 if {[info exists sidelines($id)]} {
653 set canvy $y2
757 foreach ls $sidelines($id) {
654 allcanvs conf -scrollregion \
758 set coords [lindex $ls 0]
655 [list 0 0 0 [expr $canvy + 0.5 * $linespc + 2]]
759 set thick [lindex $ls 1]
656 update
760 set arrow [lindex $ls 2]
657 if {$stopped} break
761 set t [$canv create line $coords -fill $colormap($id) \
762 -width [expr {($thick + $xtra) * $lthickness}] \
763 -arrow $arrow -tags lines.$id]
764 $canv lower $t
765 bindline $t $id
766 }
767 }
768 }
769
770 # level here is an index in displist
771 proc drawcommitline {level} {
772 global parents children nparents displist
773 global canv canv2 canv3 mainfont namefont canvy linespc
774 global lineid linehtag linentag linedtag commitinfo
775 global colormap numcommits currentparents dupparents
776 global idtags idline idheads idotherrefs
777 global lineno lthickness mainline mainlinearrow sidelines
778 global commitlisted rowtextx idpos lastuse displist
779 global oldnlines olddlevel olddisplist
780
658 incr numcommits
781 incr numcommits
659 incr lineno
782 incr lineno
660 set nlines [llength $todo]
783 set id [lindex $displist $level]
661 set id [lindex $todo $level]
784 set lastuse($id) $lineno
662 set lineid($lineno) $id
785 set lineid($lineno) $id
663 set idline($id) $lineno
786 set idline($id) $lineno
664 set actualparents {}
787 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
665 set ofill white
666 if {[info exists parents($id)]} {
667 foreach p $parents($id) {
668 if {[info exists ncleft($p)]} {
669 incr ncleft($p) -1
670 if {![info exists commitinfo($p)]} {
671 readcommit $p
672 if {![info exists commitinfo($p)]} continue
673 }
674 lappend actualparents $p
675 set ofill blue
676 }
677 }
678 }
679 if {![info exists commitinfo($id)]} {
788 if {![info exists commitinfo($id)]} {
680 readcommit $id
789 readcommit $id
681 if {![info exists commitinfo($id)]} {
790 if {![info exists commitinfo($id)]} {
682 set commitinfo($id) {"No commit information available"}
791 set commitinfo($id) {"No commit information available"}
683 }
792 set nparents($id) 0
684 }
793 }
685 set x [expr $canvx0 + $level * $linespc]
794 }
686 set y2 [expr $canvy + $linespc]
795 assigncolor $id
687 if {[info exists linestarty($level)] && $linestarty($level) < $canvy} {
796 set currentparents {}
688 set t [$canv create line $x $linestarty($level) $x $canvy \
797 set dupparents {}
689 -width $lthickness -fill $colormap($id)]
798 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
690 $canv lower $t
799 foreach p $parents($id) {
691 }
800 if {[lsearch -exact $currentparents $p] < 0} {
692 set linestarty($level) $canvy
801 lappend currentparents $p
802 } else {
803 # remember that this parent was listed twice
804 lappend dupparents $p
805 }
806 }
807 }
808 set x [xcoord $level $level $lineno]
809 set y1 $canvy
810 set canvy [expr $canvy + $linespc]
811 allcanvs conf -scrollregion \
812 [list 0 0 0 [expr $y1 + 0.5 * $linespc + 2]]
813 if {[info exists mainline($id)]} {
814 lappend mainline($id) $x $y1
815 if {$mainlinearrow($id) ne "none"} {
816 set mainline($id) [trimdiagstart $mainline($id)]
817 }
818 }
819 drawlines $id 0
693 set orad [expr {$linespc / 3}]
820 set orad [expr {$linespc / 3}]
694 set t [$canv create oval [expr $x - $orad] [expr $canvy - $orad] \
821 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
695 [expr $x + $orad - 1] [expr $canvy + $orad - 1] \
822 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
696 -fill $ofill -outline black -width 1]
823 -fill $ofill -outline black -width 1]
697 $canv raise $t
824 $canv raise $t
698 set xt [expr $canvx0 + $nlines * $linespc]
825 $canv bind $t <1> {selcanvline {} %x %y}
699 if {$nparents($id) > 2} {
826 set xt [xcoord [llength $displist] $level $lineno]
700 set xt [expr {$xt + ($nparents($id) - 2) * $linespc}]
827 if {[llength $currentparents] > 2} {
701 }
828 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
702 if {[info exists idtags($id)] && $idtags($id) != {}} {
829 }
703 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
830 set rowtextx($lineno) $xt
704 set yt [expr $canvy - 0.5 * $linespc]
831 set idpos($id) [list $x $xt $y1]
705 set yb [expr $yt + $linespc - 1]
832 if {[info exists idtags($id)] || [info exists idheads($id)]
706 set xvals {}
833 || [info exists idotherrefs($id)]} {
707 set wvals {}
834 set xt [drawtags $id $x $xt $y1]
708 foreach tag $idtags($id) {
709 set wid [font measure $mainfont $tag]
710 lappend xvals $xt
711 lappend wvals $wid
712 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
713 }
714 set t [$canv create line $x $canvy [lindex $xvals end] $canvy \
715 -width $lthickness -fill black]
716 $canv lower $t
717 foreach tag $idtags($id) x $xvals wid $wvals {
718 set xl [expr $x + $delta]
719 set xr [expr $x + $delta + $wid + $lthickness]
720 $canv create polygon $x [expr $yt + $delta] $xl $yt\
721 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
722 -width 1 -outline black -fill yellow
723 $canv create text $xl $canvy -anchor w -text $tag \
724 -font $mainfont
725 }
726 }
835 }
727 set headline [lindex $commitinfo($id) 0]
836 set headline [lindex $commitinfo($id) 0]
728 set name [lindex $commitinfo($id) 1]
837 set name [lindex $commitinfo($id) 1]
729 set date [lindex $commitinfo($id) 2]
838 set date [lindex $commitinfo($id) 2]
730 set linehtag($lineno) [$canv create text $xt $canvy -anchor w \
839 set linehtag($lineno) [$canv create text $xt $y1 -anchor w \
731 -text $headline -font $mainfont ]
840 -text $headline -font $mainfont ]
732 set linentag($lineno) [$canv2 create text 3 $canvy -anchor w \
841 $canv bind $linehtag($lineno) <Button-3> "rowmenu %X %Y $id"
842 set linentag($lineno) [$canv2 create text 3 $y1 -anchor w \
733 -text $name -font $namefont]
843 -text $name -font $namefont]
734 set linedtag($lineno) [$canv3 create text 3 $canvy -anchor w \
844 set linedtag($lineno) [$canv3 create text 3 $y1 -anchor w \
735 -text $date -font $mainfont]
845 -text $date -font $mainfont]
736 if {!$datemode && [llength $actualparents] == 1} {
846
737 set p [lindex $actualparents 0]
847 set olddlevel $level
738 if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} {
848 set olddisplist $displist
739 assigncolor $p
849 set oldnlines [llength $displist]
740 set todo [lreplace $todo $level $level $p]
850 }
741 continue
851
852 proc drawtags {id x xt y1} {
853 global idtags idheads idotherrefs
854 global linespc lthickness
855 global canv mainfont idline rowtextx
856
857 set marks {}
858 set ntags 0
859 set nheads 0
860 if {[info exists idtags($id)]} {
861 set marks $idtags($id)
862 set ntags [llength $marks]
863 }
864 if {[info exists idheads($id)]} {
865 set marks [concat $marks $idheads($id)]
866 set nheads [llength $idheads($id)]
867 }
868 if {[info exists idotherrefs($id)]} {
869 set marks [concat $marks $idotherrefs($id)]
870 }
871 if {$marks eq {}} {
872 return $xt
873 }
874
875 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
876 set yt [expr $y1 - 0.5 * $linespc]
877 set yb [expr $yt + $linespc - 1]
878 set xvals {}
879 set wvals {}
880 foreach tag $marks {
881 set wid [font measure $mainfont $tag]
882 lappend xvals $xt
883 lappend wvals $wid
884 set xt [expr {$xt + $delta + $wid + $lthickness + $linespc}]
885 }
886 set t [$canv create line $x $y1 [lindex $xvals end] $y1 \
887 -width $lthickness -fill black -tags tag.$id]
888 $canv lower $t
889 foreach tag $marks x $xvals wid $wvals {
890 set xl [expr $x + $delta]
891 set xr [expr $x + $delta + $wid + $lthickness]
892 if {[incr ntags -1] >= 0} {
893 # draw a tag
894 set t [$canv create polygon $x [expr $yt + $delta] $xl $yt \
895 $xr $yt $xr $yb $xl $yb $x [expr $yb - $delta] \
896 -width 1 -outline black -fill yellow -tags tag.$id]
897 $canv bind $t <1> [list showtag $tag 1]
898 set rowtextx($idline($id)) [expr {$xr + $linespc}]
899 } else {
900 # draw a head or other ref
901 if {[incr nheads -1] >= 0} {
902 set col green
903 } else {
904 set col "#ddddff"
905 }
906 set xl [expr $xl - $delta/2]
907 $canv create polygon $x $yt $xr $yt $xr $yb $x $yb \
908 -width 1 -outline black -fill $col -tags tag.$id
909 }
910 set t [$canv create text $xl $y1 -anchor w -text $tag \
911 -font $mainfont -tags tag.$id]
912 if {$ntags >= 0} {
913 $canv bind $t <1> [list showtag $tag 1]
914 }
915 }
916 return $xt
917 }
918
919 proc notecrossings {id lo hi corner} {
920 global olddisplist crossings cornercrossings
921
922 for {set i $lo} {[incr i] < $hi} {} {
923 set p [lindex $olddisplist $i]
924 if {$p == {}} continue
925 if {$i == $corner} {
926 if {![info exists cornercrossings($id)]
927 || [lsearch -exact $cornercrossings($id) $p] < 0} {
928 lappend cornercrossings($id) $p
929 }
930 if {![info exists cornercrossings($p)]
931 || [lsearch -exact $cornercrossings($p) $id] < 0} {
932 lappend cornercrossings($p) $id
933 }
934 } else {
935 if {![info exists crossings($id)]
936 || [lsearch -exact $crossings($id) $p] < 0} {
937 lappend crossings($id) $p
938 }
939 if {![info exists crossings($p)]
940 || [lsearch -exact $crossings($p) $id] < 0} {
941 lappend crossings($p) $id
942 }
943 }
944 }
945 }
946
947 proc xcoord {i level ln} {
948 global canvx0 xspc1 xspc2
949
950 set x [expr {$canvx0 + $i * $xspc1($ln)}]
951 if {$i > 0 && $i == $level} {
952 set x [expr {$x + 0.5 * ($xspc2 - $xspc1($ln))}]
953 } elseif {$i > $level} {
954 set x [expr {$x + $xspc2 - $xspc1($ln)}]
955 }
956 return $x
957 }
958
959 # it seems Tk can't draw arrows on the end of diagonal line segments...
960 proc trimdiagend {line} {
961 while {[llength $line] > 4} {
962 set x1 [lindex $line end-3]
963 set y1 [lindex $line end-2]
964 set x2 [lindex $line end-1]
965 set y2 [lindex $line end]
966 if {($x1 == $x2) != ($y1 == $y2)} break
967 set line [lreplace $line end-1 end]
968 }
969 return $line
970 }
971
972 proc trimdiagstart {line} {
973 while {[llength $line] > 4} {
974 set x1 [lindex $line 0]
975 set y1 [lindex $line 1]
976 set x2 [lindex $line 2]
977 set y2 [lindex $line 3]
978 if {($x1 == $x2) != ($y1 == $y2)} break
979 set line [lreplace $line 0 1]
980 }
981 return $line
982 }
983
984 proc drawslants {id needonscreen nohs} {
985 global canv mainline mainlinearrow sidelines
986 global canvx0 canvy xspc1 xspc2 lthickness
987 global currentparents dupparents
988 global lthickness linespc canvy colormap lineno geometry
989 global maxgraphpct maxwidth
990 global displist onscreen lastuse
991 global parents commitlisted
992 global oldnlines olddlevel olddisplist
993 global nhyperspace numcommits nnewparents
994
995 if {$lineno < 0} {
996 lappend displist $id
997 set onscreen($id) 1
998 return 0
999 }
1000
1001 set y1 [expr {$canvy - $linespc}]
1002 set y2 $canvy
1003
1004 # work out what we need to get back on screen
1005 set reins {}
1006 if {$onscreen($id) < 0} {
1007 # next to do isn't displayed, better get it on screen...
1008 lappend reins [list $id 0]
1009 }
1010 # make sure all the previous commits's parents are on the screen
1011 foreach p $currentparents {
1012 if {$onscreen($p) < 0} {
1013 lappend reins [list $p 0]
1014 }
1015 }
1016 # bring back anything requested by caller
1017 if {$needonscreen ne {}} {
1018 lappend reins $needonscreen
1019 }
1020
1021 # try the shortcut
1022 if {$currentparents == $id && $onscreen($id) == 0 && $reins eq {}} {
1023 set dlevel $olddlevel
1024 set x [xcoord $dlevel $dlevel $lineno]
1025 set mainline($id) [list $x $y1]
1026 set mainlinearrow($id) none
1027 set lastuse($id) $lineno
1028 set displist [lreplace $displist $dlevel $dlevel $id]
1029 set onscreen($id) 1
1030 set xspc1([expr {$lineno + 1}]) $xspc1($lineno)
1031 return $dlevel
1032 }
1033
1034 # update displist
1035 set displist [lreplace $displist $olddlevel $olddlevel]
1036 set j $olddlevel
1037 foreach p $currentparents {
1038 set lastuse($p) $lineno
1039 if {$onscreen($p) == 0} {
1040 set displist [linsert $displist $j $p]
1041 set onscreen($p) 1
1042 incr j
1043 }
1044 }
1045 if {$onscreen($id) == 0} {
1046 lappend displist $id
1047 set onscreen($id) 1
1048 }
1049
1050 # remove the null entry if present
1051 set nullentry [lsearch -exact $displist {}]
1052 if {$nullentry >= 0} {
1053 set displist [lreplace $displist $nullentry $nullentry]
1054 }
1055
1056 # bring back the ones we need now (if we did it earlier
1057 # it would change displist and invalidate olddlevel)
1058 foreach pi $reins {
1059 # test again in case of duplicates in reins
1060 set p [lindex $pi 0]
1061 if {$onscreen($p) < 0} {
1062 set onscreen($p) 1
1063 set lastuse($p) $lineno
1064 set displist [linsert $displist [lindex $pi 1] $p]
1065 incr nhyperspace -1
742 }
1066 }
743 }
1067 }
744
1068
745 set oldtodo $todo
1069 set lastuse($id) $lineno
746 set oldlevel $level
1070
747 set lines {}
1071 # see if we need to make any lines jump off into hyperspace
748 for {set i 0} {$i < $nlines} {incr i} {
1072 set displ [llength $displist]
749 if {[lindex $todo $i] == {}} continue
1073 if {$displ > $maxwidth} {
750 if {[info exists linestarty($i)]} {
1074 set ages {}
751 set oldstarty($i) $linestarty($i)
1075 foreach x $displist {
752 unset linestarty($i)
1076 lappend ages [list $lastuse($x) $x]
753 }
1077 }
754 if {$i != $level} {
1078 set ages [lsort -integer -index 0 $ages]
755 lappend lines [list $i [lindex $todo $i]]
1079 set k 0
756 }
1080 while {$displ > $maxwidth} {
757 }
1081 set use [lindex $ages $k 0]
758 if {$nullentry >= 0} {
1082 set victim [lindex $ages $k 1]
759 set todo [lreplace $todo $nullentry $nullentry]
1083 if {$use >= $lineno - 5} break
760 if {$nullentry < $level} {
1084 incr k
761 incr level -1
1085 if {[lsearch -exact $nohs $victim] >= 0} continue
1086 set i [lsearch -exact $displist $victim]
1087 set displist [lreplace $displist $i $i]
1088 set onscreen($victim) -1
1089 incr nhyperspace
1090 incr displ -1
1091 if {$i < $nullentry} {
1092 incr nullentry -1
1093 }
1094 set x [lindex $mainline($victim) end-1]
1095 lappend mainline($victim) $x $y1
1096 set line [trimdiagend $mainline($victim)]
1097 set arrow "last"
1098 if {$mainlinearrow($victim) ne "none"} {
1099 set line [trimdiagstart $line]
1100 set arrow "both"
1101 }
1102 lappend sidelines($victim) [list $line 1 $arrow]
1103 unset mainline($victim)
1104 }
1105 }
1106
1107 set dlevel [lsearch -exact $displist $id]
1108
1109 # If we are reducing, put in a null entry
1110 if {$displ < $oldnlines} {
1111 # does the next line look like a merge?
1112 # i.e. does it have > 1 new parent?
1113 if {$nnewparents($id) > 1} {
1114 set i [expr {$dlevel + 1}]
1115 } elseif {$nnewparents([lindex $olddisplist $olddlevel]) == 0} {
1116 set i $olddlevel
1117 if {$nullentry >= 0 && $nullentry < $i} {
1118 incr i -1
1119 }
1120 } elseif {$nullentry >= 0} {
1121 set i $nullentry
1122 while {$i < $displ
1123 && [lindex $olddisplist $i] == [lindex $displist $i]} {
1124 incr i
1125 }
1126 } else {
1127 set i $olddlevel
1128 if {$dlevel >= $i} {
1129 incr i
1130 }
1131 }
1132 if {$i < $displ} {
1133 set displist [linsert $displist $i {}]
1134 incr displ
1135 if {$dlevel >= $i} {
1136 incr dlevel
1137 }
1138 }
1139 }
1140
1141 # decide on the line spacing for the next line
1142 set lj [expr {$lineno + 1}]
1143 set maxw [expr {$maxgraphpct * $geometry(canv1) / 100}]
1144 if {$displ <= 1 || $canvx0 + $displ * $xspc2 <= $maxw} {
1145 set xspc1($lj) $xspc2
1146 } else {
1147 set xspc1($lj) [expr {($maxw - $canvx0 - $xspc2) / ($displ - 1)}]
1148 if {$xspc1($lj) < $lthickness} {
1149 set xspc1($lj) $lthickness
1150 }
1151 }
1152
1153 foreach idi $reins {
1154 set id [lindex $idi 0]
1155 set j [lsearch -exact $displist $id]
1156 set xj [xcoord $j $dlevel $lj]
1157 set mainline($id) [list $xj $y2]
1158 set mainlinearrow($id) first
1159 }
1160
1161 set i -1
1162 foreach id $olddisplist {
1163 incr i
1164 if {$id == {}} continue
1165 if {$onscreen($id) <= 0} continue
1166 set xi [xcoord $i $olddlevel $lineno]
1167 if {$i == $olddlevel} {
1168 foreach p $currentparents {
1169 set j [lsearch -exact $displist $p]
1170 set coords [list $xi $y1]
1171 set xj [xcoord $j $dlevel $lj]
1172 if {$xj < $xi - $linespc} {
1173 lappend coords [expr {$xj + $linespc}] $y1
1174 notecrossings $p $j $i [expr {$j + 1}]
1175 } elseif {$xj > $xi + $linespc} {
1176 lappend coords [expr {$xj - $linespc}] $y1
1177 notecrossings $p $i $j [expr {$j - 1}]
1178 }
1179 if {[lsearch -exact $dupparents $p] >= 0} {
1180 # draw a double-width line to indicate the doubled parent
1181 lappend coords $xj $y2
1182 lappend sidelines($p) [list $coords 2 none]
1183 if {![info exists mainline($p)]} {
1184 set mainline($p) [list $xj $y2]
1185 set mainlinearrow($p) none
1186 }
1187 } else {
1188 # normal case, no parent duplicated
1189 set yb $y2
1190 set dx [expr {abs($xi - $xj)}]
1191 if {0 && $dx < $linespc} {
1192 set yb [expr {$y1 + $dx}]
1193 }
1194 if {![info exists mainline($p)]} {
1195 if {$xi != $xj} {
1196 lappend coords $xj $yb
1197 }
1198 set mainline($p) $coords
1199 set mainlinearrow($p) none
1200 } else {
1201 lappend coords $xj $yb
1202 if {$yb < $y2} {
1203 lappend coords $xj $y2
1204 }
1205 lappend sidelines($p) [list $coords 1 none]
1206 }
1207 }
1208 }
1209 } else {
1210 set j $i
1211 if {[lindex $displist $i] != $id} {
1212 set j [lsearch -exact $displist $id]
1213 }
1214 if {$j != $i || $xspc1($lineno) != $xspc1($lj)
1215 || ($olddlevel < $i && $i < $dlevel)
1216 || ($dlevel < $i && $i < $olddlevel)} {
1217 set xj [xcoord $j $dlevel $lj]
1218 lappend mainline($id) $xi $y1 $xj $y2
1219 }
1220 }
1221 }
1222 return $dlevel
1223 }
1224
1225 # search for x in a list of lists
1226 proc llsearch {llist x} {
1227 set i 0
1228 foreach l $llist {
1229 if {$l == $x || [lsearch -exact $l $x] >= 0} {
1230 return $i
1231 }
1232 incr i
1233 }
1234 return -1
1235 }
1236
1237 proc drawmore {reading} {
1238 global displayorder numcommits ncmupdate nextupdate
1239 global stopped nhyperspace parents commitlisted
1240 global maxwidth onscreen displist currentparents olddlevel
1241
1242 set n [llength $displayorder]
1243 while {$numcommits < $n} {
1244 set id [lindex $displayorder $numcommits]
1245 set ctxend [expr {$numcommits + 10}]
1246 if {!$reading && $ctxend > $n} {
1247 set ctxend $n
1248 }
1249 set dlist {}
1250 if {$numcommits > 0} {
1251 set dlist [lreplace $displist $olddlevel $olddlevel]
1252 set i $olddlevel
1253 foreach p $currentparents {
1254 if {$onscreen($p) == 0} {
1255 set dlist [linsert $dlist $i $p]
1256 incr i
1257 }
1258 }
1259 }
1260 set nohs {}
1261 set reins {}
1262 set isfat [expr {[llength $dlist] > $maxwidth}]
1263 if {$nhyperspace > 0 || $isfat} {
1264 if {$ctxend > $n} break
1265 # work out what to bring back and
1266 # what we want to don't want to send into hyperspace
1267 set room 1
1268 for {set k $numcommits} {$k < $ctxend} {incr k} {
1269 set x [lindex $displayorder $k]
1270 set i [llsearch $dlist $x]
1271 if {$i < 0} {
1272 set i [llength $dlist]
1273 lappend dlist $x
1274 }
1275 if {[lsearch -exact $nohs $x] < 0} {
1276 lappend nohs $x
1277 }
1278 if {$reins eq {} && $onscreen($x) < 0 && $room} {
1279 set reins [list $x $i]
1280 }
1281 set newp {}
1282 if {[info exists commitlisted($x)]} {
1283 set right 0
1284 foreach p $parents($x) {
1285 if {[llsearch $dlist $p] < 0} {
1286 lappend newp $p
1287 if {[lsearch -exact $nohs $p] < 0} {
1288 lappend nohs $p
1289 }
1290 if {$reins eq {} && $onscreen($p) < 0 && $room} {
1291 set reins [list $p [expr {$i + $right}]]
1292 }
1293 }
1294 set right 1
1295 }
1296 }
1297 set l [lindex $dlist $i]
1298 if {[llength $l] == 1} {
1299 set l $newp
1300 } else {
1301 set j [lsearch -exact $l $x]
1302 set l [concat [lreplace $l $j $j] $newp]
1303 }
1304 set dlist [lreplace $dlist $i $i $l]
1305 if {$room && $isfat && [llength $newp] <= 1} {
1306 set room 0
1307 }
1308 }
1309 }
1310
1311 set dlevel [drawslants $id $reins $nohs]
1312 drawcommitline $dlevel
1313 if {[clock clicks -milliseconds] >= $nextupdate
1314 && $numcommits >= $ncmupdate} {
1315 doupdate $reading
1316 if {$stopped} break
1317 }
1318 }
1319 }
1320
1321 # level here is an index in todo
1322 proc updatetodo {level noshortcut} {
1323 global ncleft todo nnewparents
1324 global commitlisted parents onscreen
1325
1326 set id [lindex $todo $level]
1327 set olds {}
1328 if {[info exists commitlisted($id)]} {
1329 foreach p $parents($id) {
1330 if {[lsearch -exact $olds $p] < 0} {
1331 lappend olds $p
1332 }
1333 }
1334 }
1335 if {!$noshortcut && [llength $olds] == 1} {
1336 set p [lindex $olds 0]
1337 if {$ncleft($p) == 1 && [lsearch -exact $todo $p] < 0} {
1338 set ncleft($p) 0
1339 set todo [lreplace $todo $level $level $p]
1340 set onscreen($p) 0
1341 set nnewparents($id) 1
1342 return 0
762 }
1343 }
763 }
1344 }
764
1345
765 set todo [lreplace $todo $level $level]
1346 set todo [lreplace $todo $level $level]
766 if {$nullentry > $level} {
767 incr nullentry -1
768 }
769 set i $level
1347 set i $level
770 foreach p $actualparents {
1348 set n 0
1349 foreach p $olds {
1350 incr ncleft($p) -1
771 set k [lsearch -exact $todo $p]
1351 set k [lsearch -exact $todo $p]
772 if {$k < 0} {
1352 if {$k < 0} {
773 assigncolor $p
774 set todo [linsert $todo $i $p]
1353 set todo [linsert $todo $i $p]
775 if {$nullentry >= $i} {
1354 set onscreen($p) 0
776 incr nullentry
777 }
778 incr i
1355 incr i
779 }
1356 incr n
780 lappend lines [list $oldlevel $p]
1357 }
781 }
1358 }
1359 set nnewparents($id) $n
1360
1361 return 1
1362 }
1363
1364 proc decidenext {{noread 0}} {
1365 global ncleft todo
1366 global datemode cdate
1367 global commitinfo
782
1368
783 # choose which one to do next time around
1369 # choose which one to do next time around
784 set todol [llength $todo]
1370 set todol [llength $todo]
785 set level -1
1371 set level -1
786 set latest {}
1372 set latest {}
787 for {set k $todol} {[incr k -1] >= 0} {} {
1373 for {set k $todol} {[incr k -1] >= 0} {} {
788 set p [lindex $todo $k]
1374 set p [lindex $todo $k]
789 if {$p == {}} continue
790 if {$ncleft($p) == 0} {
1375 if {$ncleft($p) == 0} {
791 if {$datemode} {
1376 if {$datemode} {
1377 if {![info exists commitinfo($p)]} {
1378 if {$noread} {
1379 return {}
1380 }
1381 readcommit $p
1382 }
792 if {$latest == {} || $cdate($p) > $latest} {
1383 if {$latest == {} || $cdate($p) > $latest} {
793 set level $k
1384 set level $k
794 set latest $cdate($p)
1385 set latest $cdate($p)
795 }
1386 }
796 } else {
1387 } else {
797 set level $k
1388 set level $k
798 break
1389 break
799 }
1390 }
800 }
1391 }
801 }
1392 }
802 if {$level < 0} {
1393 if {$level < 0} {
803 if {$todo != {}} {
1394 if {$todo != {}} {
804 puts "ERROR: none of the pending commits can be done yet:"
1395 puts "ERROR: none of the pending commits can be done yet:"
805 foreach p $todo {
1396 foreach p $todo {
806 puts " $p"
1397 puts " $p ($ncleft($p))"
807 }
1398 }
808 }
1399 }
809 break
1400 return -1
1401 }
1402
1403 return $level
810 }
1404 }
811
1405
812 # If we are reducing, put in a null entry
1406 proc drawcommit {id} {
813 if {$todol < $nlines} {
1407 global phase todo nchildren datemode nextupdate
814 if {$nullentry >= 0} {
1408 global numcommits ncmupdate displayorder todo onscreen
815 set i $nullentry
1409
816 while {$i < $todol
1410 if {$phase != "incrdraw"} {
817 && [lindex $oldtodo $i] == [lindex $todo $i]} {
1411 set phase incrdraw
818 incr i
1412 set displayorder {}
819 }
1413 set todo {}
820 } else {
1414 initgraph
821 set i $oldlevel
1415 }
822 if {$level >= $i} {
1416 if {$nchildren($id) == 0} {
823 incr i
1417 lappend todo $id
824 }
1418 set onscreen($id) 0
825 }
1419 }
826 if {$i >= $todol} {
1420 set level [decidenext 1]
827 set nullentry -1
1421 if {$level == {} || $id != [lindex $todo $level]} {
828 } else {
1422 return
829 set nullentry $i
1423 }
830 set todo [linsert $todo $nullentry {}]
1424 while 1 {
831 if {$level >= $i} {
1425 lappend displayorder [lindex $todo $level]
832 incr level
1426 if {[updatetodo $level $datemode]} {
833 }
1427 set level [decidenext 1]
834 }
1428 if {$level == {}} break
835 } else {
1429 }
836 set nullentry -1
1430 set id [lindex $todo $level]
1431 if {![info exists commitlisted($id)]} {
1432 break
1433 }
1434 }
1435 drawmore 1
837 }
1436 }
838
1437
839 foreach l $lines {
1438 proc finishcommits {} {
840 set i [lindex $l 0]
1439 global phase
841 set dst [lindex $l 1]
1440 global canv mainfont ctext maincursor textcursor
842 set j [lsearch -exact $todo $dst]
1441
843 if {$i == $j} {
1442 if {$phase != "incrdraw"} {
844 if {[info exists oldstarty($i)]} {
1443 $canv delete all
845 set linestarty($i) $oldstarty($i)
1444 $canv create text 3 3 -anchor nw -text "No commits selected" \
846 }
1445 -font $mainfont -tags textitems
847 continue
1446 set phase {}
848 }
1447 } else {
849 set xi [expr {$canvx0 + $i * $linespc}]
1448 drawrest
850 set xj [expr {$canvx0 + $j * $linespc}]
1449 }
851 set coords {}
1450 . config -cursor $maincursor
852 if {[info exists oldstarty($i)] && $oldstarty($i) < $canvy} {
1451 settextcursor $textcursor
853 lappend coords $xi $oldstarty($i)
1452 }
854 }
1453
855 lappend coords $xi $canvy
1454 # Don't change the text pane cursor if it is currently the hand cursor,
856 if {$j < $i - 1} {
1455 # showing that we are over a sha1 ID link.
857 lappend coords [expr $xj + $linespc] $canvy
1456 proc settextcursor {c} {
858 } elseif {$j > $i + 1} {
1457 global ctext curtextcursor
859 lappend coords [expr $xj - $linespc] $canvy
1458
860 }
1459 if {[$ctext cget -cursor] == $curtextcursor} {
861 lappend coords $xj $y2
1460 $ctext config -cursor $c
862 set t [$canv create line $coords -width $lthickness \
1461 }
863 -fill $colormap($dst)]
1462 set curtextcursor $c
864 $canv lower $t
1463 }
865 if {![info exists linestarty($j)]} {
1464
866 set linestarty($j) $y2
1465 proc drawgraph {} {
867 }
1466 global nextupdate startmsecs ncmupdate
868 }
1467 global displayorder onscreen
1468
1469 if {$displayorder == {}} return
1470 set startmsecs [clock clicks -milliseconds]
1471 set nextupdate [expr $startmsecs + 100]
1472 set ncmupdate 1
1473 initgraph
1474 foreach id $displayorder {
1475 set onscreen($id) 0
1476 }
1477 drawmore 0
1478 }
1479
1480 proc drawrest {} {
1481 global phase stopped redisplaying selectedline
1482 global datemode todo displayorder
1483 global numcommits ncmupdate
1484 global nextupdate startmsecs
1485
1486 set level [decidenext]
1487 if {$level >= 0} {
1488 set phase drawgraph
1489 while 1 {
1490 lappend displayorder [lindex $todo $level]
1491 set hard [updatetodo $level $datemode]
1492 if {$hard} {
1493 set level [decidenext]
1494 if {$level < 0} break
1495 }
1496 }
1497 drawmore 0
869 }
1498 }
870 set phase {}
1499 set phase {}
1500 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1501 #puts "overall $drawmsecs ms for $numcommits commits"
871 if {$redisplaying} {
1502 if {$redisplaying} {
872 if {$stopped == 0 && [info exists selectedline]} {
1503 if {$stopped == 0 && [info exists selectedline]} {
873 selectline $selectedline
1504 selectline $selectedline 0
874 }
1505 }
875 if {$stopped == 1} {
1506 if {$stopped == 1} {
876 set stopped 0
1507 set stopped 0
877 after idle drawgraph
1508 after idle drawgraph
878 } else {
1509 } else {
879 set redisplaying 0
1510 set redisplaying 0
880 }
1511 }
881 }
1512 }
882 }
1513 }
883
1514
884 proc findmatches {f} {
1515 proc findmatches {f} {
885 global findtype foundstring foundstrlen
1516 global findtype foundstring foundstrlen
886 if {$findtype == "Regexp"} {
1517 if {$findtype == "Regexp"} {
887 set matches [regexp -indices -all -inline $foundstring $f]
1518 set matches [regexp -indices -all -inline $foundstring $f]
888 } else {
1519 } else {
889 if {$findtype == "IgnCase"} {
1520 if {$findtype == "IgnCase"} {
890 set str [string tolower $f]
1521 set str [string tolower $f]
891 } else {
1522 } else {
892 set str $f
1523 set str $f
893 }
1524 }
894 set matches {}
1525 set matches {}
895 set i 0
1526 set i 0
896 while {[set j [string first $foundstring $str $i]] >= 0} {
1527 while {[set j [string first $foundstring $str $i]] >= 0} {
897 lappend matches [list $j [expr $j+$foundstrlen-1]]
1528 lappend matches [list $j [expr $j+$foundstrlen-1]]
898 set i [expr $j + $foundstrlen]
1529 set i [expr $j + $foundstrlen]
899 }
1530 }
900 }
1531 }
901 return $matches
1532 return $matches
902 }
1533 }
903
1534
904 proc dofind {} {
1535 proc dofind {} {
905 global findtype findloc findstring markedmatches commitinfo
1536 global findtype findloc findstring markedmatches commitinfo
906 global numcommits lineid linehtag linentag linedtag
1537 global numcommits lineid linehtag linentag linedtag
907 global mainfont namefont canv canv2 canv3 selectedline
1538 global mainfont namefont canv canv2 canv3 selectedline
908 global matchinglines foundstring foundstrlen idtags
1539 global matchinglines foundstring foundstrlen
1540
1541 stopfindproc
909 unmarkmatches
1542 unmarkmatches
910 focus .
1543 focus .
911 set matchinglines {}
1544 set matchinglines {}
912 set fldtypes {Headline Author Date Committer CDate Comment}
1545 if {$findloc == "Pickaxe"} {
1546 findpatches
1547 return
1548 }
913 if {$findtype == "IgnCase"} {
1549 if {$findtype == "IgnCase"} {
914 set foundstring [string tolower $findstring]
1550 set foundstring [string tolower $findstring]
915 } else {
1551 } else {
916 set foundstring $findstring
1552 set foundstring $findstring
917 }
1553 }
918 set foundstrlen [string length $findstring]
1554 set foundstrlen [string length $findstring]
919 if {$foundstrlen == 0} return
1555 if {$foundstrlen == 0} return
1556 if {$findloc == "Files"} {
1557 findfiles
1558 return
1559 }
920 if {![info exists selectedline]} {
1560 if {![info exists selectedline]} {
921 set oldsel -1
1561 set oldsel -1
922 } else {
1562 } else {
923 set oldsel $selectedline
1563 set oldsel $selectedline
924 }
1564 }
925 set didsel 0
1565 set didsel 0
1566 set fldtypes {Headline Author Date Committer CDate Comment}
926 for {set l 0} {$l < $numcommits} {incr l} {
1567 for {set l 0} {$l < $numcommits} {incr l} {
927 set id $lineid($l)
1568 set id $lineid($l)
928 set info $commitinfo($id)
1569 set info $commitinfo($id)
929 set doesmatch 0
1570 set doesmatch 0
930 foreach f $info ty $fldtypes {
1571 foreach f $info ty $fldtypes {
931 if {$findloc != "All fields" && $findloc != $ty} {
1572 if {$findloc != "All fields" && $findloc != $ty} {
932 continue
1573 continue
933 }
1574 }
934 set matches [findmatches $f]
1575 set matches [findmatches $f]
935 if {$matches == {}} continue
1576 if {$matches == {}} continue
936 set doesmatch 1
1577 set doesmatch 1
937 if {$ty == "Headline"} {
1578 if {$ty == "Headline"} {
938 markmatches $canv $l $f $linehtag($l) $matches $mainfont
1579 markmatches $canv $l $f $linehtag($l) $matches $mainfont
939 } elseif {$ty == "Author"} {
1580 } elseif {$ty == "Author"} {
940 markmatches $canv2 $l $f $linentag($l) $matches $namefont
1581 markmatches $canv2 $l $f $linentag($l) $matches $namefont
941 } elseif {$ty == "Date"} {
1582 } elseif {$ty == "Date"} {
942 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
1583 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
943 }
1584 }
944 }
1585 }
945 if {$doesmatch} {
1586 if {$doesmatch} {
946 lappend matchinglines $l
1587 lappend matchinglines $l
947 if {!$didsel && $l > $oldsel} {
1588 if {!$didsel && $l > $oldsel} {
948 findselectline $l
1589 findselectline $l
949 set didsel 1
1590 set didsel 1
950 }
1591 }
951 }
1592 }
952 }
1593 }
953 if {$matchinglines == {}} {
1594 if {$matchinglines == {}} {
954 bell
1595 bell
955 } elseif {!$didsel} {
1596 } elseif {!$didsel} {
956 findselectline [lindex $matchinglines 0]
1597 findselectline [lindex $matchinglines 0]
957 }
1598 }
958 }
1599 }
959
1600
960 proc findselectline {l} {
1601 proc findselectline {l} {
961 global findloc commentend ctext
1602 global findloc commentend ctext
962 selectline $l
1603 selectline $l 1
963 if {$findloc == "All fields" || $findloc == "Comments"} {
1604 if {$findloc == "All fields" || $findloc == "Comments"} {
964 # highlight the matches in the comments
1605 # highlight the matches in the comments
965 set f [$ctext get 1.0 $commentend]
1606 set f [$ctext get 1.0 $commentend]
966 set matches [findmatches $f]
1607 set matches [findmatches $f]
967 foreach match $matches {
1608 foreach match $matches {
968 set start [lindex $match 0]
1609 set start [lindex $match 0]
969 set end [expr [lindex $match 1] + 1]
1610 set end [expr [lindex $match 1] + 1]
970 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
1611 $ctext tag add found "1.0 + $start c" "1.0 + $end c"
971 }
1612 }
972 }
1613 }
973 }
1614 }
974
1615
975 proc findnext {} {
1616 proc findnext {restart} {
976 global matchinglines selectedline
1617 global matchinglines selectedline
977 if {![info exists matchinglines]} {
1618 if {![info exists matchinglines]} {
1619 if {$restart} {
978 dofind
1620 dofind
1621 }
979 return
1622 return
980 }
1623 }
981 if {![info exists selectedline]} return
1624 if {![info exists selectedline]} return
982 foreach l $matchinglines {
1625 foreach l $matchinglines {
983 if {$l > $selectedline} {
1626 if {$l > $selectedline} {
984 findselectline $l
1627 findselectline $l
985 return
1628 return
986 }
1629 }
987 }
1630 }
988 bell
1631 bell
989 }
1632 }
990
1633
991 proc findprev {} {
1634 proc findprev {} {
992 global matchinglines selectedline
1635 global matchinglines selectedline
993 if {![info exists matchinglines]} {
1636 if {![info exists matchinglines]} {
994 dofind
1637 dofind
995 return
1638 return
996 }
1639 }
997 if {![info exists selectedline]} return
1640 if {![info exists selectedline]} return
998 set prev {}
1641 set prev {}
999 foreach l $matchinglines {
1642 foreach l $matchinglines {
1000 if {$l >= $selectedline} break
1643 if {$l >= $selectedline} break
1001 set prev $l
1644 set prev $l
1002 }
1645 }
1003 if {$prev != {}} {
1646 if {$prev != {}} {
1004 findselectline $prev
1647 findselectline $prev
1005 } else {
1648 } else {
1006 bell
1649 bell
1007 }
1650 }
1008 }
1651 }
1009
1652
1653 proc findlocchange {name ix op} {
1654 global findloc findtype findtypemenu
1655 if {$findloc == "Pickaxe"} {
1656 set findtype Exact
1657 set state disabled
1658 } else {
1659 set state normal
1660 }
1661 $findtypemenu entryconf 1 -state $state
1662 $findtypemenu entryconf 2 -state $state
1663 }
1664
1665 proc stopfindproc {{done 0}} {
1666 global findprocpid findprocfile findids
1667 global ctext findoldcursor phase maincursor textcursor
1668 global findinprogress
1669
1670 catch {unset findids}
1671 if {[info exists findprocpid]} {
1672 if {!$done} {
1673 catch {exec kill $findprocpid}
1674 }
1675 catch {close $findprocfile}
1676 unset findprocpid
1677 }
1678 if {[info exists findinprogress]} {
1679 unset findinprogress
1680 if {$phase != "incrdraw"} {
1681 . config -cursor $maincursor
1682 settextcursor $textcursor
1683 }
1684 }
1685 }
1686
1687 proc findpatches {} {
1688 global findstring selectedline numcommits
1689 global findprocpid findprocfile
1690 global finddidsel ctext lineid findinprogress
1691 global findinsertpos
1692
1693 if {$numcommits == 0} return
1694
1695 # make a list of all the ids to search, starting at the one
1696 # after the selected line (if any)
1697 if {[info exists selectedline]} {
1698 set l $selectedline
1699 } else {
1700 set l -1
1701 }
1702 set inputids {}
1703 for {set i 0} {$i < $numcommits} {incr i} {
1704 if {[incr l] >= $numcommits} {
1705 set l 0
1706 }
1707 append inputids $lineid($l) "\n"
1708 }
1709
1710 if {[catch {
1711 set f [open [list | hg git-diff-tree --stdin -s -r -S$findstring \
1712 << $inputids] r]
1713 } err]} {
1714 error_popup "Error starting search process: $err"
1715 return
1716 }
1717
1718 set findinsertpos end
1719 set findprocfile $f
1720 set findprocpid [pid $f]
1721 fconfigure $f -blocking 0
1722 fileevent $f readable readfindproc
1723 set finddidsel 0
1724 . config -cursor watch
1725 settextcursor watch
1726 set findinprogress 1
1727 }
1728
1729 proc readfindproc {} {
1730 global findprocfile finddidsel
1731 global idline matchinglines findinsertpos
1732
1733 set n [gets $findprocfile line]
1734 if {$n < 0} {
1735 if {[eof $findprocfile]} {
1736 stopfindproc 1
1737 if {!$finddidsel} {
1738 bell
1739 }
1740 }
1741 return
1742 }
1743 if {![regexp {^[0-9a-f]{40}} $line id]} {
1744 error_popup "Can't parse git-diff-tree output: $line"
1745 stopfindproc
1746 return
1747 }
1748 if {![info exists idline($id)]} {
1749 puts stderr "spurious id: $id"
1750 return
1751 }
1752 set l $idline($id)
1753 insertmatch $l $id
1754 }
1755
1756 proc insertmatch {l id} {
1757 global matchinglines findinsertpos finddidsel
1758
1759 if {$findinsertpos == "end"} {
1760 if {$matchinglines != {} && $l < [lindex $matchinglines 0]} {
1761 set matchinglines [linsert $matchinglines 0 $l]
1762 set findinsertpos 1
1763 } else {
1764 lappend matchinglines $l
1765 }
1766 } else {
1767 set matchinglines [linsert $matchinglines $findinsertpos $l]
1768 incr findinsertpos
1769 }
1770 markheadline $l $id
1771 if {!$finddidsel} {
1772 findselectline $l
1773 set finddidsel 1
1774 }
1775 }
1776
1777 proc findfiles {} {
1778 global selectedline numcommits lineid ctext
1779 global ffileline finddidsel parents nparents
1780 global findinprogress findstartline findinsertpos
1781 global treediffs fdiffids fdiffsneeded fdiffpos
1782 global findmergefiles
1783
1784 if {$numcommits == 0} return
1785
1786 if {[info exists selectedline]} {
1787 set l [expr {$selectedline + 1}]
1788 } else {
1789 set l 0
1790 }
1791 set ffileline $l
1792 set findstartline $l
1793 set diffsneeded {}
1794 set fdiffsneeded {}
1795 while 1 {
1796 set id $lineid($l)
1797 if {$findmergefiles || $nparents($id) == 1} {
1798 foreach p $parents($id) {
1799 if {![info exists treediffs([list $id $p])]} {
1800 append diffsneeded "$id $p\n"
1801 lappend fdiffsneeded [list $id $p]
1802 }
1803 }
1804 }
1805 if {[incr l] >= $numcommits} {
1806 set l 0
1807 }
1808 if {$l == $findstartline} break
1809 }
1810
1811 # start off a git-diff-tree process if needed
1812 if {$diffsneeded ne {}} {
1813 if {[catch {
1814 set df [open [list | hg git-diff-tree -r --stdin << $diffsneeded] r]
1815 } err ]} {
1816 error_popup "Error starting search process: $err"
1817 return
1818 }
1819 catch {unset fdiffids}
1820 set fdiffpos 0
1821 fconfigure $df -blocking 0
1822 fileevent $df readable [list readfilediffs $df]
1823 }
1824
1825 set finddidsel 0
1826 set findinsertpos end
1827 set id $lineid($l)
1828 set p [lindex $parents($id) 0]
1829 . config -cursor watch
1830 settextcursor watch
1831 set findinprogress 1
1832 findcont [list $id $p]
1833 update
1834 }
1835
1836 proc readfilediffs {df} {
1837 global findids fdiffids fdiffs
1838
1839 set n [gets $df line]
1840 if {$n < 0} {
1841 if {[eof $df]} {
1842 donefilediff
1843 if {[catch {close $df} err]} {
1844 stopfindproc
1845 bell
1846 error_popup "Error in hg git-diff-tree: $err"
1847 } elseif {[info exists findids]} {
1848 set ids $findids
1849 stopfindproc
1850 bell
1851 error_popup "Couldn't find diffs for {$ids}"
1852 }
1853 }
1854 return
1855 }
1856 if {[regexp {^([0-9a-f]{40}) \(from ([0-9a-f]{40})\)} $line match id p]} {
1857 # start of a new string of diffs
1858 donefilediff
1859 set fdiffids [list $id $p]
1860 set fdiffs {}
1861 } elseif {[string match ":*" $line]} {
1862 lappend fdiffs [lindex $line 5]
1863 }
1864 }
1865
1866 proc donefilediff {} {
1867 global fdiffids fdiffs treediffs findids
1868 global fdiffsneeded fdiffpos
1869
1870 if {[info exists fdiffids]} {
1871 while {[lindex $fdiffsneeded $fdiffpos] ne $fdiffids
1872 && $fdiffpos < [llength $fdiffsneeded]} {
1873 # git-diff-tree doesn't output anything for a commit
1874 # which doesn't change anything
1875 set nullids [lindex $fdiffsneeded $fdiffpos]
1876 set treediffs($nullids) {}
1877 if {[info exists findids] && $nullids eq $findids} {
1878 unset findids
1879 findcont $nullids
1880 }
1881 incr fdiffpos
1882 }
1883 incr fdiffpos
1884
1885 if {![info exists treediffs($fdiffids)]} {
1886 set treediffs($fdiffids) $fdiffs
1887 }
1888 if {[info exists findids] && $fdiffids eq $findids} {
1889 unset findids
1890 findcont $fdiffids
1891 }
1892 }
1893 }
1894
1895 proc findcont {ids} {
1896 global findids treediffs parents nparents
1897 global ffileline findstartline finddidsel
1898 global lineid numcommits matchinglines findinprogress
1899 global findmergefiles
1900
1901 set id [lindex $ids 0]
1902 set p [lindex $ids 1]
1903 set pi [lsearch -exact $parents($id) $p]
1904 set l $ffileline
1905 while 1 {
1906 if {$findmergefiles || $nparents($id) == 1} {
1907 if {![info exists treediffs($ids)]} {
1908 set findids $ids
1909 set ffileline $l
1910 return
1911 }
1912 set doesmatch 0
1913 foreach f $treediffs($ids) {
1914 set x [findmatches $f]
1915 if {$x != {}} {
1916 set doesmatch 1
1917 break
1918 }
1919 }
1920 if {$doesmatch} {
1921 insertmatch $l $id
1922 set pi $nparents($id)
1923 }
1924 } else {
1925 set pi $nparents($id)
1926 }
1927 if {[incr pi] >= $nparents($id)} {
1928 set pi 0
1929 if {[incr l] >= $numcommits} {
1930 set l 0
1931 }
1932 if {$l == $findstartline} break
1933 set id $lineid($l)
1934 }
1935 set p [lindex $parents($id) $pi]
1936 set ids [list $id $p]
1937 }
1938 stopfindproc
1939 if {!$finddidsel} {
1940 bell
1941 }
1942 }
1943
1944 # mark a commit as matching by putting a yellow background
1945 # behind the headline
1946 proc markheadline {l id} {
1947 global canv mainfont linehtag commitinfo
1948
1949 set bbox [$canv bbox $linehtag($l)]
1950 set t [$canv create rect $bbox -outline {} -tags matches -fill yellow]
1951 $canv lower $t
1952 }
1953
1954 # mark the bits of a headline, author or date that match a find string
1010 proc markmatches {canv l str tag matches font} {
1955 proc markmatches {canv l str tag matches font} {
1011 set bbox [$canv bbox $tag]
1956 set bbox [$canv bbox $tag]
1012 set x0 [lindex $bbox 0]
1957 set x0 [lindex $bbox 0]
1013 set y0 [lindex $bbox 1]
1958 set y0 [lindex $bbox 1]
1014 set y1 [lindex $bbox 3]
1959 set y1 [lindex $bbox 3]
1015 foreach match $matches {
1960 foreach match $matches {
1016 set start [lindex $match 0]
1961 set start [lindex $match 0]
1017 set end [lindex $match 1]
1962 set end [lindex $match 1]
1018 if {$start > $end} continue
1963 if {$start > $end} continue
1019 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1964 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1020 set xlen [font measure $font [string range $str 0 [expr $end]]]
1965 set xlen [font measure $font [string range $str 0 [expr $end]]]
1021 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1966 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1022 -outline {} -tags matches -fill yellow]
1967 -outline {} -tags matches -fill yellow]
1023 $canv lower $t
1968 $canv lower $t
1024 }
1969 }
1025 }
1970 }
1026
1971
1027 proc unmarkmatches {} {
1972 proc unmarkmatches {} {
1028 global matchinglines
1973 global matchinglines findids
1029 allcanvs delete matches
1974 allcanvs delete matches
1030 catch {unset matchinglines}
1975 catch {unset matchinglines}
1976 catch {unset findids}
1031 }
1977 }
1032
1978
1033 proc selcanvline {x y} {
1979 proc selcanvline {w x y} {
1034 global canv canvy0 ctext linespc selectedline
1980 global canv canvy0 ctext linespc
1035 global lineid linehtag linentag linedtag
1981 global lineid linehtag linentag linedtag rowtextx
1036 set ymax [lindex [$canv cget -scrollregion] 3]
1982 set ymax [lindex [$canv cget -scrollregion] 3]
1037 if {$ymax == {}} return
1983 if {$ymax == {}} return
1038 set yfrac [lindex [$canv yview] 0]
1984 set yfrac [lindex [$canv yview] 0]
1039 set y [expr {$y + $yfrac * $ymax}]
1985 set y [expr {$y + $yfrac * $ymax}]
1040 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1986 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1041 if {$l < 0} {
1987 if {$l < 0} {
1042 set l 0
1988 set l 0
1043 }
1989 }
1044 if {[info exists selectedline] && $selectedline == $l} return
1990 if {$w eq $canv} {
1991 if {![info exists rowtextx($l)] || $x < $rowtextx($l)} return
1992 }
1045 unmarkmatches
1993 unmarkmatches
1046 selectline $l
1994 selectline $l 1
1995 }
1996
1997 proc commit_descriptor {p} {
1998 global commitinfo
1999 set l "..."
2000 if {[info exists commitinfo($p)]} {
2001 set l [lindex $commitinfo($p) 0]
2002 }
2003 return "$p ($l)"
1047 }
2004 }
1048
2005
1049 proc selectline {l} {
2006 # append some text to the ctext widget, and make any SHA1 ID
2007 # that we know about be a clickable link.
2008 proc appendwithlinks {text} {
2009 global ctext idline linknum
2010
2011 set start [$ctext index "end - 1c"]
2012 $ctext insert end $text
2013 $ctext insert end "\n"
2014 set links [regexp -indices -all -inline {[0-9a-f]{40}} $text]
2015 foreach l $links {
2016 set s [lindex $l 0]
2017 set e [lindex $l 1]
2018 set linkid [string range $text $s $e]
2019 if {![info exists idline($linkid)]} continue
2020 incr e
2021 $ctext tag add link "$start + $s c" "$start + $e c"
2022 $ctext tag add link$linknum "$start + $s c" "$start + $e c"
2023 $ctext tag bind link$linknum <1> [list selectline $idline($linkid) 1]
2024 incr linknum
2025 }
2026 $ctext tag conf link -foreground blue -underline 1
2027 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
2028 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
2029 }
2030
2031 proc selectline {l isnew} {
1050 global canv canv2 canv3 ctext commitinfo selectedline
2032 global canv canv2 canv3 ctext commitinfo selectedline
1051 global lineid linehtag linentag linedtag
2033 global lineid linehtag linentag linedtag
1052 global canvy0 linespc nparents treepending
2034 global canvy0 linespc parents nparents children
1053 global cflist treediffs currentid sha1entry
2035 global cflist currentid sha1entry
1054 global commentend seenfile numcommits idtags
2036 global commentend idtags idline linknum
2037
2038 $canv delete hover
2039 normalline
1055 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
2040 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1056 $canv delete secsel
2041 $canv delete secsel
1057 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
2042 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1058 -tags secsel -fill [$canv cget -selectbackground]]
2043 -tags secsel -fill [$canv cget -selectbackground]]
1059 $canv lower $t
2044 $canv lower $t
1060 $canv2 delete secsel
2045 $canv2 delete secsel
1061 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
2046 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1062 -tags secsel -fill [$canv2 cget -selectbackground]]
2047 -tags secsel -fill [$canv2 cget -selectbackground]]
1063 $canv2 lower $t
2048 $canv2 lower $t
1064 $canv3 delete secsel
2049 $canv3 delete secsel
1065 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
2050 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1066 -tags secsel -fill [$canv3 cget -selectbackground]]
2051 -tags secsel -fill [$canv3 cget -selectbackground]]
1067 $canv3 lower $t
2052 $canv3 lower $t
1068 set y [expr {$canvy0 + $l * $linespc}]
2053 set y [expr {$canvy0 + $l * $linespc}]
1069 set ymax [lindex [$canv cget -scrollregion] 3]
2054 set ymax [lindex [$canv cget -scrollregion] 3]
1070 set ytop [expr {$y - $linespc - 1}]
2055 set ytop [expr {$y - $linespc - 1}]
1071 set ybot [expr {$y + $linespc + 1}]
2056 set ybot [expr {$y + $linespc + 1}]
1072 set wnow [$canv yview]
2057 set wnow [$canv yview]
1073 set wtop [expr [lindex $wnow 0] * $ymax]
2058 set wtop [expr [lindex $wnow 0] * $ymax]
1074 set wbot [expr [lindex $wnow 1] * $ymax]
2059 set wbot [expr [lindex $wnow 1] * $ymax]
1075 set wh [expr {$wbot - $wtop}]
2060 set wh [expr {$wbot - $wtop}]
1076 set newtop $wtop
2061 set newtop $wtop
1077 if {$ytop < $wtop} {
2062 if {$ytop < $wtop} {
1078 if {$ybot < $wtop} {
2063 if {$ybot < $wtop} {
1079 set newtop [expr {$y - $wh / 2.0}]
2064 set newtop [expr {$y - $wh / 2.0}]
1080 } else {
2065 } else {
1081 set newtop $ytop
2066 set newtop $ytop
1082 if {$newtop > $wtop - $linespc} {
2067 if {$newtop > $wtop - $linespc} {
1083 set newtop [expr {$wtop - $linespc}]
2068 set newtop [expr {$wtop - $linespc}]
1084 }
2069 }
1085 }
2070 }
1086 } elseif {$ybot > $wbot} {
2071 } elseif {$ybot > $wbot} {
1087 if {$ytop > $wbot} {
2072 if {$ytop > $wbot} {
1088 set newtop [expr {$y - $wh / 2.0}]
2073 set newtop [expr {$y - $wh / 2.0}]
1089 } else {
2074 } else {
1090 set newtop [expr {$ybot - $wh}]
2075 set newtop [expr {$ybot - $wh}]
1091 if {$newtop < $wtop + $linespc} {
2076 if {$newtop < $wtop + $linespc} {
1092 set newtop [expr {$wtop + $linespc}]
2077 set newtop [expr {$wtop + $linespc}]
1093 }
2078 }
1094 }
2079 }
1095 }
2080 }
1096 if {$newtop != $wtop} {
2081 if {$newtop != $wtop} {
1097 if {$newtop < 0} {
2082 if {$newtop < 0} {
1098 set newtop 0
2083 set newtop 0
1099 }
2084 }
1100 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
2085 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1101 }
2086 }
2087
2088 if {$isnew} {
2089 addtohistory [list selectline $l 0]
2090 }
2091
1102 set selectedline $l
2092 set selectedline $l
1103
2093
1104 set id $lineid($l)
2094 set id $lineid($l)
1105 set currentid $id
2095 set currentid $id
1106 $sha1entry delete 0 end
2096 $sha1entry delete 0 end
1107 $sha1entry insert 0 $id
2097 $sha1entry insert 0 $id
1108 $sha1entry selection from 0
2098 $sha1entry selection from 0
1109 $sha1entry selection to end
2099 $sha1entry selection to end
1110
2100
1111 $ctext conf -state normal
2101 $ctext conf -state normal
1112 $ctext delete 0.0 end
2102 $ctext delete 0.0 end
2103 set linknum 0
2104 $ctext mark set fmark.0 0.0
2105 $ctext mark gravity fmark.0 left
1113 set info $commitinfo($id)
2106 set info $commitinfo($id)
1114 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
2107 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1115 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
2108 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1116 if {[info exists idtags($id)]} {
2109 if {[info exists idtags($id)]} {
1117 $ctext insert end "Tags:"
2110 $ctext insert end "Tags:"
1118 foreach tag $idtags($id) {
2111 foreach tag $idtags($id) {
1119 $ctext insert end " $tag"
2112 $ctext insert end " $tag"
1120 }
2113 }
1121 $ctext insert end "\n"
2114 $ctext insert end "\n"
1122 }
2115 }
1123 $ctext insert end "\n"
2116
1124 $ctext insert end [lindex $info 5]
2117 set comment {}
1125 $ctext insert end "\n"
2118 if {[info exists parents($id)]} {
2119 foreach p $parents($id) {
2120 append comment "Parent: [commit_descriptor $p]\n"
2121 }
2122 }
2123 if {[info exists children($id)]} {
2124 foreach c $children($id) {
2125 append comment "Child: [commit_descriptor $c]\n"
2126 }
2127 }
2128 append comment "\n"
2129 append comment [lindex $info 5]
2130
2131 # make anything that looks like a SHA1 ID be a clickable link
2132 appendwithlinks $comment
2133
1126 $ctext tag delete Comments
2134 $ctext tag delete Comments
1127 $ctext tag remove found 1.0 end
2135 $ctext tag remove found 1.0 end
1128 $ctext conf -state disabled
2136 $ctext conf -state disabled
1129 set commentend [$ctext index "end - 1c"]
2137 set commentend [$ctext index "end - 1c"]
1130
2138
1131 $cflist delete 0 end
2139 $cflist delete 0 end
2140 $cflist insert end "Comments"
1132 if {$nparents($id) == 1} {
2141 if {$nparents($id) == 1} {
1133 if {![info exists treediffs($id)]} {
2142 startdiff [concat $id $parents($id)]
1134 if {![info exists treepending]} {
2143 } elseif {$nparents($id) > 1} {
1135 gettreediffs $id
2144 mergediff $id
1136 }
2145 }
1137 } else {
1138 addtocflist $id
1139 }
1140 }
1141 catch {unset seenfile}
1142 }
2146 }
1143
2147
1144 proc selnextline {dir} {
2148 proc selnextline {dir} {
1145 global selectedline
2149 global selectedline
1146 if {![info exists selectedline]} return
2150 if {![info exists selectedline]} return
1147 set l [expr $selectedline + $dir]
2151 set l [expr $selectedline + $dir]
1148 unmarkmatches
2152 unmarkmatches
1149 selectline $l
2153 selectline $l 1
2154 }
2155
2156 proc unselectline {} {
2157 global selectedline
2158
2159 catch {unset selectedline}
2160 allcanvs delete secsel
2161 }
2162
2163 proc addtohistory {cmd} {
2164 global history historyindex
2165
2166 if {$historyindex > 0
2167 && [lindex $history [expr {$historyindex - 1}]] == $cmd} {
2168 return
2169 }
2170
2171 if {$historyindex < [llength $history]} {
2172 set history [lreplace $history $historyindex end $cmd]
2173 } else {
2174 lappend history $cmd
2175 }
2176 incr historyindex
2177 if {$historyindex > 1} {
2178 .ctop.top.bar.leftbut conf -state normal
2179 } else {
2180 .ctop.top.bar.leftbut conf -state disabled
2181 }
2182 .ctop.top.bar.rightbut conf -state disabled
2183 }
2184
2185 proc goback {} {
2186 global history historyindex
2187
2188 if {$historyindex > 1} {
2189 incr historyindex -1
2190 set cmd [lindex $history [expr {$historyindex - 1}]]
2191 eval $cmd
2192 .ctop.top.bar.rightbut conf -state normal
2193 }
2194 if {$historyindex <= 1} {
2195 .ctop.top.bar.leftbut conf -state disabled
2196 }
2197 }
2198
2199 proc goforw {} {
2200 global history historyindex
2201
2202 if {$historyindex < [llength $history]} {
2203 set cmd [lindex $history $historyindex]
2204 incr historyindex
2205 eval $cmd
2206 .ctop.top.bar.leftbut conf -state normal
2207 }
2208 if {$historyindex >= [llength $history]} {
2209 .ctop.top.bar.rightbut conf -state disabled
2210 }
2211 }
2212
2213 proc mergediff {id} {
2214 global parents diffmergeid diffmergegca mergefilelist diffpindex
2215
2216 set diffmergeid $id
2217 set diffpindex -1
2218 set diffmergegca [findgca $parents($id)]
2219 if {[info exists mergefilelist($id)]} {
2220 if {$mergefilelist($id) ne {}} {
2221 showmergediff
2222 }
2223 } else {
2224 contmergediff {}
2225 }
2226 }
2227
2228 proc findgca {ids} {
2229 set gca {}
2230 foreach id $ids {
2231 if {$gca eq {}} {
2232 set gca $id
2233 } else {
2234 if {[catch {
2235 set gca [exec hg git-merge-base $gca $id]
2236 } err]} {
2237 return {}
2238 }
2239 }
2240 }
2241 return $gca
2242 }
2243
2244 proc contmergediff {ids} {
2245 global diffmergeid diffpindex parents nparents diffmergegca
2246 global treediffs mergefilelist diffids treepending
2247
2248 # diff the child against each of the parents, and diff
2249 # each of the parents against the GCA.
2250 while 1 {
2251 if {[lindex $ids 0] == $diffmergeid && $diffmergegca ne {}} {
2252 set ids [list [lindex $ids 1] $diffmergegca]
2253 } else {
2254 if {[incr diffpindex] >= $nparents($diffmergeid)} break
2255 set p [lindex $parents($diffmergeid) $diffpindex]
2256 set ids [list $diffmergeid $p]
2257 }
2258 if {![info exists treediffs($ids)]} {
2259 set diffids $ids
2260 if {![info exists treepending]} {
2261 gettreediffs $ids
2262 }
2263 return
2264 }
2265 }
2266
2267 # If a file in some parent is different from the child and also
2268 # different from the GCA, then it's interesting.
2269 # If we don't have a GCA, then a file is interesting if it is
2270 # different from the child in all the parents.
2271 if {$diffmergegca ne {}} {
2272 set files {}
2273 foreach p $parents($diffmergeid) {
2274 set gcadiffs $treediffs([list $p $diffmergegca])
2275 foreach f $treediffs([list $diffmergeid $p]) {
2276 if {[lsearch -exact $files $f] < 0
2277 && [lsearch -exact $gcadiffs $f] >= 0} {
2278 lappend files $f
2279 }
2280 }
2281 }
2282 set files [lsort $files]
2283 } else {
2284 set p [lindex $parents($diffmergeid) 0]
2285 set files $treediffs([list $diffmergeid $p])
2286 for {set i 1} {$i < $nparents($diffmergeid) && $files ne {}} {incr i} {
2287 set p [lindex $parents($diffmergeid) $i]
2288 set df $treediffs([list $diffmergeid $p])
2289 set nf {}
2290 foreach f $files {
2291 if {[lsearch -exact $df $f] >= 0} {
2292 lappend nf $f
2293 }
2294 }
2295 set files $nf
2296 }
2297 }
2298
2299 set mergefilelist($diffmergeid) $files
2300 if {$files ne {}} {
2301 showmergediff
2302 }
2303 }
2304
2305 proc showmergediff {} {
2306 global cflist diffmergeid mergefilelist parents
2307 global diffopts diffinhunk currentfile currenthunk filelines
2308 global diffblocked groupfilelast mergefds groupfilenum grouphunks
2309
2310 set files $mergefilelist($diffmergeid)
2311 foreach f $files {
2312 $cflist insert end $f
2313 }
2314 set env(GIT_DIFF_OPTS) $diffopts
2315 set flist {}
2316 catch {unset currentfile}
2317 catch {unset currenthunk}
2318 catch {unset filelines}
2319 catch {unset groupfilenum}
2320 catch {unset grouphunks}
2321 set groupfilelast -1
2322 foreach p $parents($diffmergeid) {
2323 set cmd [list | hg git-diff-tree -p $p $diffmergeid]
2324 set cmd [concat $cmd $mergefilelist($diffmergeid)]
2325 if {[catch {set f [open $cmd r]} err]} {
2326 error_popup "Error getting diffs: $err"
2327 foreach f $flist {
2328 catch {close $f}
2329 }
2330 return
2331 }
2332 lappend flist $f
2333 set ids [list $diffmergeid $p]
2334 set mergefds($ids) $f
2335 set diffinhunk($ids) 0
2336 set diffblocked($ids) 0
2337 fconfigure $f -blocking 0
2338 fileevent $f readable [list getmergediffline $f $ids $diffmergeid]
2339 }
2340 }
2341
2342 proc getmergediffline {f ids id} {
2343 global diffmergeid diffinhunk diffoldlines diffnewlines
2344 global currentfile currenthunk
2345 global diffoldstart diffnewstart diffoldlno diffnewlno
2346 global diffblocked mergefilelist
2347 global noldlines nnewlines difflcounts filelines
2348
2349 set n [gets $f line]
2350 if {$n < 0} {
2351 if {![eof $f]} return
2352 }
2353
2354 if {!([info exists diffmergeid] && $diffmergeid == $id)} {
2355 if {$n < 0} {
2356 close $f
2357 }
2358 return
2359 }
2360
2361 if {$diffinhunk($ids) != 0} {
2362 set fi $currentfile($ids)
2363 if {$n > 0 && [regexp {^[-+ \\]} $line match]} {
2364 # continuing an existing hunk
2365 set line [string range $line 1 end]
2366 set p [lindex $ids 1]
2367 if {$match eq "-" || $match eq " "} {
2368 set filelines($p,$fi,$diffoldlno($ids)) $line
2369 incr diffoldlno($ids)
2370 }
2371 if {$match eq "+" || $match eq " "} {
2372 set filelines($id,$fi,$diffnewlno($ids)) $line
2373 incr diffnewlno($ids)
2374 }
2375 if {$match eq " "} {
2376 if {$diffinhunk($ids) == 2} {
2377 lappend difflcounts($ids) \
2378 [list $noldlines($ids) $nnewlines($ids)]
2379 set noldlines($ids) 0
2380 set diffinhunk($ids) 1
2381 }
2382 incr noldlines($ids)
2383 } elseif {$match eq "-" || $match eq "+"} {
2384 if {$diffinhunk($ids) == 1} {
2385 lappend difflcounts($ids) [list $noldlines($ids)]
2386 set noldlines($ids) 0
2387 set nnewlines($ids) 0
2388 set diffinhunk($ids) 2
2389 }
2390 if {$match eq "-"} {
2391 incr noldlines($ids)
2392 } else {
2393 incr nnewlines($ids)
2394 }
2395 }
2396 # and if it's \ No newline at end of line, then what?
2397 return
2398 }
2399 # end of a hunk
2400 if {$diffinhunk($ids) == 1 && $noldlines($ids) != 0} {
2401 lappend difflcounts($ids) [list $noldlines($ids)]
2402 } elseif {$diffinhunk($ids) == 2
2403 && ($noldlines($ids) != 0 || $nnewlines($ids) != 0)} {
2404 lappend difflcounts($ids) [list $noldlines($ids) $nnewlines($ids)]
2405 }
2406 set currenthunk($ids) [list $currentfile($ids) \
2407 $diffoldstart($ids) $diffnewstart($ids) \
2408 $diffoldlno($ids) $diffnewlno($ids) \
2409 $difflcounts($ids)]
2410 set diffinhunk($ids) 0
2411 # -1 = need to block, 0 = unblocked, 1 = is blocked
2412 set diffblocked($ids) -1
2413 processhunks
2414 if {$diffblocked($ids) == -1} {
2415 fileevent $f readable {}
2416 set diffblocked($ids) 1
2417 }
2418 }
2419
2420 if {$n < 0} {
2421 # eof
2422 if {!$diffblocked($ids)} {
2423 close $f
2424 set currentfile($ids) [llength $mergefilelist($diffmergeid)]
2425 set currenthunk($ids) [list $currentfile($ids) 0 0 0 0 {}]
2426 processhunks
2427 }
2428 } elseif {[regexp {^diff --git a/(.*) b/} $line match fname]} {
2429 # start of a new file
2430 set currentfile($ids) \
2431 [lsearch -exact $mergefilelist($diffmergeid) $fname]
2432 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2433 $line match f1l f1c f2l f2c rest]} {
2434 if {[info exists currentfile($ids)] && $currentfile($ids) >= 0} {
2435 # start of a new hunk
2436 if {$f1l == 0 && $f1c == 0} {
2437 set f1l 1
2438 }
2439 if {$f2l == 0 && $f2c == 0} {
2440 set f2l 1
2441 }
2442 set diffinhunk($ids) 1
2443 set diffoldstart($ids) $f1l
2444 set diffnewstart($ids) $f2l
2445 set diffoldlno($ids) $f1l
2446 set diffnewlno($ids) $f2l
2447 set difflcounts($ids) {}
2448 set noldlines($ids) 0
2449 set nnewlines($ids) 0
2450 }
2451 }
1150 }
2452 }
1151
2453
1152 proc addtocflist {id} {
2454 proc processhunks {} {
1153 global currentid treediffs cflist treepending
2455 global diffmergeid parents nparents currenthunk
1154 if {$id != $currentid} {
2456 global mergefilelist diffblocked mergefds
1155 gettreediffs $currentid
2457 global grouphunks grouplinestart grouplineend groupfilenum
1156 return
2458
1157 }
2459 set nfiles [llength $mergefilelist($diffmergeid)]
1158 $cflist insert end "All files"
2460 while 1 {
1159 foreach f $treediffs($currentid) {
2461 set fi $nfiles
1160 $cflist insert end $f
2462 set lno 0
1161 }
2463 # look for the earliest hunk
1162 getblobdiffs $id
2464 foreach p $parents($diffmergeid) {
2465 set ids [list $diffmergeid $p]
2466 if {![info exists currenthunk($ids)]} return
2467 set i [lindex $currenthunk($ids) 0]
2468 set l [lindex $currenthunk($ids) 2]
2469 if {$i < $fi || ($i == $fi && $l < $lno)} {
2470 set fi $i
2471 set lno $l
2472 set pi $p
2473 }
2474 }
2475
2476 if {$fi < $nfiles} {
2477 set ids [list $diffmergeid $pi]
2478 set hunk $currenthunk($ids)
2479 unset currenthunk($ids)
2480 if {$diffblocked($ids) > 0} {
2481 fileevent $mergefds($ids) readable \
2482 [list getmergediffline $mergefds($ids) $ids $diffmergeid]
2483 }
2484 set diffblocked($ids) 0
2485
2486 if {[info exists groupfilenum] && $groupfilenum == $fi
2487 && $lno <= $grouplineend} {
2488 # add this hunk to the pending group
2489 lappend grouphunks($pi) $hunk
2490 set endln [lindex $hunk 4]
2491 if {$endln > $grouplineend} {
2492 set grouplineend $endln
2493 }
2494 continue
2495 }
2496 }
2497
2498 # succeeding stuff doesn't belong in this group, so
2499 # process the group now
2500 if {[info exists groupfilenum]} {
2501 processgroup
2502 unset groupfilenum
2503 unset grouphunks
2504 }
2505
2506 if {$fi >= $nfiles} break
2507
2508 # start a new group
2509 set groupfilenum $fi
2510 set grouphunks($pi) [list $hunk]
2511 set grouplinestart $lno
2512 set grouplineend [lindex $hunk 4]
2513 }
2514 }
2515
2516 proc processgroup {} {
2517 global groupfilelast groupfilenum difffilestart
2518 global mergefilelist diffmergeid ctext filelines
2519 global parents diffmergeid diffoffset
2520 global grouphunks grouplinestart grouplineend nparents
2521 global mergemax
2522
2523 $ctext conf -state normal
2524 set id $diffmergeid
2525 set f $groupfilenum
2526 if {$groupfilelast != $f} {
2527 $ctext insert end "\n"
2528 set here [$ctext index "end - 1c"]
2529 set difffilestart($f) $here
2530 set mark fmark.[expr {$f + 1}]
2531 $ctext mark set $mark $here
2532 $ctext mark gravity $mark left
2533 set header [lindex $mergefilelist($id) $f]
2534 set l [expr {(78 - [string length $header]) / 2}]
2535 set pad [string range "----------------------------------------" 1 $l]
2536 $ctext insert end "$pad $header $pad\n" filesep
2537 set groupfilelast $f
2538 foreach p $parents($id) {
2539 set diffoffset($p) 0
2540 }
2541 }
2542
2543 $ctext insert end "@@" msep
2544 set nlines [expr {$grouplineend - $grouplinestart}]
2545 set events {}
2546 set pnum 0
2547 foreach p $parents($id) {
2548 set startline [expr {$grouplinestart + $diffoffset($p)}]
2549 set ol $startline
2550 set nl $grouplinestart
2551 if {[info exists grouphunks($p)]} {
2552 foreach h $grouphunks($p) {
2553 set l [lindex $h 2]
2554 if {$nl < $l} {
2555 for {} {$nl < $l} {incr nl} {
2556 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2557 incr ol
2558 }
2559 }
2560 foreach chunk [lindex $h 5] {
2561 if {[llength $chunk] == 2} {
2562 set olc [lindex $chunk 0]
2563 set nlc [lindex $chunk 1]
2564 set nnl [expr {$nl + $nlc}]
2565 lappend events [list $nl $nnl $pnum $olc $nlc]
2566 incr ol $olc
2567 set nl $nnl
2568 } else {
2569 incr ol [lindex $chunk 0]
2570 incr nl [lindex $chunk 0]
2571 }
2572 }
2573 }
2574 }
2575 if {$nl < $grouplineend} {
2576 for {} {$nl < $grouplineend} {incr nl} {
2577 set filelines($p,$f,$ol) $filelines($id,$f,$nl)
2578 incr ol
2579 }
2580 }
2581 set nlines [expr {$ol - $startline}]
2582 $ctext insert end " -$startline,$nlines" msep
2583 incr pnum
1163 }
2584 }
1164
2585
1165 proc gettreediffs {id} {
2586 set nlines [expr {$grouplineend - $grouplinestart}]
1166 global treediffs parents treepending
2587 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
1167 set treepending $id
2588
1168 set treediffs($id) {}
2589 set events [lsort -integer -index 0 $events]
1169 set p [lindex $parents($id) 0]
2590 set nevents [llength $events]
1170 if [catch {set gdtf [open "|hgit diff-tree -r $p $id" r]}] return
2591 set nmerge $nparents($diffmergeid)
1171 fconfigure $gdtf -blocking 0
2592 set l $grouplinestart
1172 fileevent $gdtf readable "gettreediffline $gdtf $id"
2593 for {set i 0} {$i < $nevents} {set i $j} {
2594 set nl [lindex $events $i 0]
2595 while {$l < $nl} {
2596 $ctext insert end " $filelines($id,$f,$l)\n"
2597 incr l
2598 }
2599 set e [lindex $events $i]
2600 set enl [lindex $e 1]
2601 set j $i
2602 set active {}
2603 while 1 {
2604 set pnum [lindex $e 2]
2605 set olc [lindex $e 3]
2606 set nlc [lindex $e 4]
2607 if {![info exists delta($pnum)]} {
2608 set delta($pnum) [expr {$olc - $nlc}]
2609 lappend active $pnum
2610 } else {
2611 incr delta($pnum) [expr {$olc - $nlc}]
2612 }
2613 if {[incr j] >= $nevents} break
2614 set e [lindex $events $j]
2615 if {[lindex $e 0] >= $enl} break
2616 if {[lindex $e 1] > $enl} {
2617 set enl [lindex $e 1]
2618 }
2619 }
2620 set nlc [expr {$enl - $l}]
2621 set ncol mresult
2622 set bestpn -1
2623 if {[llength $active] == $nmerge - 1} {
2624 # no diff for one of the parents, i.e. it's identical
2625 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2626 if {![info exists delta($pnum)]} {
2627 if {$pnum < $mergemax} {
2628 lappend ncol m$pnum
2629 } else {
2630 lappend ncol mmax
2631 }
2632 break
2633 }
2634 }
2635 } elseif {[llength $active] == $nmerge} {
2636 # all parents are different, see if one is very similar
2637 set bestsim 30
2638 for {set pnum 0} {$pnum < $nmerge} {incr pnum} {
2639 set sim [similarity $pnum $l $nlc $f \
2640 [lrange $events $i [expr {$j-1}]]]
2641 if {$sim > $bestsim} {
2642 set bestsim $sim
2643 set bestpn $pnum
2644 }
2645 }
2646 if {$bestpn >= 0} {
2647 lappend ncol m$bestpn
2648 }
2649 }
2650 set pnum -1
2651 foreach p $parents($id) {
2652 incr pnum
2653 if {![info exists delta($pnum)] || $pnum == $bestpn} continue
2654 set olc [expr {$nlc + $delta($pnum)}]
2655 set ol [expr {$l + $diffoffset($p)}]
2656 incr diffoffset($p) $delta($pnum)
2657 unset delta($pnum)
2658 for {} {$olc > 0} {incr olc -1} {
2659 $ctext insert end "-$filelines($p,$f,$ol)\n" m$pnum
2660 incr ol
2661 }
2662 }
2663 set endl [expr {$l + $nlc}]
2664 if {$bestpn >= 0} {
2665 # show this pretty much as a normal diff
2666 set p [lindex $parents($id) $bestpn]
2667 set ol [expr {$l + $diffoffset($p)}]
2668 incr diffoffset($p) $delta($bestpn)
2669 unset delta($bestpn)
2670 for {set k $i} {$k < $j} {incr k} {
2671 set e [lindex $events $k]
2672 if {[lindex $e 2] != $bestpn} continue
2673 set nl [lindex $e 0]
2674 set ol [expr {$ol + $nl - $l}]
2675 for {} {$l < $nl} {incr l} {
2676 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2677 }
2678 set c [lindex $e 3]
2679 for {} {$c > 0} {incr c -1} {
2680 $ctext insert end "-$filelines($p,$f,$ol)\n" m$bestpn
2681 incr ol
2682 }
2683 set nl [lindex $e 1]
2684 for {} {$l < $nl} {incr l} {
2685 $ctext insert end "+$filelines($id,$f,$l)\n" mresult
2686 }
2687 }
2688 }
2689 for {} {$l < $endl} {incr l} {
2690 $ctext insert end "+$filelines($id,$f,$l)\n" $ncol
2691 }
2692 }
2693 while {$l < $grouplineend} {
2694 $ctext insert end " $filelines($id,$f,$l)\n"
2695 incr l
2696 }
2697 $ctext conf -state disabled
1173 }
2698 }
1174
2699
1175 proc gettreediffline {gdtf id} {
2700 proc similarity {pnum l nlc f events} {
1176 global treediffs treepending
2701 global diffmergeid parents diffoffset filelines
2702
2703 set id $diffmergeid
2704 set p [lindex $parents($id) $pnum]
2705 set ol [expr {$l + $diffoffset($p)}]
2706 set endl [expr {$l + $nlc}]
2707 set same 0
2708 set diff 0
2709 foreach e $events {
2710 if {[lindex $e 2] != $pnum} continue
2711 set nl [lindex $e 0]
2712 set ol [expr {$ol + $nl - $l}]
2713 for {} {$l < $nl} {incr l} {
2714 incr same [string length $filelines($id,$f,$l)]
2715 incr same
2716 }
2717 set oc [lindex $e 3]
2718 for {} {$oc > 0} {incr oc -1} {
2719 incr diff [string length $filelines($p,$f,$ol)]
2720 incr diff
2721 incr ol
2722 }
2723 set nl [lindex $e 1]
2724 for {} {$l < $nl} {incr l} {
2725 incr diff [string length $filelines($id,$f,$l)]
2726 incr diff
2727 }
2728 }
2729 for {} {$l < $endl} {incr l} {
2730 incr same [string length $filelines($id,$f,$l)]
2731 incr same
2732 }
2733 if {$same == 0} {
2734 return 0
2735 }
2736 return [expr {200 * $same / (2 * $same + $diff)}]
2737 }
2738
2739 proc startdiff {ids} {
2740 global treediffs diffids treepending diffmergeid
2741
2742 set diffids $ids
2743 catch {unset diffmergeid}
2744 if {![info exists treediffs($ids)]} {
2745 if {![info exists treepending]} {
2746 gettreediffs $ids
2747 }
2748 } else {
2749 addtocflist $ids
2750 }
2751 }
2752
2753 proc addtocflist {ids} {
2754 global treediffs cflist
2755 foreach f $treediffs($ids) {
2756 $cflist insert end $f
2757 }
2758 getblobdiffs $ids
2759 }
2760
2761 proc gettreediffs {ids} {
2762 global treediff parents treepending
2763 set treepending $ids
2764 set treediff {}
2765 set id [lindex $ids 0]
2766 set p [lindex $ids 1]
2767 if [catch {set gdtf [open "|hg git-diff-tree -r $p $id" r]}] return
2768 fconfigure $gdtf -blocking 0
2769 fileevent $gdtf readable [list gettreediffline $gdtf $ids]
2770 }
2771
2772 proc gettreediffline {gdtf ids} {
2773 global treediff treediffs treepending diffids diffmergeid
2774
1177 set n [gets $gdtf line]
2775 set n [gets $gdtf line]
1178 if {$n < 0} {
2776 if {$n < 0} {
1179 if {![eof $gdtf]} return
2777 if {![eof $gdtf]} return
1180 close $gdtf
2778 close $gdtf
2779 set treediffs($ids) $treediff
1181 unset treepending
2780 unset treepending
1182 addtocflist $id
2781 if {$ids != $diffids} {
2782 gettreediffs $diffids
2783 } else {
2784 if {[info exists diffmergeid]} {
2785 contmergediff $ids
2786 } else {
2787 addtocflist $ids
2788 }
2789 }
1183 return
2790 return
1184 }
2791 }
1185 set file [lindex $line 5]
2792 set file [lindex $line 5]
1186 lappend treediffs($id) $file
2793 lappend treediff $file
1187 }
2794 }
1188
2795
1189 proc getblobdiffs {id} {
2796 proc getblobdiffs {ids} {
1190 global parents diffopts blobdifffd env curdifftag curtagstart
2797 global diffopts blobdifffd diffids env curdifftag curtagstart
1191 global diffindex difffilestart
2798 global difffilestart nextupdate diffinhdr treediffs
1192 set p [lindex $parents($id) 0]
2799
2800 set id [lindex $ids 0]
2801 set p [lindex $ids 1]
1193 set env(GIT_DIFF_OPTS) $diffopts
2802 set env(GIT_DIFF_OPTS) $diffopts
1194 if [catch {set bdf [open "|hgit diff-tree -r -p $p $id" r]} err] {
2803 set cmd [list | hg git-diff-tree -r -p -C $p $id]
2804 if {[catch {set bdf [open $cmd r]} err]} {
1195 puts "error getting diffs: $err"
2805 puts "error getting diffs: $err"
1196 return
2806 return
1197 }
2807 }
2808 set diffinhdr 0
1198 fconfigure $bdf -blocking 0
2809 fconfigure $bdf -blocking 0
1199 set blobdifffd($id) $bdf
2810 set blobdifffd($ids) $bdf
1200 set curdifftag Comments
2811 set curdifftag Comments
1201 set curtagstart 0.0
2812 set curtagstart 0.0
1202 set diffindex 0
1203 catch {unset difffilestart}
2813 catch {unset difffilestart}
1204 fileevent $bdf readable "getblobdiffline $bdf $id"
2814 fileevent $bdf readable [list getblobdiffline $bdf $diffids]
2815 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
1205 }
2816 }
1206
2817
1207 proc getblobdiffline {bdf id} {
2818 proc getblobdiffline {bdf ids} {
1208 global currentid blobdifffd ctext curdifftag curtagstart seenfile
2819 global diffids blobdifffd ctext curdifftag curtagstart
1209 global diffnexthead diffnextnote diffindex difffilestart
2820 global diffnexthead diffnextnote difffilestart
2821 global nextupdate diffinhdr treediffs
2822 global gaudydiff
2823
1210 set n [gets $bdf line]
2824 set n [gets $bdf line]
1211 if {$n < 0} {
2825 if {$n < 0} {
1212 if {[eof $bdf]} {
2826 if {[eof $bdf]} {
1213 close $bdf
2827 close $bdf
1214 if {$id == $currentid && $bdf == $blobdifffd($id)} {
2828 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1215 $ctext tag add $curdifftag $curtagstart end
2829 $ctext tag add $curdifftag $curtagstart end
1216 set seenfile($curdifftag) 1
1217 }
2830 }
1218 }
2831 }
1219 return
2832 return
1220 }
2833 }
1221 if {$id != $currentid || $bdf != $blobdifffd($id)} {
2834 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1222 return
2835 return
1223 }
2836 }
1224 $ctext conf -state normal
2837 $ctext conf -state normal
1225 if {[regexp {^---[ \t]+([^/])*/([^\t]*)} $line match s0 fname]} {
2838 if {[regexp {^diff --git a/(.*) b/(.*)} $line match fname newname]} {
1226 # start of a new file
2839 # start of a new file
1227 $ctext insert end "\n"
2840 $ctext insert end "\n"
1228 $ctext tag add $curdifftag $curtagstart end
2841 $ctext tag add $curdifftag $curtagstart end
1229 set seenfile($curdifftag) 1
1230 set curtagstart [$ctext index "end - 1c"]
2842 set curtagstart [$ctext index "end - 1c"]
1231 set header $fname
2843 set header $newname
1232 if {[info exists diffnexthead]} {
2844 set here [$ctext index "end - 1c"]
1233 set fname $diffnexthead
2845 set i [lsearch -exact $treediffs($diffids) $fname]
1234 set header "$diffnexthead ($diffnextnote)"
2846 if {$i >= 0} {
1235 unset diffnexthead
2847 set difffilestart($i) $here
1236 }
2848 incr i
1237 set difffilestart($diffindex) [$ctext index "end - 1c"]
2849 $ctext mark set fmark.$i $here
1238 incr diffindex
2850 $ctext mark gravity fmark.$i left
2851 }
2852 if {$newname != $fname} {
2853 set i [lsearch -exact $treediffs($diffids) $newname]
2854 if {$i >= 0} {
2855 set difffilestart($i) $here
2856 incr i
2857 $ctext mark set fmark.$i $here
2858 $ctext mark gravity fmark.$i left
2859 }
2860 }
1239 set curdifftag "f:$fname"
2861 set curdifftag "f:$fname"
1240 $ctext tag delete $curdifftag
2862 $ctext tag delete $curdifftag
1241 set l [expr {(78 - [string length $header]) / 2}]
2863 set l [expr {(78 - [string length $header]) / 2}]
1242 set pad [string range "----------------------------------------" 1 $l]
2864 set pad [string range "----------------------------------------" 1 $l]
1243 $ctext insert end "$pad $header $pad\n" filesep
2865 $ctext insert end "$pad $header $pad\n" filesep
1244 } elseif {[string range $line 0 2] == "+++"} {
2866 set diffinhdr 1
1245 # no need to do anything with this
2867 } elseif {[regexp {^(---|\+\+\+)} $line]} {
1246 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
2868 set diffinhdr 0
1247 set diffnexthead $fn
1248 set diffnextnote "created, mode $m"
1249 } elseif {[string range $line 0 8] == "Deleted: "} {
1250 set diffnexthead [string range $line 9 end]
1251 set diffnextnote "deleted"
1252 } elseif {[regexp {^diff --git a/(.*) b/} $line match fn]} {
1253 # save the filename in case the next thing is "new file mode ..."
1254 set diffnexthead $fn
1255 set diffnextnote "modified"
1256 } elseif {[regexp {^new file mode ([0-7]+)} $line match m]} {
1257 set diffnextnote "new file, mode $m"
1258 } elseif {[string range $line 0 11] == "deleted file"} {
1259 set diffnextnote "deleted"
1260 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
2869 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1261 $line match f1l f1c f2l f2c rest]} {
2870 $line match f1l f1c f2l f2c rest]} {
2871 if {$gaudydiff} {
1262 $ctext insert end "\t" hunksep
2872 $ctext insert end "\t" hunksep
1263 $ctext insert end " $f1l " d0 " $f2l " d1
2873 $ctext insert end " $f1l " d0 " $f2l " d1
1264 $ctext insert end " $rest \n" hunksep
2874 $ctext insert end " $rest \n" hunksep
1265 } else {
2875 } else {
2876 $ctext insert end "$line\n" hunksep
2877 }
2878 set diffinhdr 0
2879 } else {
1266 set x [string range $line 0 0]
2880 set x [string range $line 0 0]
1267 if {$x == "-" || $x == "+"} {
2881 if {$x == "-" || $x == "+"} {
1268 set tag [expr {$x == "+"}]
2882 set tag [expr {$x == "+"}]
2883 if {$gaudydiff} {
1269 set line [string range $line 1 end]
2884 set line [string range $line 1 end]
2885 }
1270 $ctext insert end "$line\n" d$tag
2886 $ctext insert end "$line\n" d$tag
1271 } elseif {$x == " "} {
2887 } elseif {$x == " "} {
2888 if {$gaudydiff} {
1272 set line [string range $line 1 end]
2889 set line [string range $line 1 end]
2890 }
1273 $ctext insert end "$line\n"
2891 $ctext insert end "$line\n"
1274 } elseif {$x == "\\"} {
2892 } elseif {$diffinhdr || $x == "\\"} {
1275 # e.g. "\ No newline at end of file"
2893 # e.g. "\ No newline at end of file"
1276 $ctext insert end "$line\n" filesep
2894 $ctext insert end "$line\n" filesep
1277 } else {
2895 } else {
1278 # Something else we don't recognize
2896 # Something else we don't recognize
1279 if {$curdifftag != "Comments"} {
2897 if {$curdifftag != "Comments"} {
1280 $ctext insert end "\n"
2898 $ctext insert end "\n"
1281 $ctext tag add $curdifftag $curtagstart end
2899 $ctext tag add $curdifftag $curtagstart end
1282 set seenfile($curdifftag) 1
1283 set curtagstart [$ctext index "end - 1c"]
2900 set curtagstart [$ctext index "end - 1c"]
1284 set curdifftag Comments
2901 set curdifftag Comments
1285 }
2902 }
1286 $ctext insert end "$line\n" filesep
2903 $ctext insert end "$line\n" filesep
1287 }
2904 }
1288 }
2905 }
1289 $ctext conf -state disabled
2906 $ctext conf -state disabled
2907 if {[clock clicks -milliseconds] >= $nextupdate} {
2908 incr nextupdate 100
2909 fileevent $bdf readable {}
2910 update
2911 fileevent $bdf readable "getblobdiffline $bdf {$ids}"
2912 }
1290 }
2913 }
1291
2914
1292 proc nextfile {} {
2915 proc nextfile {} {
1293 global difffilestart ctext
2916 global difffilestart ctext
1294 set here [$ctext index @0,0]
2917 set here [$ctext index @0,0]
1295 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
2918 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1296 if {[$ctext compare $difffilestart($i) > $here]} {
2919 if {[$ctext compare $difffilestart($i) > $here]} {
1297 $ctext yview $difffilestart($i)
2920 if {![info exists pos]
1298 break
2921 || [$ctext compare $difffilestart($i) < $pos]} {
1299 }
2922 set pos $difffilestart($i)
2923 }
2924 }
2925 }
2926 if {[info exists pos]} {
2927 $ctext yview $pos
1300 }
2928 }
1301 }
2929 }
1302
2930
1303 proc listboxsel {} {
2931 proc listboxsel {} {
1304 global ctext cflist currentid treediffs seenfile
2932 global ctext cflist currentid
1305 if {![info exists currentid]} return
2933 if {![info exists currentid]} return
1306 set sel [$cflist curselection]
2934 set sel [lsort [$cflist curselection]]
1307 if {$sel == {} || [lsearch -exact $sel 0] >= 0} {
2935 if {$sel eq {}} return
1308 # show everything
2936 set first [lindex $sel 0]
1309 $ctext tag conf Comments -elide 0
2937 catch {$ctext yview fmark.$first}
1310 foreach f $treediffs($currentid) {
1311 if [info exists seenfile(f:$f)] {
1312 $ctext tag conf "f:$f" -elide 0
1313 }
1314 }
1315 } else {
1316 # just show selected files
1317 $ctext tag conf Comments -elide 1
1318 set i 1
1319 foreach f $treediffs($currentid) {
1320 set elide [expr {[lsearch -exact $sel $i] < 0}]
1321 if [info exists seenfile(f:$f)] {
1322 $ctext tag conf "f:$f" -elide $elide
1323 }
1324 incr i
1325 }
1326 }
1327 }
2938 }
1328
2939
1329 proc setcoords {} {
2940 proc setcoords {} {
1330 global linespc charspc canvx0 canvy0 mainfont
2941 global linespc charspc canvx0 canvy0 mainfont
2942 global xspc1 xspc2 lthickness
2943
1331 set linespc [font metrics $mainfont -linespace]
2944 set linespc [font metrics $mainfont -linespace]
1332 set charspc [font measure $mainfont "m"]
2945 set charspc [font measure $mainfont "m"]
1333 set canvy0 [expr 3 + 0.5 * $linespc]
2946 set canvy0 [expr 3 + 0.5 * $linespc]
1334 set canvx0 [expr 3 + 0.5 * $linespc]
2947 set canvx0 [expr 3 + 0.5 * $linespc]
2948 set lthickness [expr {int($linespc / 9) + 1}]
2949 set xspc1(0) $linespc
2950 set xspc2 $linespc
1335 }
2951 }
1336
2952
1337 proc redisplay {} {
2953 proc redisplay {} {
1338 global selectedline stopped redisplaying phase
2954 global stopped redisplaying phase
1339 if {$stopped > 1} return
2955 if {$stopped > 1} return
1340 if {$phase == "getcommits"} return
2956 if {$phase == "getcommits"} return
1341 set redisplaying 1
2957 set redisplaying 1
1342 if {$phase == "drawgraph"} {
2958 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1343 set stopped 1
2959 set stopped 1
1344 } else {
2960 } else {
1345 drawgraph
2961 drawgraph
1346 }
2962 }
1347 }
2963 }
1348
2964
1349 proc incrfont {inc} {
2965 proc incrfont {inc} {
1350 global mainfont namefont textfont selectedline ctext canv phase
2966 global mainfont namefont textfont ctext canv phase
1351 global stopped entries
2967 global stopped entries
1352 unmarkmatches
2968 unmarkmatches
1353 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
2969 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1354 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
2970 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1355 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
2971 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1356 setcoords
2972 setcoords
1357 $ctext conf -font $textfont
2973 $ctext conf -font $textfont
1358 $ctext tag conf filesep -font [concat $textfont bold]
2974 $ctext tag conf filesep -font [concat $textfont bold]
1359 foreach e $entries {
2975 foreach e $entries {
1360 $e conf -font $mainfont
2976 $e conf -font $mainfont
1361 }
2977 }
1362 if {$phase == "getcommits"} {
2978 if {$phase == "getcommits"} {
1363 $canv itemconf textitems -font $mainfont
2979 $canv itemconf textitems -font $mainfont
1364 }
2980 }
1365 redisplay
2981 redisplay
1366 }
2982 }
1367
2983
2984 proc clearsha1 {} {
2985 global sha1entry sha1string
2986 if {[string length $sha1string] == 40} {
2987 $sha1entry delete 0 end
2988 }
2989 }
2990
1368 proc sha1change {n1 n2 op} {
2991 proc sha1change {n1 n2 op} {
1369 global sha1string currentid sha1but
2992 global sha1string currentid sha1but
1370 if {$sha1string == {}
2993 if {$sha1string == {}
1371 || ([info exists currentid] && $sha1string == $currentid)} {
2994 || ([info exists currentid] && $sha1string == $currentid)} {
1372 set state disabled
2995 set state disabled
1373 } else {
2996 } else {
1374 set state normal
2997 set state normal
1375 }
2998 }
1376 if {[$sha1but cget -state] == $state} return
2999 if {[$sha1but cget -state] == $state} return
1377 if {$state == "normal"} {
3000 if {$state == "normal"} {
1378 $sha1but conf -state normal -relief raised -text "Goto: "
3001 $sha1but conf -state normal -relief raised -text "Goto: "
1379 } else {
3002 } else {
1380 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
3003 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1381 }
3004 }
1382 }
3005 }
1383
3006
1384 proc gotocommit {} {
3007 proc gotocommit {} {
1385 global sha1string currentid idline tagids
3008 global sha1string currentid idline tagids
3009 global lineid numcommits
3010
1386 if {$sha1string == {}
3011 if {$sha1string == {}
1387 || ([info exists currentid] && $sha1string == $currentid)} return
3012 || ([info exists currentid] && $sha1string == $currentid)} return
1388 if {[info exists tagids($sha1string)]} {
3013 if {[info exists tagids($sha1string)]} {
1389 set id $tagids($sha1string)
3014 set id $tagids($sha1string)
1390 } else {
3015 } else {
1391 set id [string tolower $sha1string]
3016 set id [string tolower $sha1string]
3017 if {[regexp {^[0-9a-f]{4,39}$} $id]} {
3018 set matches {}
3019 for {set l 0} {$l < $numcommits} {incr l} {
3020 if {[string match $id* $lineid($l)]} {
3021 lappend matches $lineid($l)
3022 }
3023 }
3024 if {$matches ne {}} {
3025 if {[llength $matches] > 1} {
3026 error_popup "Short SHA1 id $id is ambiguous"
3027 return
3028 }
3029 set id [lindex $matches 0]
3030 }
3031 }
1392 }
3032 }
1393 if {[info exists idline($id)]} {
3033 if {[info exists idline($id)]} {
1394 selectline $idline($id)
3034 selectline $idline($id) 1
1395 return
3035 return
1396 }
3036 }
1397 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
3037 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
1398 set type "SHA1 id"
3038 set type "SHA1 id"
1399 } else {
3039 } else {
1400 set type "Tag"
3040 set type "Tag"
1401 }
3041 }
1402 error_popup "$type $sha1string is not known"
3042 error_popup "$type $sha1string is not known"
1403 }
3043 }
1404
3044
3045 proc lineenter {x y id} {
3046 global hoverx hovery hoverid hovertimer
3047 global commitinfo canv
3048
3049 if {![info exists commitinfo($id)]} return
3050 set hoverx $x
3051 set hovery $y
3052 set hoverid $id
3053 if {[info exists hovertimer]} {
3054 after cancel $hovertimer
3055 }
3056 set hovertimer [after 500 linehover]
3057 $canv delete hover
3058 }
3059
3060 proc linemotion {x y id} {
3061 global hoverx hovery hoverid hovertimer
3062
3063 if {[info exists hoverid] && $id == $hoverid} {
3064 set hoverx $x
3065 set hovery $y
3066 if {[info exists hovertimer]} {
3067 after cancel $hovertimer
3068 }
3069 set hovertimer [after 500 linehover]
3070 }
3071 }
3072
3073 proc lineleave {id} {
3074 global hoverid hovertimer canv
3075
3076 if {[info exists hoverid] && $id == $hoverid} {
3077 $canv delete hover
3078 if {[info exists hovertimer]} {
3079 after cancel $hovertimer
3080 unset hovertimer
3081 }
3082 unset hoverid
3083 }
3084 }
3085
3086 proc linehover {} {
3087 global hoverx hovery hoverid hovertimer
3088 global canv linespc lthickness
3089 global commitinfo mainfont
3090
3091 set text [lindex $commitinfo($hoverid) 0]
3092 set ymax [lindex [$canv cget -scrollregion] 3]
3093 if {$ymax == {}} return
3094 set yfrac [lindex [$canv yview] 0]
3095 set x [expr {$hoverx + 2 * $linespc}]
3096 set y [expr {$hovery + $yfrac * $ymax - $linespc / 2}]
3097 set x0 [expr {$x - 2 * $lthickness}]
3098 set y0 [expr {$y - 2 * $lthickness}]
3099 set x1 [expr {$x + [font measure $mainfont $text] + 2 * $lthickness}]
3100 set y1 [expr {$y + $linespc + 2 * $lthickness}]
3101 set t [$canv create rectangle $x0 $y0 $x1 $y1 \
3102 -fill \#ffff80 -outline black -width 1 -tags hover]
3103 $canv raise $t
3104 set t [$canv create text $x $y -anchor nw -text $text -tags hover]
3105 $canv raise $t
3106 }
3107
3108 proc clickisonarrow {id y} {
3109 global mainline mainlinearrow sidelines lthickness
3110
3111 set thresh [expr {2 * $lthickness + 6}]
3112 if {[info exists mainline($id)]} {
3113 if {$mainlinearrow($id) ne "none"} {
3114 if {abs([lindex $mainline($id) 1] - $y) < $thresh} {
3115 return "up"
3116 }
3117 }
3118 }
3119 if {[info exists sidelines($id)]} {
3120 foreach ls $sidelines($id) {
3121 set coords [lindex $ls 0]
3122 set arrow [lindex $ls 2]
3123 if {$arrow eq "first" || $arrow eq "both"} {
3124 if {abs([lindex $coords 1] - $y) < $thresh} {
3125 return "up"
3126 }
3127 }
3128 if {$arrow eq "last" || $arrow eq "both"} {
3129 if {abs([lindex $coords end] - $y) < $thresh} {
3130 return "down"
3131 }
3132 }
3133 }
3134 }
3135 return {}
3136 }
3137
3138 proc arrowjump {id dirn y} {
3139 global mainline sidelines canv
3140
3141 set yt {}
3142 if {$dirn eq "down"} {
3143 if {[info exists mainline($id)]} {
3144 set y1 [lindex $mainline($id) 1]
3145 if {$y1 > $y} {
3146 set yt $y1
3147 }
3148 }
3149 if {[info exists sidelines($id)]} {
3150 foreach ls $sidelines($id) {
3151 set y1 [lindex $ls 0 1]
3152 if {$y1 > $y && ($yt eq {} || $y1 < $yt)} {
3153 set yt $y1
3154 }
3155 }
3156 }
3157 } else {
3158 if {[info exists sidelines($id)]} {
3159 foreach ls $sidelines($id) {
3160 set y1 [lindex $ls 0 end]
3161 if {$y1 < $y && ($yt eq {} || $y1 > $yt)} {
3162 set yt $y1
3163 }
3164 }
3165 }
3166 }
3167 if {$yt eq {}} return
3168 set ymax [lindex [$canv cget -scrollregion] 3]
3169 if {$ymax eq {} || $ymax <= 0} return
3170 set view [$canv yview]
3171 set yspan [expr {[lindex $view 1] - [lindex $view 0]}]
3172 set yfrac [expr {$yt / $ymax - $yspan / 2}]
3173 if {$yfrac < 0} {
3174 set yfrac 0
3175 }
3176 $canv yview moveto $yfrac
3177 }
3178
3179 proc lineclick {x y id isnew} {
3180 global ctext commitinfo children cflist canv thickerline
3181
3182 unmarkmatches
3183 unselectline
3184 normalline
3185 $canv delete hover
3186 # draw this line thicker than normal
3187 drawlines $id 1
3188 set thickerline $id
3189 if {$isnew} {
3190 set ymax [lindex [$canv cget -scrollregion] 3]
3191 if {$ymax eq {}} return
3192 set yfrac [lindex [$canv yview] 0]
3193 set y [expr {$y + $yfrac * $ymax}]
3194 }
3195 set dirn [clickisonarrow $id $y]
3196 if {$dirn ne {}} {
3197 arrowjump $id $dirn $y
3198 return
3199 }
3200
3201 if {$isnew} {
3202 addtohistory [list lineclick $x $y $id 0]
3203 }
3204 # fill the details pane with info about this line
3205 $ctext conf -state normal
3206 $ctext delete 0.0 end
3207 $ctext tag conf link -foreground blue -underline 1
3208 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3209 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3210 $ctext insert end "Parent:\t"
3211 $ctext insert end $id [list link link0]
3212 $ctext tag bind link0 <1> [list selbyid $id]
3213 set info $commitinfo($id)
3214 $ctext insert end "\n\t[lindex $info 0]\n"
3215 $ctext insert end "\tAuthor:\t[lindex $info 1]\n"
3216 $ctext insert end "\tDate:\t[lindex $info 2]\n"
3217 if {[info exists children($id)]} {
3218 $ctext insert end "\nChildren:"
3219 set i 0
3220 foreach child $children($id) {
3221 incr i
3222 set info $commitinfo($child)
3223 $ctext insert end "\n\t"
3224 $ctext insert end $child [list link link$i]
3225 $ctext tag bind link$i <1> [list selbyid $child]
3226 $ctext insert end "\n\t[lindex $info 0]"
3227 $ctext insert end "\n\tAuthor:\t[lindex $info 1]"
3228 $ctext insert end "\n\tDate:\t[lindex $info 2]\n"
3229 }
3230 }
3231 $ctext conf -state disabled
3232
3233 $cflist delete 0 end
3234 }
3235
3236 proc normalline {} {
3237 global thickerline
3238 if {[info exists thickerline]} {
3239 drawlines $thickerline 0
3240 unset thickerline
3241 }
3242 }
3243
3244 proc selbyid {id} {
3245 global idline
3246 if {[info exists idline($id)]} {
3247 selectline $idline($id) 1
3248 }
3249 }
3250
3251 proc mstime {} {
3252 global startmstime
3253 if {![info exists startmstime]} {
3254 set startmstime [clock clicks -milliseconds]
3255 }
3256 return [format "%.3f" [expr {([clock click -milliseconds] - $startmstime) / 1000.0}]]
3257 }
3258
3259 proc rowmenu {x y id} {
3260 global rowctxmenu idline selectedline rowmenuid
3261
3262 if {![info exists selectedline] || $idline($id) eq $selectedline} {
3263 set state disabled
3264 } else {
3265 set state normal
3266 }
3267 $rowctxmenu entryconfigure 0 -state $state
3268 $rowctxmenu entryconfigure 1 -state $state
3269 $rowctxmenu entryconfigure 2 -state $state
3270 set rowmenuid $id
3271 tk_popup $rowctxmenu $x $y
3272 }
3273
3274 proc diffvssel {dirn} {
3275 global rowmenuid selectedline lineid
3276
3277 if {![info exists selectedline]} return
3278 if {$dirn} {
3279 set oldid $lineid($selectedline)
3280 set newid $rowmenuid
3281 } else {
3282 set oldid $rowmenuid
3283 set newid $lineid($selectedline)
3284 }
3285 addtohistory [list doseldiff $oldid $newid]
3286 doseldiff $oldid $newid
3287 }
3288
3289 proc doseldiff {oldid newid} {
3290 global ctext cflist
3291 global commitinfo
3292
3293 $ctext conf -state normal
3294 $ctext delete 0.0 end
3295 $ctext mark set fmark.0 0.0
3296 $ctext mark gravity fmark.0 left
3297 $cflist delete 0 end
3298 $cflist insert end "Top"
3299 $ctext insert end "From "
3300 $ctext tag conf link -foreground blue -underline 1
3301 $ctext tag bind link <Enter> { %W configure -cursor hand2 }
3302 $ctext tag bind link <Leave> { %W configure -cursor $curtextcursor }
3303 $ctext tag bind link0 <1> [list selbyid $oldid]
3304 $ctext insert end $oldid [list link link0]
3305 $ctext insert end "\n "
3306 $ctext insert end [lindex $commitinfo($oldid) 0]
3307 $ctext insert end "\n\nTo "
3308 $ctext tag bind link1 <1> [list selbyid $newid]
3309 $ctext insert end $newid [list link link1]
3310 $ctext insert end "\n "
3311 $ctext insert end [lindex $commitinfo($newid) 0]
3312 $ctext insert end "\n"
3313 $ctext conf -state disabled
3314 $ctext tag delete Comments
3315 $ctext tag remove found 1.0 end
3316 startdiff [list $newid $oldid]
3317 }
3318
3319 proc mkpatch {} {
3320 global rowmenuid currentid commitinfo patchtop patchnum
3321
3322 if {![info exists currentid]} return
3323 set oldid $currentid
3324 set oldhead [lindex $commitinfo($oldid) 0]
3325 set newid $rowmenuid
3326 set newhead [lindex $commitinfo($newid) 0]
3327 set top .patch
3328 set patchtop $top
3329 catch {destroy $top}
3330 toplevel $top
3331 label $top.title -text "Generate patch"
3332 grid $top.title - -pady 10
3333 label $top.from -text "From:"
3334 entry $top.fromsha1 -width 40 -relief flat
3335 $top.fromsha1 insert 0 $oldid
3336 $top.fromsha1 conf -state readonly
3337 grid $top.from $top.fromsha1 -sticky w
3338 entry $top.fromhead -width 60 -relief flat
3339 $top.fromhead insert 0 $oldhead
3340 $top.fromhead conf -state readonly
3341 grid x $top.fromhead -sticky w
3342 label $top.to -text "To:"
3343 entry $top.tosha1 -width 40 -relief flat
3344 $top.tosha1 insert 0 $newid
3345 $top.tosha1 conf -state readonly
3346 grid $top.to $top.tosha1 -sticky w
3347 entry $top.tohead -width 60 -relief flat
3348 $top.tohead insert 0 $newhead
3349 $top.tohead conf -state readonly
3350 grid x $top.tohead -sticky w
3351 button $top.rev -text "Reverse" -command mkpatchrev -padx 5
3352 grid $top.rev x -pady 10
3353 label $top.flab -text "Output file:"
3354 entry $top.fname -width 60
3355 $top.fname insert 0 [file normalize "patch$patchnum.patch"]
3356 incr patchnum
3357 grid $top.flab $top.fname -sticky w
3358 frame $top.buts
3359 button $top.buts.gen -text "Generate" -command mkpatchgo
3360 button $top.buts.can -text "Cancel" -command mkpatchcan
3361 grid $top.buts.gen $top.buts.can
3362 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3363 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3364 grid $top.buts - -pady 10 -sticky ew
3365 focus $top.fname
3366 }
3367
3368 proc mkpatchrev {} {
3369 global patchtop
3370
3371 set oldid [$patchtop.fromsha1 get]
3372 set oldhead [$patchtop.fromhead get]
3373 set newid [$patchtop.tosha1 get]
3374 set newhead [$patchtop.tohead get]
3375 foreach e [list fromsha1 fromhead tosha1 tohead] \
3376 v [list $newid $newhead $oldid $oldhead] {
3377 $patchtop.$e conf -state normal
3378 $patchtop.$e delete 0 end
3379 $patchtop.$e insert 0 $v
3380 $patchtop.$e conf -state readonly
3381 }
3382 }
3383
3384 proc mkpatchgo {} {
3385 global patchtop
3386
3387 set oldid [$patchtop.fromsha1 get]
3388 set newid [$patchtop.tosha1 get]
3389 set fname [$patchtop.fname get]
3390 if {[catch {exec hg git-diff-tree -p $oldid $newid >$fname &} err]} {
3391 error_popup "Error creating patch: $err"
3392 }
3393 catch {destroy $patchtop}
3394 unset patchtop
3395 }
3396
3397 proc mkpatchcan {} {
3398 global patchtop
3399
3400 catch {destroy $patchtop}
3401 unset patchtop
3402 }
3403
3404 proc mktag {} {
3405 global rowmenuid mktagtop commitinfo
3406
3407 set top .maketag
3408 set mktagtop $top
3409 catch {destroy $top}
3410 toplevel $top
3411 label $top.title -text "Create tag"
3412 grid $top.title - -pady 10
3413 label $top.id -text "ID:"
3414 entry $top.sha1 -width 40 -relief flat
3415 $top.sha1 insert 0 $rowmenuid
3416 $top.sha1 conf -state readonly
3417 grid $top.id $top.sha1 -sticky w
3418 entry $top.head -width 60 -relief flat
3419 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3420 $top.head conf -state readonly
3421 grid x $top.head -sticky w
3422 label $top.tlab -text "Tag name:"
3423 entry $top.tag -width 60
3424 grid $top.tlab $top.tag -sticky w
3425 frame $top.buts
3426 button $top.buts.gen -text "Create" -command mktaggo
3427 button $top.buts.can -text "Cancel" -command mktagcan
3428 grid $top.buts.gen $top.buts.can
3429 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3430 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3431 grid $top.buts - -pady 10 -sticky ew
3432 focus $top.tag
3433 }
3434
3435 proc domktag {} {
3436 global mktagtop env tagids idtags
3437
3438 set id [$mktagtop.sha1 get]
3439 set tag [$mktagtop.tag get]
3440 if {$tag == {}} {
3441 error_popup "No tag name specified"
3442 return
3443 }
3444 if {[info exists tagids($tag)]} {
3445 error_popup "Tag \"$tag\" already exists"
3446 return
3447 }
3448 if {[catch {
3449 set out [exec hg tag $tag $id]
3450 } err]} {
3451 error_popup "Error creating tag: $err"
3452 return
3453 }
3454
3455 set tagids($tag) $id
3456 lappend idtags($id) $tag
3457 redrawtags $id
3458 }
3459
3460 proc redrawtags {id} {
3461 global canv linehtag idline idpos selectedline
3462
3463 if {![info exists idline($id)]} return
3464 $canv delete tag.$id
3465 set xt [eval drawtags $id $idpos($id)]
3466 $canv coords $linehtag($idline($id)) $xt [lindex $idpos($id) 2]
3467 if {[info exists selectedline] && $selectedline == $idline($id)} {
3468 selectline $selectedline 0
3469 }
3470 }
3471
3472 proc mktagcan {} {
3473 global mktagtop
3474
3475 catch {destroy $mktagtop}
3476 unset mktagtop
3477 }
3478
3479 proc mktaggo {} {
3480 domktag
3481 mktagcan
3482 }
3483
3484 proc writecommit {} {
3485 global rowmenuid wrcomtop commitinfo wrcomcmd
3486
3487 set top .writecommit
3488 set wrcomtop $top
3489 catch {destroy $top}
3490 toplevel $top
3491 label $top.title -text "Write commit to file"
3492 grid $top.title - -pady 10
3493 label $top.id -text "ID:"
3494 entry $top.sha1 -width 40 -relief flat
3495 $top.sha1 insert 0 $rowmenuid
3496 $top.sha1 conf -state readonly
3497 grid $top.id $top.sha1 -sticky w
3498 entry $top.head -width 60 -relief flat
3499 $top.head insert 0 [lindex $commitinfo($rowmenuid) 0]
3500 $top.head conf -state readonly
3501 grid x $top.head -sticky w
3502 label $top.clab -text "Command:"
3503 entry $top.cmd -width 60 -textvariable wrcomcmd
3504 grid $top.clab $top.cmd -sticky w -pady 10
3505 label $top.flab -text "Output file:"
3506 entry $top.fname -width 60
3507 $top.fname insert 0 [file normalize "commit-[string range $rowmenuid 0 6]"]
3508 grid $top.flab $top.fname -sticky w
3509 frame $top.buts
3510 button $top.buts.gen -text "Write" -command wrcomgo
3511 button $top.buts.can -text "Cancel" -command wrcomcan
3512 grid $top.buts.gen $top.buts.can
3513 grid columnconfigure $top.buts 0 -weight 1 -uniform a
3514 grid columnconfigure $top.buts 1 -weight 1 -uniform a
3515 grid $top.buts - -pady 10 -sticky ew
3516 focus $top.fname
3517 }
3518
3519 proc wrcomgo {} {
3520 global wrcomtop
3521
3522 set id [$wrcomtop.sha1 get]
3523 set cmd "echo $id | [$wrcomtop.cmd get]"
3524 set fname [$wrcomtop.fname get]
3525 if {[catch {exec sh -c $cmd >$fname &} err]} {
3526 error_popup "Error writing commit: $err"
3527 }
3528 catch {destroy $wrcomtop}
3529 unset wrcomtop
3530 }
3531
3532 proc wrcomcan {} {
3533 global wrcomtop
3534
3535 catch {destroy $wrcomtop}
3536 unset wrcomtop
3537 }
3538
3539 proc listrefs {id} {
3540 global idtags idheads idotherrefs
3541
3542 set x {}
3543 if {[info exists idtags($id)]} {
3544 set x $idtags($id)
3545 }
3546 set y {}
3547 if {[info exists idheads($id)]} {
3548 set y $idheads($id)
3549 }
3550 set z {}
3551 if {[info exists idotherrefs($id)]} {
3552 set z $idotherrefs($id)
3553 }
3554 return [list $x $y $z]
3555 }
3556
3557 proc rereadrefs {} {
3558 global idtags idheads idotherrefs
3559 global tagids headids otherrefids
3560
3561 set refids [concat [array names idtags] \
3562 [array names idheads] [array names idotherrefs]]
3563 foreach id $refids {
3564 if {![info exists ref($id)]} {
3565 set ref($id) [listrefs $id]
3566 }
3567 }
3568 foreach v {tagids idtags headids idheads otherrefids idotherrefs} {
3569 catch {unset $v}
3570 }
3571 readrefs
3572 set refids [lsort -unique [concat $refids [array names idtags] \
3573 [array names idheads] [array names idotherrefs]]]
3574 foreach id $refids {
3575 set v [listrefs $id]
3576 if {![info exists ref($id)] || $ref($id) != $v} {
3577 redrawtags $id
3578 }
3579 }
3580 }
3581
3582 proc showtag {tag isnew} {
3583 global ctext cflist tagcontents tagids linknum
3584
3585 if {$isnew} {
3586 addtohistory [list showtag $tag 0]
3587 }
3588 $ctext conf -state normal
3589 $ctext delete 0.0 end
3590 set linknum 0
3591 if {[info exists tagcontents($tag)]} {
3592 set text $tagcontents($tag)
3593 } else {
3594 set text "Tag: $tag\nId: $tagids($tag)"
3595 }
3596 appendwithlinks $text
3597 $ctext conf -state disabled
3598 $cflist delete 0 end
3599 }
3600
1405 proc doquit {} {
3601 proc doquit {} {
1406 global stopped
3602 global stopped
1407 set stopped 100
3603 set stopped 100
1408 destroy .
3604 destroy .
1409 }
3605 }
1410
3606
1411 # defaults...
3607 # defaults...
1412 set datemode 0
3608 set datemode 0
1413 set boldnames 0
3609 set boldnames 0
1414 set diffopts "-U 5 -p"
3610 set diffopts "-U 5 -p"
3611 set wrcomcmd "hg git-diff-tree --stdin -p --pretty"
1415
3612
1416 set mainfont {Helvetica 9}
3613 set mainfont {Helvetica 9}
1417 set textfont {Courier 9}
3614 set textfont {Courier 9}
3615 set findmergefiles 0
3616 set gaudydiff 0
3617 set maxgraphpct 50
3618 set maxwidth 16
1418
3619
1419 set colors {green red blue magenta darkgrey brown orange}
3620 set colors {green red blue magenta darkgrey brown orange}
1420 set colorbycommitter false
1421
3621
1422 catch {source ~/.gitk}
3622 catch {source ~/.gitk}
1423
3623
1424 set namefont $mainfont
3624 set namefont $mainfont
1425 if {$boldnames} {
3625 if {$boldnames} {
1426 lappend namefont bold
3626 lappend namefont bold
1427 }
3627 }
1428
3628
1429 set revtreeargs {}
3629 set revtreeargs {}
1430 foreach arg $argv {
3630 foreach arg $argv {
1431 switch -regexp -- $arg {
3631 switch -regexp -- $arg {
1432 "^$" { }
3632 "^$" { }
1433 "^-b" { set boldnames 1 }
3633 "^-b" { set boldnames 1 }
1434 "^-c" { set colorbycommitter 1 }
1435 "^-d" { set datemode 1 }
3634 "^-d" { set datemode 1 }
1436 default {
3635 default {
1437 lappend revtreeargs $arg
3636 lappend revtreeargs $arg
1438 }
3637 }
1439 }
3638 }
1440 }
3639 }
1441
3640
3641 set history {}
3642 set historyindex 0
3643
1442 set stopped 0
3644 set stopped 0
1443 set redisplaying 0
3645 set redisplaying 0
1444 set stuffsaved 0
3646 set stuffsaved 0
3647 set patchnum 0
1445 setcoords
3648 setcoords
1446 makewindow
3649 makewindow
1447 readrefs
3650 readrefs
1448 readfullcommits $revtreeargs
3651 getcommits $revtreeargs
General Comments 0
You need to be logged in to leave comments. Login now