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