##// 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 1 #!/bin/sh
2 2 # Tcl ignores the next line -*- tcl -*- \
3 3 exec wish "$0" -- "${1+$@}"
4 4
5 5 # Copyright (C) 2005 Paul Mackerras. All rights reserved.
6 6 # This program is free software; it may be used, copied, modified
7 7 # and distributed under the terms of the GNU General Public Licence,
8 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} {
13 global commits commfd phase canv mainfont curcommit allcommitstate
14 if {$rargs == {}} {
15 set rargs HEAD
19 proc getcommits {rargs} {
20 global commits commfd phase canv mainfont env
21 global startmsecs nextupdate ncmupdate
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 30 set commits {}
18 set curcommit {}
19 set allcommitstate none
20 31 set phase getcommits
21 if [catch {set commfd [open "|hgit rev-list -c $rargs" r]} err] {
22 puts stderr "Error executing hgit rev-list: $err"
32 set startmsecs [clock clicks -milliseconds]
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 49 exit 1
24 50 }
25 fconfigure $commfd -blocking 0
26 fileevent $commfd readable "getallcommitline $commfd"
51 set leftover {}
52 fconfigure $commfd -blocking 0 -translation lf
53 fileevent $commfd readable [list getcommitlines $commfd]
27 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 56 -font $mainfont -tags textitems
57 . config -cursor watch
58 settextcursor watch
30 59 }
31 60
32 proc getcommitline {commfd} {
33 global commits parents cdate nparents children nchildren
34 set n [gets $commfd line]
35 if {$n < 0} {
61 proc getcommitlines {commfd} {
62 global commits parents cdate children
63 global commitlisted phase commitinfo nextupdate
64 global stopped redisplaying leftover
65
66 set stuff [read $commfd]
67 if {$stuff == {}} {
36 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 70 fconfigure $commfd -blocking 1
39 71 if {![catch {close $commfd} err]} {
40 after idle readallcommits
72 after idle finishcommits
41 73 return
42 74 }
43 75 if {[string range $err 0 4] == "usage"} {
44 set err "\
45 Gitk: error reading commits: bad arguments to hgit rev-list.\n\
46 (Note: arguments to gitk are passed to hgit rev-list\
47 to allow selection of commits to be displayed.)"
76 set err \
77 {Gitk: error reading commits: bad arguments to git-rev-list.
78 (Note: arguments to gitk are passed to git-rev-list
79 to allow selection of commits to be displayed.)}
48 80 } else {
49 81 set err "Error reading commits: $err"
50 82 }
51 83 error_popup $err
52 84 exit 1
53 85 }
54 if {![regexp {^[0-9a-f]{40}$} $line]} {
55 error_popup "Can't parse hgit rev-tree output: {$line}"
86 set start 0
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 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 {} {
62 global commits
63 foreach id $commits {
64 readcommit $id
146 proc doupdate {reading} {
147 global commfd nextupdate numcommits ncmupdate
148
149 if {$reading} {
150 fileevent $commfd readable {}
151 }
65 152 update
66 }
67 drawgraph
153 set nextupdate [expr {[clock clicks -milliseconds] + 100}]
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} {
71 global commitinfo children nchildren parents nparents cdate
166 proc readcommit {id} {
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 174 set inhdr 1
73 175 set comment {}
74 176 set headline {}
75 177 set auname {}
76 178 set audate {}
77 179 set comname {}
78 180 set comdate {}
79 181 if {![info exists nchildren($id)]} {
80 182 set children($id) {}
81 183 set nchildren($id) 0
82 }
83 set parents($id) {}
84 set nparents($id) 0
184 set ncleft($id) 0
185 }
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 199 foreach line [split $contents "\n"] {
86 200 if {$inhdr} {
87 201 if {$line == {}} {
88 202 set inhdr 0
89 203 } else {
90 204 set tag [lindex $line 0]
91 if {$tag == "parent"} {
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"} {
205 if {$tag == "author"} {
104 206 set x [expr {[llength $line] - 2}]
105 207 set audate [lindex $line $x]
106 208 set auname [lrange $line 1 [expr {$x - 1}]]
107 209 } elseif {$tag == "committer"} {
108 210 set x [expr {[llength $line] - 2}]
109 211 set comdate [lindex $line $x]
110 212 set comname [lrange $line 1 [expr {$x - 1}]]
111 213 }
112 214 }
113 215 } else {
114 216 if {$comment == {}} {
115 set headline $line
217 set headline [string trim $line]
116 218 } else {
117 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 226 append comment $line
120 227 }
121 228 }
122 229 if {$audate != {}} {
123 230 set audate [clock format $audate -format "%Y-%m-%d %H:%M:%S"]
124 231 }
125 232 if {$comdate != {}} {
126 233 set cdate($id) $comdate
127 234 set comdate [clock format $comdate -format "%Y-%m-%d %H:%M:%S"]
128 235 }
129 236 set commitinfo($id) [list $headline $auname $audate \
130 237 $comname $comdate $comment]
131 238 }
132 239
133 proc getallcommitline {commfd} {
134 global commits allcommitstate curcommit curcommitid
135 set n [gets $commfd line]
136 set s "\n"
137 if {$n < 0} {
138 if {![eof $commfd]} return
139 # this works around what is apparently a bug in Tcl...
140 fconfigure $commfd -blocking 1
141 if {![catch {close $commfd} err]} {
142 if {$allcommitstate == "indent"} {
143 readonecommit $curcommitid $curcommit
144 }
145 after idle drawgraph
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
240 proc readrefs {} {
241 global tagids idtags headids idheads tagcontents
242
243 set tags [exec hg tags]
244 set lines [split $tags '\n']
245 foreach f $lines {
246 set f [regexp -all -inline {\S+} $f]
247 set direct [lindex $f 0]
248 set full [lindex $f 1]
249 set sha [split $full ':']
250 set tag [lindex $sha 1]
251 lappend tagids($direct) $tag
252 lappend idtags($tag) $direct
175 253 }
176 254 }
177 255
178 proc getcommits {rargs} {
179 global commits commfd phase canv mainfont
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 }
256 proc readotherrefs {base dname excl} {
257 global otherrefids idotherrefs
195 258
196 proc readcommit {id} {
197 global commitinfo children nchildren parents nparents cdate
198 set inhdr 1
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 {
259 set git [gitdir]
260 set files [glob -nocomplain -types f [file join $git $base *]]
261 foreach f $files {
219 262 catch {
220 263 set fd [open $f r]
221 set line [read $fd]
264 set line [read $fd 40]
222 265 if {[regexp {^[0-9a-f]{40}} $line id]} {
223 set contents [split [exec hgit cat-file tag $id] "\n"]
224 set obj {}
225 set type {}
226 set tag {}
227 foreach l $contents {
228 if {$l == {}} break
229 switch -- [lindex $l 0] {
230 "object" {set obj [lindex $l 1]}
231 "type" {set type [lindex $l 1]}
232 "tag" {set tag [string range $l 4 end]}
233 }
234 }
235 if {$obj != {} && $type == "commit" && $tag != {}} {
236 set tagids($tag) $obj
237 lappend idtags($obj) $tag
238 }
239 }
240 }
266 set name "$dname[file tail $f]"
267 set otherrefids($name) $id
268 lappend idotherrefs($id) $name
269 }
270 close $fd
271 }
272 }
273 set dirs [glob -nocomplain -types d [file join $git $base *]]
274 foreach d $dirs {
275 set dir [file tail $d]
276 if {[lsearch -exact $excl $dir] >= 0} continue
277 readotherrefs [file join $base $dir] "$dname$dir/" {}
241 278 }
242 279 }
243 280
244 281 proc error_popup msg {
245 282 set w .error
246 283 toplevel $w
247 284 wm transient $w .
248 285 message $w.m -text $msg -justify center -aspect 400
249 286 pack $w.m -side top -fill x -padx 20 -pady 20
250 287 button $w.ok -text OK -command "destroy $w"
251 288 pack $w.ok -side bottom -fill x
252 289 bind $w <Visibility> "grab $w; focus $w"
253 290 tkwait window $w
254 291 }
255 292
256 293 proc makewindow {} {
257 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 296 global entries sha1entry sha1string sha1but
297 global maincursor textcursor curtextcursor
298 global rowctxmenu gaudydiff mergemax
260 299
261 300 menu .bar
262 301 .bar add cascade -label "File" -menu .bar.file
263 302 menu .bar.file
303 .bar.file add command -label "Reread references" -command rereadrefs
264 304 .bar.file add command -label "Quit" -command doquit
265 305 menu .bar.help
266 306 .bar add cascade -label "Help" -menu .bar.help
267 307 .bar.help add command -label "About gitk" -command about
268 308 . configure -menu .bar
269 309
270 310 if {![info exists geometry(canv1)]} {
271 311 set geometry(canv1) [expr 45 * $charspc]
272 312 set geometry(canv2) [expr 30 * $charspc]
273 313 set geometry(canv3) [expr 15 * $charspc]
274 314 set geometry(canvh) [expr 25 * $linespc + 4]
275 315 set geometry(ctextw) 80
276 316 set geometry(ctexth) 30
277 317 set geometry(cflistw) 30
278 318 }
279 319 panedwindow .ctop -orient vertical
280 320 if {[info exists geometry(width)]} {
281 321 .ctop conf -width $geometry(width) -height $geometry(height)
282 322 set texth [expr {$geometry(height) - $geometry(canvh) - 56}]
283 323 set geometry(ctexth) [expr {($texth - 8) /
284 324 [font metrics $textfont -linespace]}]
285 325 }
286 326 frame .ctop.top
287 327 frame .ctop.top.bar
288 328 pack .ctop.top.bar -side bottom -fill x
289 329 set cscroll .ctop.top.csb
290 330 scrollbar $cscroll -command {allcanvs yview} -highlightthickness 0
291 331 pack $cscroll -side right -fill y
292 332 panedwindow .ctop.top.clist -orient horizontal -sashpad 0 -handlesize 4
293 333 pack .ctop.top.clist -side top -fill both -expand 1
294 334 .ctop add .ctop.top
295 335 set canv .ctop.top.clist.canv
296 336 canvas $canv -height $geometry(canvh) -width $geometry(canv1) \
297 337 -bg white -bd 0 \
298 338 -yscrollincr $linespc -yscrollcommand "$cscroll set"
299 339 .ctop.top.clist add $canv
300 340 set canv2 .ctop.top.clist.canv2
301 341 canvas $canv2 -height $geometry(canvh) -width $geometry(canv2) \
302 342 -bg white -bd 0 -yscrollincr $linespc
303 343 .ctop.top.clist add $canv2
304 344 set canv3 .ctop.top.clist.canv3
305 345 canvas $canv3 -height $geometry(canvh) -width $geometry(canv3) \
306 346 -bg white -bd 0 -yscrollincr $linespc
307 347 .ctop.top.clist add $canv3
308 348 bind .ctop.top.clist <Configure> {resizeclistpanes %W %w}
309 349
310 350 set sha1entry .ctop.top.bar.sha1
311 351 set entries $sha1entry
312 352 set sha1but .ctop.top.bar.sha1label
313 353 button $sha1but -text "SHA1 ID: " -state disabled -relief flat \
314 354 -command gotocommit -width 8
315 355 $sha1but conf -disabledforeground [$sha1but cget -foreground]
316 356 pack .ctop.top.bar.sha1label -side left
317 357 entry $sha1entry -width 40 -font $textfont -textvariable sha1string
318 358 trace add variable sha1string write sha1change
319 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 384 button .ctop.top.bar.findbut -text "Find" -command dofind
321 385 pack .ctop.top.bar.findbut -side left
322 386 set findstring {}
323 387 set fstring .ctop.top.bar.findstring
324 388 lappend entries $fstring
325 389 entry $fstring -width 30 -font $textfont -textvariable findstring
326 390 pack $fstring -side left -expand 1 -fill x
327 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 394 set findloc "All fields"
330 395 tk_optionMenu .ctop.top.bar.findloc findloc "All fields" Headline \
331 Comments Author Committer
396 Comments Author Committer Files Pickaxe
332 397 pack .ctop.top.bar.findloc -side right
333 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 402 panedwindow .ctop.cdet -orient horizontal
336 403 .ctop add .ctop.cdet
337 404 frame .ctop.cdet.left
338 405 set ctext .ctop.cdet.left.ctext
339 406 text $ctext -bg white -state disabled -font $textfont \
340 407 -width $geometry(ctextw) -height $geometry(ctexth) \
341 -yscrollcommand ".ctop.cdet.left.sb set"
408 -yscrollcommand ".ctop.cdet.left.sb set" -wrap none
342 409 scrollbar .ctop.cdet.left.sb -command "$ctext yview"
343 410 pack .ctop.cdet.left.sb -side right -fill y
344 411 pack $ctext -side left -fill both -expand 1
345 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 416 $ctext tag conf hunksep -back blue -fore white
349 417 $ctext tag conf d0 -back "#ff8080"
350 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 432 $ctext tag conf found -back yellow
433 }
352 434
353 435 frame .ctop.cdet.right
354 436 set cflist .ctop.cdet.right.cfiles
355 437 listbox $cflist -bg white -selectmode extended -width $geometry(cflistw) \
356 438 -yscrollcommand ".ctop.cdet.right.sb set"
357 439 scrollbar .ctop.cdet.right.sb -command "$cflist yview"
358 440 pack .ctop.cdet.right.sb -side right -fill y
359 441 pack $cflist -side left -fill both -expand 1
360 442 .ctop.cdet add .ctop.cdet.right
361 443 bind .ctop.cdet <Configure> {resizecdetpanes %W %w}
362 444
363 445 pack .ctop -side top -fill both -expand 1
364 446
365 bindall <1> {selcanvline %x %y}
366 bindall <B1-Motion> {selcanvline %x %y}
447 bindall <1> {selcanvline %W %x %y}
448 #bindall <B1-Motion> {selcanvline %W %x %y}
367 449 bindall <ButtonRelease-4> "allcanvs yview scroll -5 units"
368 450 bindall <ButtonRelease-5> "allcanvs yview scroll 5 units"
369 451 bindall <2> "allcanvs scan mark 0 %y"
370 452 bindall <B2-Motion> "allcanvs scan dragto 0 %y"
371 453 bind . <Key-Up> "selnextline -1"
372 454 bind . <Key-Down> "selnextline 1"
373 455 bind . <Key-Prior> "allcanvs yview scroll -1 pages"
374 456 bind . <Key-Next> "allcanvs yview scroll 1 pages"
375 457 bindkey <Key-Delete> "$ctext yview scroll -1 pages"
376 458 bindkey <Key-BackSpace> "$ctext yview scroll -1 pages"
377 459 bindkey <Key-space> "$ctext yview scroll 1 pages"
378 460 bindkey p "selnextline -1"
379 461 bindkey n "selnextline 1"
380 462 bindkey b "$ctext yview scroll -1 pages"
381 463 bindkey d "$ctext yview scroll 18 units"
382 464 bindkey u "$ctext yview scroll -18 units"
383 bindkey / findnext
465 bindkey / {findnext 1}
466 bindkey <Key-Return> {findnext 0}
384 467 bindkey ? findprev
385 468 bindkey f nextfile
386 469 bind . <Control-q> doquit
387 470 bind . <Control-f> dofind
388 bind . <Control-g> findnext
471 bind . <Control-g> {findnext 0}
389 472 bind . <Control-r> findprev
390 473 bind . <Control-equal> {incrfont 1}
391 474 bind . <Control-KP_Add> {incrfont 1}
392 475 bind . <Control-minus> {incrfont -1}
393 476 bind . <Control-KP_Subtract> {incrfont -1}
394 477 bind $cflist <<ListboxSelect>> listboxsel
395 478 bind . <Destroy> {savestuff %W}
396 479 bind . <Button-1> "click %W"
397 480 bind $fstring <Key-Return> dofind
398 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 499 # when we make a key binding for the toplevel, make sure
402 500 # it doesn't get triggered when that key is pressed in the
403 501 # find string entry widget.
404 502 proc bindkey {ev script} {
405 503 global entries
406 504 bind . $ev $script
407 505 set escript [bind Entry $ev]
408 506 if {$escript == {}} {
409 507 set escript [bind Entry <Key>]
410 508 }
411 509 foreach e $entries {
412 510 bind $e $ev "$escript; break"
413 511 }
414 512 }
415 513
416 514 # set the focus back to the toplevel for any click outside
417 515 # the entry widgets
418 516 proc click {w} {
419 517 global entries
420 518 foreach e $entries {
421 519 if {$w == $e} return
422 520 }
423 521 focus .
424 522 }
425 523
426 524 proc savestuff {w} {
427 525 global canv canv2 canv3 ctext cflist mainfont textfont
428 global stuffsaved
526 global stuffsaved findmergefiles gaudydiff maxgraphpct
527 global maxwidth
528
429 529 if {$stuffsaved} return
430 530 if {![winfo viewable .]} return
431 531 catch {
432 532 set f [open "~/.gitk-new" w]
433 puts $f "set mainfont {$mainfont}"
434 puts $f "set textfont {$textfont}"
533 puts $f [list set mainfont $mainfont]
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 539 puts $f "set geometry(width) [winfo width .ctop]"
436 540 puts $f "set geometry(height) [winfo height .ctop]"
437 541 puts $f "set geometry(canv1) [expr [winfo width $canv]-2]"
438 542 puts $f "set geometry(canv2) [expr [winfo width $canv2]-2]"
439 543 puts $f "set geometry(canv3) [expr [winfo width $canv3]-2]"
440 544 puts $f "set geometry(canvh) [expr [winfo height $canv]-2]"
441 545 set wid [expr {([winfo width $ctext] - 8) \
442 546 / [font measure $textfont "0"]}]
443 547 puts $f "set geometry(ctextw) $wid"
444 548 set wid [expr {([winfo width $cflist] - 11) \
445 549 / [font measure [$cflist cget -font] "0"]}]
446 550 puts $f "set geometry(cflistw) $wid"
447 551 close $f
448 552 file rename -force "~/.gitk-new" "~/.gitk"
449 553 }
450 554 set stuffsaved 1
451 555 }
452 556
453 557 proc resizeclistpanes {win w} {
454 558 global oldwidth
455 559 if [info exists oldwidth($win)] {
456 560 set s0 [$win sash coord 0]
457 561 set s1 [$win sash coord 1]
458 562 if {$w < 60} {
459 563 set sash0 [expr {int($w/2 - 2)}]
460 564 set sash1 [expr {int($w*5/6 - 2)}]
461 565 } else {
462 566 set factor [expr {1.0 * $w / $oldwidth($win)}]
463 567 set sash0 [expr {int($factor * [lindex $s0 0])}]
464 568 set sash1 [expr {int($factor * [lindex $s1 0])}]
465 569 if {$sash0 < 30} {
466 570 set sash0 30
467 571 }
468 572 if {$sash1 < $sash0 + 20} {
469 573 set sash1 [expr $sash0 + 20]
470 574 }
471 575 if {$sash1 > $w - 10} {
472 576 set sash1 [expr $w - 10]
473 577 if {$sash0 > $sash1 - 20} {
474 578 set sash0 [expr $sash1 - 20]
475 579 }
476 580 }
477 581 }
478 582 $win sash place 0 $sash0 [lindex $s0 1]
479 583 $win sash place 1 $sash1 [lindex $s1 1]
480 584 }
481 585 set oldwidth($win) $w
482 586 }
483 587
484 588 proc resizecdetpanes {win w} {
485 589 global oldwidth
486 590 if [info exists oldwidth($win)] {
487 591 set s0 [$win sash coord 0]
488 592 if {$w < 60} {
489 593 set sash0 [expr {int($w*3/4 - 2)}]
490 594 } else {
491 595 set factor [expr {1.0 * $w / $oldwidth($win)}]
492 596 set sash0 [expr {int($factor * [lindex $s0 0])}]
493 597 if {$sash0 < 45} {
494 598 set sash0 45
495 599 }
496 600 if {$sash0 > $w - 15} {
497 601 set sash0 [expr $w - 15]
498 602 }
499 603 }
500 604 $win sash place 0 $sash0 [lindex $s0 1]
501 605 }
502 606 set oldwidth($win) $w
503 607 }
504 608
505 609 proc allcanvs args {
506 610 global canv canv2 canv3
507 611 eval $canv $args
508 612 eval $canv2 $args
509 613 eval $canv3 $args
510 614 }
511 615
512 616 proc bindall {event action} {
513 617 global canv canv2 canv3
514 618 bind $canv $event $action
515 619 bind $canv2 $event $action
516 620 bind $canv3 $event $action
517 621 }
518 622
519 623 proc about {} {
520 624 set w .about
521 625 if {[winfo exists $w]} {
522 626 raise $w
523 627 return
524 628 }
525 629 toplevel $w
526 630 wm title $w "About gitk"
527 631 message $w.m -text {
528 Gitk version 1.1
632 Gitk version 1.2
529 633
530 634 Copyright οΏ½ 2005 Paul Mackerras
531 635
532 Use and redistribute under the terms of the GNU General Public License
533
534 (CVS $Revision: 1.20 $)} \
636 Use and redistribute under the terms of the GNU General Public License} \
535 637 -justify center -aspect 400
536 638 pack $w.m -side top -fill x -padx 20 -pady 20
537 639 button $w.ok -text Close -command "destroy $w"
538 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 643 proc assigncolor {id} {
561 644 global commitinfo colormap commcolors colors nextcolor
562 global colorbycommitter
563 645 global parents nparents children nchildren
646 global cornercrossings crossings
647
564 648 if [info exists colormap($id)] return
565 649 set ncolors [llength $colors]
566 if {$colorbycommitter} {
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} {
650 if {$nparents($id) <= 1 && $nchildren($id) == 1} {
580 651 set child [lindex $children($id) 0]
581 652 if {[info exists colormap($child)]
582 653 && $nparents($child) == 1} {
583 654 set colormap($id) $colormap($child)
584 655 return
585 656 }
586 657 }
587 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 686 foreach child $children($id) {
589 687 if {[info exists colormap($child)]
590 688 && [lsearch -exact $badcolors $colormap($child)] < 0} {
591 689 lappend badcolors $colormap($child)
592 690 }
593 691 if {[info exists parents($child)]} {
594 692 foreach p $parents($child) {
595 693 if {[info exists colormap($p)]
596 694 && [lsearch -exact $badcolors $colormap($p)] < 0} {
597 695 lappend badcolors $colormap($p)
598 696 }
599 697 }
600 698 }
601 699 }
602 700 if {[llength $badcolors] >= $ncolors} {
603 set badcolors {}
701 set badcolors $origbad
702 }
604 703 }
605 704 for {set i 0} {$i <= $ncolors} {incr i} {
606 705 set c [lindex $colors $nextcolor]
607 706 if {[incr nextcolor] >= $ncolors} {
608 707 set nextcolor 0
609 708 }
610 709 if {[lsearch -exact $badcolors $c]} break
611 710 }
612 711 set colormap($id) $c
613 712 }
614 }
615 713
616 proc drawgraph {} {
617 global parents children nparents nchildren commits
618 global canv canv2 canv3 mainfont namefont canvx0 canvy0 canvy linespc
619 global datemode cdate
620 global lineid linehtag linentag linedtag commitinfo
621 global nextcolor colormap numcommits
622 global stopped phase redisplaying selectedline idtags idline
714 proc initgraph {} {
715 global canvy canvy0 lineno numcommits nextcolor linespc
716 global mainline mainlinearrow sidelines
717 global nchildren ncleft
718 global displist nhyperspace
623 719
624 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 728 foreach id [array names nchildren] {
627 if {$nchildren($id) == 0} {
628 lappend start $id
629 }
630 729 set ncleft($id) $nchildren($id)
631 if {![info exists nparents($id)]} {
632 set nparents($id) 0
633 }
634 }
635 if {$start == {}} {
636 error_popup "Gitk: ERROR: No starting commits found"
637 exit 1
730 }
731 set displist {}
732 set nhyperspace 0
733 }
734
735 proc bindline {t id} {
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
641 foreach id $start {
642 assigncolor $id
643 }
644 set todo $start
645 set level [expr [llength $todo] - 1]
646 set y2 $canvy0
647 set nullentry -1
648 set lineno -1
649 set numcommits 0
650 set phase drawgraph
651 set lthickness [expr {($linespc / 9) + 1}]
652 while 1 {
653 set canvy $y2
654 allcanvs conf -scrollregion \
655 [list 0 0 0 [expr $canvy + 0.5 * $linespc + 2]]
656 update
657 if {$stopped} break
744 proc drawlines {id xtra} {
745 global mainline mainlinearrow sidelines lthickness colormap canv
746
747 $canv delete lines.$id
748 if {[info exists mainline($id)]} {
749 set t [$canv create line $mainline($id) \
750 -width [expr {($xtra + 1) * $lthickness}] \
751 -fill $colormap($id) -tags lines.$id \
752 -arrow $mainlinearrow($id)]
753 $canv lower $t
754 bindline $t $id
755 }
756 if {[info exists sidelines($id)]} {
757 foreach ls $sidelines($id) {
758 set coords [lindex $ls 0]
759 set thick [lindex $ls 1]
760 set arrow [lindex $ls 2]
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 781 incr numcommits
659 782 incr lineno
660 set nlines [llength $todo]
661 set id [lindex $todo $level]
783 set id [lindex $displist $level]
784 set lastuse($id) $lineno
662 785 set lineid($lineno) $id
663 786 set idline($id) $lineno
664 set actualparents {}
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 }
787 set ofill [expr {[info exists commitlisted($id)]? "blue": "white"}]
679 788 if {![info exists commitinfo($id)]} {
680 789 readcommit $id
681 790 if {![info exists commitinfo($id)]} {
682 791 set commitinfo($id) {"No commit information available"}
683 }
684 }
685 set x [expr $canvx0 + $level * $linespc]
686 set y2 [expr $canvy + $linespc]
687 if {[info exists linestarty($level)] && $linestarty($level) < $canvy} {
688 set t [$canv create line $x $linestarty($level) $x $canvy \
689 -width $lthickness -fill $colormap($id)]
690 $canv lower $t
691 }
692 set linestarty($level) $canvy
792 set nparents($id) 0
793 }
794 }
795 assigncolor $id
796 set currentparents {}
797 set dupparents {}
798 if {[info exists commitlisted($id)] && [info exists parents($id)]} {
799 foreach p $parents($id) {
800 if {[lsearch -exact $currentparents $p] < 0} {
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 820 set orad [expr {$linespc / 3}]
694 set t [$canv create oval [expr $x - $orad] [expr $canvy - $orad] \
695 [expr $x + $orad - 1] [expr $canvy + $orad - 1] \
821 set t [$canv create oval [expr $x - $orad] [expr $y1 - $orad] \
822 [expr $x + $orad - 1] [expr $y1 + $orad - 1] \
696 823 -fill $ofill -outline black -width 1]
697 824 $canv raise $t
698 set xt [expr $canvx0 + $nlines * $linespc]
699 if {$nparents($id) > 2} {
700 set xt [expr {$xt + ($nparents($id) - 2) * $linespc}]
701 }
702 if {[info exists idtags($id)] && $idtags($id) != {}} {
703 set delta [expr {int(0.5 * ($linespc - $lthickness))}]
704 set yt [expr $canvy - 0.5 * $linespc]
705 set yb [expr $yt + $linespc - 1]
706 set xvals {}
707 set wvals {}
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 }
825 $canv bind $t <1> {selcanvline {} %x %y}
826 set xt [xcoord [llength $displist] $level $lineno]
827 if {[llength $currentparents] > 2} {
828 set xt [expr {$xt + ([llength $currentparents] - 2) * $linespc}]
829 }
830 set rowtextx($lineno) $xt
831 set idpos($id) [list $x $xt $y1]
832 if {[info exists idtags($id)] || [info exists idheads($id)]
833 || [info exists idotherrefs($id)]} {
834 set xt [drawtags $id $x $xt $y1]
726 835 }
727 836 set headline [lindex $commitinfo($id) 0]
728 837 set name [lindex $commitinfo($id) 1]
729 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 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 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 845 -text $date -font $mainfont]
736 if {!$datemode && [llength $actualparents] == 1} {
737 set p [lindex $actualparents 0]
738 if {$ncleft($p) == 0 && [lsearch -exact $todo $p] < 0} {
739 assigncolor $p
740 set todo [lreplace $todo $level $level $p]
741 continue
846
847 set olddlevel $level
848 set olddisplist $displist
849 set oldnlines [llength $displist]
850 }
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
746 set oldlevel $level
747 set lines {}
748 for {set i 0} {$i < $nlines} {incr i} {
749 if {[lindex $todo $i] == {}} continue
750 if {[info exists linestarty($i)]} {
751 set oldstarty($i) $linestarty($i)
752 unset linestarty($i)
753 }
754 if {$i != $level} {
755 lappend lines [list $i [lindex $todo $i]]
756 }
757 }
758 if {$nullentry >= 0} {
759 set todo [lreplace $todo $nullentry $nullentry]
760 if {$nullentry < $level} {
761 incr level -1
1069 set lastuse($id) $lineno
1070
1071 # see if we need to make any lines jump off into hyperspace
1072 set displ [llength $displist]
1073 if {$displ > $maxwidth} {
1074 set ages {}
1075 foreach x $displist {
1076 lappend ages [list $lastuse($x) $x]
1077 }
1078 set ages [lsort -integer -index 0 $ages]
1079 set k 0
1080 while {$displ > $maxwidth} {
1081 set use [lindex $ages $k 0]
1082 set victim [lindex $ages $k 1]
1083 if {$use >= $lineno - 5} break
1084 incr k
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 1346 set todo [lreplace $todo $level $level]
766 if {$nullentry > $level} {
767 incr nullentry -1
768 }
769 1347 set i $level
770 foreach p $actualparents {
1348 set n 0
1349 foreach p $olds {
1350 incr ncleft($p) -1
771 1351 set k [lsearch -exact $todo $p]
772 1352 if {$k < 0} {
773 assigncolor $p
774 1353 set todo [linsert $todo $i $p]
775 if {$nullentry >= $i} {
776 incr nullentry
777 }
1354 set onscreen($p) 0
778 1355 incr i
779 }
780 lappend lines [list $oldlevel $p]
781 }
1356 incr n
1357 }
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 1369 # choose which one to do next time around
784 1370 set todol [llength $todo]
785 1371 set level -1
786 1372 set latest {}
787 1373 for {set k $todol} {[incr k -1] >= 0} {} {
788 1374 set p [lindex $todo $k]
789 if {$p == {}} continue
790 1375 if {$ncleft($p) == 0} {
791 1376 if {$datemode} {
1377 if {![info exists commitinfo($p)]} {
1378 if {$noread} {
1379 return {}
1380 }
1381 readcommit $p
1382 }
792 1383 if {$latest == {} || $cdate($p) > $latest} {
793 1384 set level $k
794 1385 set latest $cdate($p)
795 1386 }
796 1387 } else {
797 1388 set level $k
798 1389 break
799 1390 }
800 1391 }
801 1392 }
802 1393 if {$level < 0} {
803 1394 if {$todo != {}} {
804 1395 puts "ERROR: none of the pending commits can be done yet:"
805 1396 foreach p $todo {
806 puts " $p"
807 }
808 }
809 break
1397 puts " $p ($ncleft($p))"
1398 }
1399 }
1400 return -1
1401 }
1402
1403 return $level
810 1404 }
811 1405
812 # If we are reducing, put in a null entry
813 if {$todol < $nlines} {
814 if {$nullentry >= 0} {
815 set i $nullentry
816 while {$i < $todol
817 && [lindex $oldtodo $i] == [lindex $todo $i]} {
818 incr i
819 }
820 } else {
821 set i $oldlevel
822 if {$level >= $i} {
823 incr i
824 }
825 }
826 if {$i >= $todol} {
827 set nullentry -1
828 } else {
829 set nullentry $i
830 set todo [linsert $todo $nullentry {}]
831 if {$level >= $i} {
832 incr level
833 }
834 }
835 } else {
836 set nullentry -1
1406 proc drawcommit {id} {
1407 global phase todo nchildren datemode nextupdate
1408 global numcommits ncmupdate displayorder todo onscreen
1409
1410 if {$phase != "incrdraw"} {
1411 set phase incrdraw
1412 set displayorder {}
1413 set todo {}
1414 initgraph
1415 }
1416 if {$nchildren($id) == 0} {
1417 lappend todo $id
1418 set onscreen($id) 0
1419 }
1420 set level [decidenext 1]
1421 if {$level == {} || $id != [lindex $todo $level]} {
1422 return
1423 }
1424 while 1 {
1425 lappend displayorder [lindex $todo $level]
1426 if {[updatetodo $level $datemode]} {
1427 set level [decidenext 1]
1428 if {$level == {}} break
1429 }
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 {
840 set i [lindex $l 0]
841 set dst [lindex $l 1]
842 set j [lsearch -exact $todo $dst]
843 if {$i == $j} {
844 if {[info exists oldstarty($i)]} {
845 set linestarty($i) $oldstarty($i)
846 }
847 continue
848 }
849 set xi [expr {$canvx0 + $i * $linespc}]
850 set xj [expr {$canvx0 + $j * $linespc}]
851 set coords {}
852 if {[info exists oldstarty($i)] && $oldstarty($i) < $canvy} {
853 lappend coords $xi $oldstarty($i)
854 }
855 lappend coords $xi $canvy
856 if {$j < $i - 1} {
857 lappend coords [expr $xj + $linespc] $canvy
858 } elseif {$j > $i + 1} {
859 lappend coords [expr $xj - $linespc] $canvy
860 }
861 lappend coords $xj $y2
862 set t [$canv create line $coords -width $lthickness \
863 -fill $colormap($dst)]
864 $canv lower $t
865 if {![info exists linestarty($j)]} {
866 set linestarty($j) $y2
867 }
868 }
1438 proc finishcommits {} {
1439 global phase
1440 global canv mainfont ctext maincursor textcursor
1441
1442 if {$phase != "incrdraw"} {
1443 $canv delete all
1444 $canv create text 3 3 -anchor nw -text "No commits selected" \
1445 -font $mainfont -tags textitems
1446 set phase {}
1447 } else {
1448 drawrest
1449 }
1450 . config -cursor $maincursor
1451 settextcursor $textcursor
1452 }
1453
1454 # Don't change the text pane cursor if it is currently the hand cursor,
1455 # showing that we are over a sha1 ID link.
1456 proc settextcursor {c} {
1457 global ctext curtextcursor
1458
1459 if {[$ctext cget -cursor] == $curtextcursor} {
1460 $ctext config -cursor $c
1461 }
1462 set curtextcursor $c
1463 }
1464
1465 proc drawgraph {} {
1466 global nextupdate startmsecs ncmupdate
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 1499 set phase {}
1500 set drawmsecs [expr [clock clicks -milliseconds] - $startmsecs]
1501 #puts "overall $drawmsecs ms for $numcommits commits"
871 1502 if {$redisplaying} {
872 1503 if {$stopped == 0 && [info exists selectedline]} {
873 selectline $selectedline
1504 selectline $selectedline 0
874 1505 }
875 1506 if {$stopped == 1} {
876 1507 set stopped 0
877 1508 after idle drawgraph
878 1509 } else {
879 1510 set redisplaying 0
880 1511 }
881 1512 }
882 1513 }
883 1514
884 1515 proc findmatches {f} {
885 1516 global findtype foundstring foundstrlen
886 1517 if {$findtype == "Regexp"} {
887 1518 set matches [regexp -indices -all -inline $foundstring $f]
888 1519 } else {
889 1520 if {$findtype == "IgnCase"} {
890 1521 set str [string tolower $f]
891 1522 } else {
892 1523 set str $f
893 1524 }
894 1525 set matches {}
895 1526 set i 0
896 1527 while {[set j [string first $foundstring $str $i]] >= 0} {
897 1528 lappend matches [list $j [expr $j+$foundstrlen-1]]
898 1529 set i [expr $j + $foundstrlen]
899 1530 }
900 1531 }
901 1532 return $matches
902 1533 }
903 1534
904 1535 proc dofind {} {
905 1536 global findtype findloc findstring markedmatches commitinfo
906 1537 global numcommits lineid linehtag linentag linedtag
907 1538 global mainfont namefont canv canv2 canv3 selectedline
908 global matchinglines foundstring foundstrlen idtags
1539 global matchinglines foundstring foundstrlen
1540
1541 stopfindproc
909 1542 unmarkmatches
910 1543 focus .
911 1544 set matchinglines {}
912 set fldtypes {Headline Author Date Committer CDate Comment}
1545 if {$findloc == "Pickaxe"} {
1546 findpatches
1547 return
1548 }
913 1549 if {$findtype == "IgnCase"} {
914 1550 set foundstring [string tolower $findstring]
915 1551 } else {
916 1552 set foundstring $findstring
917 1553 }
918 1554 set foundstrlen [string length $findstring]
919 1555 if {$foundstrlen == 0} return
1556 if {$findloc == "Files"} {
1557 findfiles
1558 return
1559 }
920 1560 if {![info exists selectedline]} {
921 1561 set oldsel -1
922 1562 } else {
923 1563 set oldsel $selectedline
924 1564 }
925 1565 set didsel 0
1566 set fldtypes {Headline Author Date Committer CDate Comment}
926 1567 for {set l 0} {$l < $numcommits} {incr l} {
927 1568 set id $lineid($l)
928 1569 set info $commitinfo($id)
929 1570 set doesmatch 0
930 1571 foreach f $info ty $fldtypes {
931 1572 if {$findloc != "All fields" && $findloc != $ty} {
932 1573 continue
933 1574 }
934 1575 set matches [findmatches $f]
935 1576 if {$matches == {}} continue
936 1577 set doesmatch 1
937 1578 if {$ty == "Headline"} {
938 1579 markmatches $canv $l $f $linehtag($l) $matches $mainfont
939 1580 } elseif {$ty == "Author"} {
940 1581 markmatches $canv2 $l $f $linentag($l) $matches $namefont
941 1582 } elseif {$ty == "Date"} {
942 1583 markmatches $canv3 $l $f $linedtag($l) $matches $mainfont
943 1584 }
944 1585 }
945 1586 if {$doesmatch} {
946 1587 lappend matchinglines $l
947 1588 if {!$didsel && $l > $oldsel} {
948 1589 findselectline $l
949 1590 set didsel 1
950 1591 }
951 1592 }
952 1593 }
953 1594 if {$matchinglines == {}} {
954 1595 bell
955 1596 } elseif {!$didsel} {
956 1597 findselectline [lindex $matchinglines 0]
957 1598 }
958 1599 }
959 1600
960 1601 proc findselectline {l} {
961 1602 global findloc commentend ctext
962 selectline $l
1603 selectline $l 1
963 1604 if {$findloc == "All fields" || $findloc == "Comments"} {
964 1605 # highlight the matches in the comments
965 1606 set f [$ctext get 1.0 $commentend]
966 1607 set matches [findmatches $f]
967 1608 foreach match $matches {
968 1609 set start [lindex $match 0]
969 1610 set end [expr [lindex $match 1] + 1]
970 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 1617 global matchinglines selectedline
977 1618 if {![info exists matchinglines]} {
1619 if {$restart} {
978 1620 dofind
1621 }
979 1622 return
980 1623 }
981 1624 if {![info exists selectedline]} return
982 1625 foreach l $matchinglines {
983 1626 if {$l > $selectedline} {
984 1627 findselectline $l
985 1628 return
986 1629 }
987 1630 }
988 1631 bell
989 1632 }
990 1633
991 1634 proc findprev {} {
992 1635 global matchinglines selectedline
993 1636 if {![info exists matchinglines]} {
994 1637 dofind
995 1638 return
996 1639 }
997 1640 if {![info exists selectedline]} return
998 1641 set prev {}
999 1642 foreach l $matchinglines {
1000 1643 if {$l >= $selectedline} break
1001 1644 set prev $l
1002 1645 }
1003 1646 if {$prev != {}} {
1004 1647 findselectline $prev
1005 1648 } else {
1006 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 1955 proc markmatches {canv l str tag matches font} {
1011 1956 set bbox [$canv bbox $tag]
1012 1957 set x0 [lindex $bbox 0]
1013 1958 set y0 [lindex $bbox 1]
1014 1959 set y1 [lindex $bbox 3]
1015 1960 foreach match $matches {
1016 1961 set start [lindex $match 0]
1017 1962 set end [lindex $match 1]
1018 1963 if {$start > $end} continue
1019 1964 set xoff [font measure $font [string range $str 0 [expr $start-1]]]
1020 1965 set xlen [font measure $font [string range $str 0 [expr $end]]]
1021 1966 set t [$canv create rect [expr $x0+$xoff] $y0 [expr $x0+$xlen+2] $y1 \
1022 1967 -outline {} -tags matches -fill yellow]
1023 1968 $canv lower $t
1024 1969 }
1025 1970 }
1026 1971
1027 1972 proc unmarkmatches {} {
1028 global matchinglines
1973 global matchinglines findids
1029 1974 allcanvs delete matches
1030 1975 catch {unset matchinglines}
1976 catch {unset findids}
1031 1977 }
1032 1978
1033 proc selcanvline {x y} {
1034 global canv canvy0 ctext linespc selectedline
1035 global lineid linehtag linentag linedtag
1979 proc selcanvline {w x y} {
1980 global canv canvy0 ctext linespc
1981 global lineid linehtag linentag linedtag rowtextx
1036 1982 set ymax [lindex [$canv cget -scrollregion] 3]
1037 1983 if {$ymax == {}} return
1038 1984 set yfrac [lindex [$canv yview] 0]
1039 1985 set y [expr {$y + $yfrac * $ymax}]
1040 1986 set l [expr {int(($y - $canvy0) / $linespc + 0.5)}]
1041 1987 if {$l < 0} {
1042 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 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 2032 global canv canv2 canv3 ctext commitinfo selectedline
1051 2033 global lineid linehtag linentag linedtag
1052 global canvy0 linespc nparents treepending
1053 global cflist treediffs currentid sha1entry
1054 global commentend seenfile numcommits idtags
2034 global canvy0 linespc parents nparents children
2035 global cflist currentid sha1entry
2036 global commentend idtags idline linknum
2037
2038 $canv delete hover
2039 normalline
1055 2040 if {![info exists lineid($l)] || ![info exists linehtag($l)]} return
1056 2041 $canv delete secsel
1057 2042 set t [eval $canv create rect [$canv bbox $linehtag($l)] -outline {{}} \
1058 2043 -tags secsel -fill [$canv cget -selectbackground]]
1059 2044 $canv lower $t
1060 2045 $canv2 delete secsel
1061 2046 set t [eval $canv2 create rect [$canv2 bbox $linentag($l)] -outline {{}} \
1062 2047 -tags secsel -fill [$canv2 cget -selectbackground]]
1063 2048 $canv2 lower $t
1064 2049 $canv3 delete secsel
1065 2050 set t [eval $canv3 create rect [$canv3 bbox $linedtag($l)] -outline {{}} \
1066 2051 -tags secsel -fill [$canv3 cget -selectbackground]]
1067 2052 $canv3 lower $t
1068 2053 set y [expr {$canvy0 + $l * $linespc}]
1069 2054 set ymax [lindex [$canv cget -scrollregion] 3]
1070 2055 set ytop [expr {$y - $linespc - 1}]
1071 2056 set ybot [expr {$y + $linespc + 1}]
1072 2057 set wnow [$canv yview]
1073 2058 set wtop [expr [lindex $wnow 0] * $ymax]
1074 2059 set wbot [expr [lindex $wnow 1] * $ymax]
1075 2060 set wh [expr {$wbot - $wtop}]
1076 2061 set newtop $wtop
1077 2062 if {$ytop < $wtop} {
1078 2063 if {$ybot < $wtop} {
1079 2064 set newtop [expr {$y - $wh / 2.0}]
1080 2065 } else {
1081 2066 set newtop $ytop
1082 2067 if {$newtop > $wtop - $linespc} {
1083 2068 set newtop [expr {$wtop - $linespc}]
1084 2069 }
1085 2070 }
1086 2071 } elseif {$ybot > $wbot} {
1087 2072 if {$ytop > $wbot} {
1088 2073 set newtop [expr {$y - $wh / 2.0}]
1089 2074 } else {
1090 2075 set newtop [expr {$ybot - $wh}]
1091 2076 if {$newtop < $wtop + $linespc} {
1092 2077 set newtop [expr {$wtop + $linespc}]
1093 2078 }
1094 2079 }
1095 2080 }
1096 2081 if {$newtop != $wtop} {
1097 2082 if {$newtop < 0} {
1098 2083 set newtop 0
1099 2084 }
1100 2085 allcanvs yview moveto [expr $newtop * 1.0 / $ymax]
1101 2086 }
2087
2088 if {$isnew} {
2089 addtohistory [list selectline $l 0]
2090 }
2091
1102 2092 set selectedline $l
1103 2093
1104 2094 set id $lineid($l)
1105 2095 set currentid $id
1106 2096 $sha1entry delete 0 end
1107 2097 $sha1entry insert 0 $id
1108 2098 $sha1entry selection from 0
1109 2099 $sha1entry selection to end
1110 2100
1111 2101 $ctext conf -state normal
1112 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 2106 set info $commitinfo($id)
1114 2107 $ctext insert end "Author: [lindex $info 1] [lindex $info 2]\n"
1115 2108 $ctext insert end "Committer: [lindex $info 3] [lindex $info 4]\n"
1116 2109 if {[info exists idtags($id)]} {
1117 2110 $ctext insert end "Tags:"
1118 2111 foreach tag $idtags($id) {
1119 2112 $ctext insert end " $tag"
1120 2113 }
1121 2114 $ctext insert end "\n"
1122 2115 }
1123 $ctext insert end "\n"
1124 $ctext insert end [lindex $info 5]
1125 $ctext insert end "\n"
2116
2117 set comment {}
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 2134 $ctext tag delete Comments
1127 2135 $ctext tag remove found 1.0 end
1128 2136 $ctext conf -state disabled
1129 2137 set commentend [$ctext index "end - 1c"]
1130 2138
1131 2139 $cflist delete 0 end
2140 $cflist insert end "Comments"
1132 2141 if {$nparents($id) == 1} {
1133 if {![info exists treediffs($id)]} {
1134 if {![info exists treepending]} {
1135 gettreediffs $id
1136 }
1137 } else {
1138 addtocflist $id
1139 }
1140 }
1141 catch {unset seenfile}
2142 startdiff [concat $id $parents($id)]
2143 } elseif {$nparents($id) > 1} {
2144 mergediff $id
2145 }
1142 2146 }
1143 2147
1144 2148 proc selnextline {dir} {
1145 2149 global selectedline
1146 2150 if {![info exists selectedline]} return
1147 2151 set l [expr $selectedline + $dir]
1148 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} {
1153 global currentid treediffs cflist treepending
1154 if {$id != $currentid} {
1155 gettreediffs $currentid
1156 return
1157 }
1158 $cflist insert end "All files"
1159 foreach f $treediffs($currentid) {
1160 $cflist insert end $f
1161 }
1162 getblobdiffs $id
2454 proc processhunks {} {
2455 global diffmergeid parents nparents currenthunk
2456 global mergefilelist diffblocked mergefds
2457 global grouphunks grouplinestart grouplineend groupfilenum
2458
2459 set nfiles [llength $mergefilelist($diffmergeid)]
2460 while 1 {
2461 set fi $nfiles
2462 set lno 0
2463 # look for the earliest hunk
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} {
1166 global treediffs parents treepending
1167 set treepending $id
1168 set treediffs($id) {}
1169 set p [lindex $parents($id) 0]
1170 if [catch {set gdtf [open "|hgit diff-tree -r $p $id" r]}] return
1171 fconfigure $gdtf -blocking 0
1172 fileevent $gdtf readable "gettreediffline $gdtf $id"
2586 set nlines [expr {$grouplineend - $grouplinestart}]
2587 $ctext insert end " +$grouplinestart,$nlines @@\n" msep
2588
2589 set events [lsort -integer -index 0 $events]
2590 set nevents [llength $events]
2591 set nmerge $nparents($diffmergeid)
2592 set l $grouplinestart
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} {
1176 global treediffs treepending
2700 proc similarity {pnum l nlc f events} {
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 2775 set n [gets $gdtf line]
1178 2776 if {$n < 0} {
1179 2777 if {![eof $gdtf]} return
1180 2778 close $gdtf
2779 set treediffs($ids) $treediff
1181 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 2790 return
1184 2791 }
1185 2792 set file [lindex $line 5]
1186 lappend treediffs($id) $file
2793 lappend treediff $file
1187 2794 }
1188 2795
1189 proc getblobdiffs {id} {
1190 global parents diffopts blobdifffd env curdifftag curtagstart
1191 global diffindex difffilestart
1192 set p [lindex $parents($id) 0]
2796 proc getblobdiffs {ids} {
2797 global diffopts blobdifffd diffids env curdifftag curtagstart
2798 global difffilestart nextupdate diffinhdr treediffs
2799
2800 set id [lindex $ids 0]
2801 set p [lindex $ids 1]
1193 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 2805 puts "error getting diffs: $err"
1196 2806 return
1197 2807 }
2808 set diffinhdr 0
1198 2809 fconfigure $bdf -blocking 0
1199 set blobdifffd($id) $bdf
2810 set blobdifffd($ids) $bdf
1200 2811 set curdifftag Comments
1201 2812 set curtagstart 0.0
1202 set diffindex 0
1203 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} {
1208 global currentid blobdifffd ctext curdifftag curtagstart seenfile
1209 global diffnexthead diffnextnote diffindex difffilestart
2818 proc getblobdiffline {bdf ids} {
2819 global diffids blobdifffd ctext curdifftag curtagstart
2820 global diffnexthead diffnextnote difffilestart
2821 global nextupdate diffinhdr treediffs
2822 global gaudydiff
2823
1210 2824 set n [gets $bdf line]
1211 2825 if {$n < 0} {
1212 2826 if {[eof $bdf]} {
1213 2827 close $bdf
1214 if {$id == $currentid && $bdf == $blobdifffd($id)} {
2828 if {$ids == $diffids && $bdf == $blobdifffd($ids)} {
1215 2829 $ctext tag add $curdifftag $curtagstart end
1216 set seenfile($curdifftag) 1
1217 2830 }
1218 2831 }
1219 2832 return
1220 2833 }
1221 if {$id != $currentid || $bdf != $blobdifffd($id)} {
2834 if {$ids != $diffids || $bdf != $blobdifffd($ids)} {
1222 2835 return
1223 2836 }
1224 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 2839 # start of a new file
1227 2840 $ctext insert end "\n"
1228 2841 $ctext tag add $curdifftag $curtagstart end
1229 set seenfile($curdifftag) 1
1230 2842 set curtagstart [$ctext index "end - 1c"]
1231 set header $fname
1232 if {[info exists diffnexthead]} {
1233 set fname $diffnexthead
1234 set header "$diffnexthead ($diffnextnote)"
1235 unset diffnexthead
1236 }
1237 set difffilestart($diffindex) [$ctext index "end - 1c"]
1238 incr diffindex
2843 set header $newname
2844 set here [$ctext index "end - 1c"]
2845 set i [lsearch -exact $treediffs($diffids) $fname]
2846 if {$i >= 0} {
2847 set difffilestart($i) $here
2848 incr i
2849 $ctext mark set fmark.$i $here
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 2861 set curdifftag "f:$fname"
1240 2862 $ctext tag delete $curdifftag
1241 2863 set l [expr {(78 - [string length $header]) / 2}]
1242 2864 set pad [string range "----------------------------------------" 1 $l]
1243 2865 $ctext insert end "$pad $header $pad\n" filesep
1244 } elseif {[string range $line 0 2] == "+++"} {
1245 # no need to do anything with this
1246 } elseif {[regexp {^Created: (.*) \((mode: *[0-7]*)\)} $line match fn m]} {
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"
2866 set diffinhdr 1
2867 } elseif {[regexp {^(---|\+\+\+)} $line]} {
2868 set diffinhdr 0
1260 2869 } elseif {[regexp {^@@ -([0-9]+),([0-9]+) \+([0-9]+),([0-9]+) @@(.*)} \
1261 2870 $line match f1l f1c f2l f2c rest]} {
2871 if {$gaudydiff} {
1262 2872 $ctext insert end "\t" hunksep
1263 2873 $ctext insert end " $f1l " d0 " $f2l " d1
1264 2874 $ctext insert end " $rest \n" hunksep
1265 2875 } else {
2876 $ctext insert end "$line\n" hunksep
2877 }
2878 set diffinhdr 0
2879 } else {
1266 2880 set x [string range $line 0 0]
1267 2881 if {$x == "-" || $x == "+"} {
1268 2882 set tag [expr {$x == "+"}]
2883 if {$gaudydiff} {
1269 2884 set line [string range $line 1 end]
2885 }
1270 2886 $ctext insert end "$line\n" d$tag
1271 2887 } elseif {$x == " "} {
2888 if {$gaudydiff} {
1272 2889 set line [string range $line 1 end]
2890 }
1273 2891 $ctext insert end "$line\n"
1274 } elseif {$x == "\\"} {
2892 } elseif {$diffinhdr || $x == "\\"} {
1275 2893 # e.g. "\ No newline at end of file"
1276 2894 $ctext insert end "$line\n" filesep
1277 2895 } else {
1278 2896 # Something else we don't recognize
1279 2897 if {$curdifftag != "Comments"} {
1280 2898 $ctext insert end "\n"
1281 2899 $ctext tag add $curdifftag $curtagstart end
1282 set seenfile($curdifftag) 1
1283 2900 set curtagstart [$ctext index "end - 1c"]
1284 2901 set curdifftag Comments
1285 2902 }
1286 2903 $ctext insert end "$line\n" filesep
1287 2904 }
1288 2905 }
1289 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 2915 proc nextfile {} {
1293 2916 global difffilestart ctext
1294 2917 set here [$ctext index @0,0]
1295 2918 for {set i 0} {[info exists difffilestart($i)]} {incr i} {
1296 2919 if {[$ctext compare $difffilestart($i) > $here]} {
1297 $ctext yview $difffilestart($i)
1298 break
1299 }
2920 if {![info exists pos]
2921 || [$ctext compare $difffilestart($i) < $pos]} {
2922 set pos $difffilestart($i)
2923 }
2924 }
2925 }
2926 if {[info exists pos]} {
2927 $ctext yview $pos
1300 2928 }
1301 2929 }
1302 2930
1303 2931 proc listboxsel {} {
1304 global ctext cflist currentid treediffs seenfile
2932 global ctext cflist currentid
1305 2933 if {![info exists currentid]} return
1306 set sel [$cflist curselection]
1307 if {$sel == {} || [lsearch -exact $sel 0] >= 0} {
1308 # show everything
1309 $ctext tag conf Comments -elide 0
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 }
2934 set sel [lsort [$cflist curselection]]
2935 if {$sel eq {}} return
2936 set first [lindex $sel 0]
2937 catch {$ctext yview fmark.$first}
1327 2938 }
1328 2939
1329 2940 proc setcoords {} {
1330 2941 global linespc charspc canvx0 canvy0 mainfont
2942 global xspc1 xspc2 lthickness
2943
1331 2944 set linespc [font metrics $mainfont -linespace]
1332 2945 set charspc [font measure $mainfont "m"]
1333 2946 set canvy0 [expr 3 + 0.5 * $linespc]
1334 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 2953 proc redisplay {} {
1338 global selectedline stopped redisplaying phase
2954 global stopped redisplaying phase
1339 2955 if {$stopped > 1} return
1340 2956 if {$phase == "getcommits"} return
1341 2957 set redisplaying 1
1342 if {$phase == "drawgraph"} {
2958 if {$phase == "drawgraph" || $phase == "incrdraw"} {
1343 2959 set stopped 1
1344 2960 } else {
1345 2961 drawgraph
1346 2962 }
1347 2963 }
1348 2964
1349 2965 proc incrfont {inc} {
1350 global mainfont namefont textfont selectedline ctext canv phase
2966 global mainfont namefont textfont ctext canv phase
1351 2967 global stopped entries
1352 2968 unmarkmatches
1353 2969 set mainfont [lreplace $mainfont 1 1 [expr {[lindex $mainfont 1] + $inc}]]
1354 2970 set namefont [lreplace $namefont 1 1 [expr {[lindex $namefont 1] + $inc}]]
1355 2971 set textfont [lreplace $textfont 1 1 [expr {[lindex $textfont 1] + $inc}]]
1356 2972 setcoords
1357 2973 $ctext conf -font $textfont
1358 2974 $ctext tag conf filesep -font [concat $textfont bold]
1359 2975 foreach e $entries {
1360 2976 $e conf -font $mainfont
1361 2977 }
1362 2978 if {$phase == "getcommits"} {
1363 2979 $canv itemconf textitems -font $mainfont
1364 2980 }
1365 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 2991 proc sha1change {n1 n2 op} {
1369 2992 global sha1string currentid sha1but
1370 2993 if {$sha1string == {}
1371 2994 || ([info exists currentid] && $sha1string == $currentid)} {
1372 2995 set state disabled
1373 2996 } else {
1374 2997 set state normal
1375 2998 }
1376 2999 if {[$sha1but cget -state] == $state} return
1377 3000 if {$state == "normal"} {
1378 3001 $sha1but conf -state normal -relief raised -text "Goto: "
1379 3002 } else {
1380 3003 $sha1but conf -state disabled -relief flat -text "SHA1 ID: "
1381 3004 }
1382 3005 }
1383 3006
1384 3007 proc gotocommit {} {
1385 3008 global sha1string currentid idline tagids
3009 global lineid numcommits
3010
1386 3011 if {$sha1string == {}
1387 3012 || ([info exists currentid] && $sha1string == $currentid)} return
1388 3013 if {[info exists tagids($sha1string)]} {
1389 3014 set id $tagids($sha1string)
1390 3015 } else {
1391 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 3033 if {[info exists idline($id)]} {
1394 selectline $idline($id)
3034 selectline $idline($id) 1
1395 3035 return
1396 3036 }
1397 if {[regexp {^[0-9a-fA-F]{40}$} $sha1string]} {
3037 if {[regexp {^[0-9a-fA-F]{4,}$} $sha1string]} {
1398 3038 set type "SHA1 id"
1399 3039 } else {
1400 3040 set type "Tag"
1401 3041 }
1402 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 3601 proc doquit {} {
1406 3602 global stopped
1407 3603 set stopped 100
1408 3604 destroy .
1409 3605 }
1410 3606
1411 3607 # defaults...
1412 3608 set datemode 0
1413 3609 set boldnames 0
1414 3610 set diffopts "-U 5 -p"
3611 set wrcomcmd "hg git-diff-tree --stdin -p --pretty"
1415 3612
1416 3613 set mainfont {Helvetica 9}
1417 3614 set textfont {Courier 9}
3615 set findmergefiles 0
3616 set gaudydiff 0
3617 set maxgraphpct 50
3618 set maxwidth 16
1418 3619
1419 3620 set colors {green red blue magenta darkgrey brown orange}
1420 set colorbycommitter false
1421 3621
1422 3622 catch {source ~/.gitk}
1423 3623
1424 3624 set namefont $mainfont
1425 3625 if {$boldnames} {
1426 3626 lappend namefont bold
1427 3627 }
1428 3628
1429 3629 set revtreeargs {}
1430 3630 foreach arg $argv {
1431 3631 switch -regexp -- $arg {
1432 3632 "^$" { }
1433 3633 "^-b" { set boldnames 1 }
1434 "^-c" { set colorbycommitter 1 }
1435 3634 "^-d" { set datemode 1 }
1436 3635 default {
1437 3636 lappend revtreeargs $arg
1438 3637 }
1439 3638 }
1440 3639 }
1441 3640
3641 set history {}
3642 set historyindex 0
3643
1442 3644 set stopped 0
1443 3645 set redisplaying 0
1444 3646 set stuffsaved 0
3647 set patchnum 0
1445 3648 setcoords
1446 3649 makewindow
1447 3650 readrefs
1448 readfullcommits $revtreeargs
3651 getcommits $revtreeargs
General Comments 0
You need to be logged in to leave comments. Login now